Your IP : 216.73.216.170
package Debian::Defoma::Subst;;
use strict;
use POSIX;
use Exporter;
use Debian::Defoma::Common;
use Debian::Defoma::SubstCache;
use Debian::Defoma::Id;
import Debian::Defoma::Common qw(®ister_subst_object &get_subst_object
$DEFAULT_PACKAGE $DEFAULT_CATEGORY);
use vars qw(@EXPORT @ISA $DEFAULT_PACKAGE $DEFAULT_CATEGORY);
@ISA = qw(Exporter);
@EXPORT = qw(&defoma_subst_open &defoma_subst_close
&defoma_subst_register &defoma_subst_unregister
&defoma_subst_add_rule &defoma_subst_remove_rule
&defoma_subst_remove_rule_by_num &defoma_subst_newrule);
sub emes {
if ($DEFAULT_PACKAGE && $DEFAULT_CATEGORY) {
printw("Subst: $DEFAULT_PACKAGE/$DEFAULT_CATEGORY: ", @_);
} else {
printw("Subst: ", @_);
}
}
sub emesd {
if ($DEFAULT_PACKAGE && $DEFAULT_CATEGORY) {
printd("Subst: $DEFAULT_PACKAGE/$DEFAULT_CATEGORY: ", @_);
} else {
printd("Subst: ", @_);
}
}
sub generate_hash {
my @list = @_;
my $key = '';
my $hashptr = {};
my $flagptr = {};
my $flag;
for (my $i = 0; $i < @list; $i++) {
if ($list[$i] =~ /^--(.*)/) {
$key = $list[$i];
if ($key =~ /(.+),(.)/) {
$key = $1;
$flag = $2;
} else {
$flag = 1;
}
$flagptr->{$key} = $flag;
} elsif ($key ne '') {
add_hash_list($hashptr, $key, $list[$i]);
}
}
$hashptr->{flag} = $flagptr;
return $hashptr;
}
sub get_base_priority {
my $hints = shift;
my $rule = shift;
my $priority = 0;
my ($p, $pc);
my $matchflag;
my $i;
my $j;
my $k;
my $key;
my $max = 0;
my @rule_keys = keys(%{$rule});
my @hints_values;
my @rule_values;
for ($i = 0; $i < @rule_keys; $i++) {
$key = $rule_keys[$i];
next if ($key eq 'flag');
if (exists($hints->{$key})) {
@hints_values = split(' ', $hints->{$key});
} else {
@hints_values = ();
}
@rule_values = split(/ /, $rule->{$key});
$matchflag = 0;
$pc = $p = $rule->{flag}->{$key};
$p = 1 if ($pc =~ /[^123]/);
for ($j = 0; $j < @rule_values; $j++) {
$max += $p;
for ($k = 0; $k < @hints_values; $k++) {
if ($rule_values[$j] eq $hints_values[$k]) {
$priority += $p;
$matchflag++;
}
}
}
if ($matchflag == 0 && $pc eq '*') {
return -1;
}
}
return -1 if ($max == 0);
$priority = int($priority * 100 / $max);
return $priority;
}
sub ar_rule {
my $com = shift;
my $sobj = shift;
my $idx = shift;
my $ruleid = shift;
my $prule = shift;
my $rulename = $sobj->{rulename};
my $iobj = $sobj->{idobject};
my $threshold = $sobj->{threshold};
my ($i, $id, $font, $pri, $phints, $ctg, $p, $ret, $j);
my (@l, @list);
my @hints;
$iobj->{delay}++;
@list = keys(%{$sobj->{cache}});
foreach $i (@list) {
@l = split(/ /, $i);
$font = $l[0];
$id = $l[1];
$j = $sobj->{cache}->{$i};
$phints = $j->{hash};
$ctg = $j->{category};
$pri = $j->{priority};
unless ($phints) {
# @l = $iobj->grep('real', f0 => $id, f1 => $font);
# next unless(@l);
if (exists($iobj->{hash01}->{$id.' '.$font})) {
$l[0] = $iobj->{hash01}->{$id.' '.$font};
next unless ($iobj->{2}->[$l[0]] =~ /^Sr/);
} else {
next;
}
@hints = split(' ', $iobj->{7}->[$l[0]]);
$phints = generate_hash(@hints);
$j->{hash} = $phints;
$j->{category} = $ctg = $iobj->{4}->[$l[0]];
$j->{priority} = $pri = $iobj->{3}->[$l[0]] / 10;
}
$p = get_base_priority($phints, $prule);
next if ($p < 40);
next if ($com && $p < $threshold && $sobj->{rule_regnum}->[$idx]);
$p += $pri;
if ($com) {
$ret = defoma_id_register($iobj, type => 'subst', font => $font,
id => $ruleid, priority => $p,
category => $ctg, origin => $id);
$sobj->{rule_regnum}->[$idx]++ unless ($ret);
} else {
$ret = defoma_id_unregister($iobj, type => 'subst', font => $font,
id => $ruleid);
$sobj->{rule_regnum}->[$idx]-- unless ($ret);
}
}
$iobj->{delay}--;
defoma_id_update($iobj, $ruleid);
}
sub ar_font {
my $com = shift;
my $sobj = shift;
my $font = shift;
my $id = shift;
my $pri = shift(@_);
my $ctg = shift;
my $phints = shift;
my $rulename = $sobj->{rulename};
my $iobj = $sobj->{idobject};
my $threshold = $sobj->{threshold};
my @rule;
my ($i, $max, $j, $ruleid, $prule, $p, $ret);
$max = $sobj->{rule_cnt};
for ($i = 0; $i < $max; $i++) {
$j = $sobj->{rule}->[$i];
next if ($j eq '' || $j =~ /^\#/);
@rule = split(/[ \t]+/, $j);
$ruleid = shift(@rule);
$prule = $sobj->{rule_hash}->[$i];
unless ($prule) {
$prule = generate_hash(@rule);
$sobj->{rule_hash}->[$i] = $prule;
}
$p = get_base_priority($phints, $prule);
next if ($p < 40);
next if ($com && $p < $threshold && $sobj->{rule_regnum}->[$i]);
$p += $pri;
if ($com) {
$ret = defoma_id_register($iobj, type => 'subst', font => $font,
id => $ruleid, priority => $p,
category => $ctg, origin => $id);
$sobj->{rule_regnum}->[$i]++ unless ($ret);
} else {
$ret = defoma_id_unregister($iobj, type => 'subst', font => $font,
id => $ruleid);
$sobj->{rule_regnum}->[$i]-- unless ($ret);
}
# &Debian::Defoma::Configure::call_1(0, $sobj->{pkg}, $com, $ctg, $font,
# $ruleid, $p, $id, $rulename);
}
}
sub defoma_subst_open {
my %args = @_;
return -1 unless (exists($args{rulename}));
my $rulename = $args{rulename};
my $threshold = exists($args{threshold}) ? $args{threshold} : 30;
my $idobject = exists($args{idobject}) ? $args{idobject} : '';
my $pkg = '';
my $suffix = '';
if ($idobject) {
$pkg = $idobject->{pkg};
$suffix = $idobject->{suffix};
}
my $prv = $args{private};
my $private = '';
if ($prv) {
return -1 unless ($idobject);
$private = $pkg.'/';
}
my $o = get_subst_object($private . $rulename);
return $o if ($o);
my $rulefile;
my $cachefile;
if ($prv) {
my $dir = ROOTDIR . '/' . $pkg . '.d/';
$rulefile = $dir . $rulename . '.private-subst-rule';
$cachefile = $dir . $rulename . '.private-subst-cache';
} else {
$rulefile = SUBSTRULEDIR . '/' . $rulename . '.subst-rule';
$cachefile = ROOTDIR . '/' . $rulename . '.subst-cache';
}
$o = new Debian::Defoma::SubstCache($rulename, $cachefile, $rulefile,
$pkg, $suffix, $idobject);
$o->{threshold} = $threshold;
$o->read();
if (! $idobject && $o->{pkg}) {
$idobject = $o->{idobject} = defoma_id_open_cache($o->{idsuffix},
$o->{pkg});
}
if ($idobject) {
my $max = $o->{rule_cnt};
my ($i, $j);
for ($i = 0; $i < $max; $i++) {
$j = $o->{rule}->[$i];
next if ($j eq '' || $j =~ /^\#/);
$j =~ /^([^ \t]+) /;
my $ruleid = $1;
$o->{rule_regnum}->[$i] = $idobject->grep('subst', f0 => $ruleid);
}
}
register_subst_object($o, $private . $rulename);
return $o;
}
sub defoma_subst_close {
my $o = shift;
if ($o) {
$o->write();
}
}
sub defoma_subst_register {
return -1 if (@_ < 3);
my $sobj = shift;
my $font = shift;
my $id = shift;
my $iobj = $sobj->{idobject};
my @l;
unless ($iobj) {
emes("IdObject is not set in SubstObject.");
return -1;
}
if (exists($sobj->{cache}->{$font.' '.$id})) {
emesd("$font, $id: already registered in subst-cache.");
return -1;
}
# @l = $iobj->grep('real', f0 => $id, f1 => $font);
# unless (@l) {
unless (exists($iobj->{hash01}->{$id.' '.$font})) {
emesd("$font, $id: not registered in id-cache.");
return -1;
}
$l[0] = $iobj->{hash01}->{$id.' '.$font};
unless ($iobj->{2}->[$l[0]] =~ /^Sr/) {
emesd("$font, $id: not registered in id-cache.");
return -1;
}
my @hints = split(' ', $iobj->{7}->[$l[0]]);
my $hash = generate_hash(@hints);
my $pri = $iobj->{3}->[$l[0]] / 10;
my $ctg = $iobj->{4}->[$l[0]];
$sobj->add_cache($font, $id, $hash, $pri, $ctg);
ar_font(1, $sobj, $font, $id, $pri, $ctg, $hash);
return 0;
}
sub defoma_subst_unregister {
return -1 if (@_ < 2);
my $sobj = shift;
my $font = shift;
my $id = shift;
my $iobj = $sobj->{idobject};
my ($hash, $pri, $ctg);
my (@hints, @l);
unless ($iobj) {
emes("$sobj->{rulename}: IdObject is not set in SubstObject.");
return -1;
}
my @ids = ();
if ($id) {
if (exists($sobj->{cache}->{$font.' '.$id})) {
push(@ids, $id);
} else {
emesd("$font, $id: not registered in subst-cache.");
return -1;
}
} else {
@l = keys(%{$sobj->{cache}});
foreach $id (@l) {
$id =~ /^([^ ]+) ([^ ]+)$/;
push(@ids, $2) if ($1 eq $font);
}
}
foreach $id (@ids) {
my $p = $sobj->{cache}->{$font.' '.$id};
$hash = $p->{hash};
$ctg = $p->{category};
$pri = $p->{priority};
unless ($hash) {
# @l = $iobj->grep('real', f0 => $id, f1 => $font);
if (exists($iobj->{hash01}->{$id.' '.$font})) {
$l[0] = $iobj->{hash01}->{$id.' '.$font};
next unless ($iobj->{2}->[$l[0]] =~ /^Sr/);
} else {
next;
}
@hints = split(' ', $iobj->{7}->[$l[0]]);
$hash = generate_hash(@hints);
$pri = $iobj->{3}->[$l[0]];
}
ar_font(0, $sobj, $font, $id, $pri, $ctg, $hash);
delete($sobj->{cache}->{$font.' '.$id});
}
return 0;
}
sub defoma_subst_add_rule {
my $sobj = shift;
my $rule = join(' ', @_);
my $idx;
if ($sobj->grep_rule($rule)) {
emesd("$sobj->{rulename}: Specified rule already exists.");
return -1;
}
my $ruleid = shift;
my $hash = generate_hash(@_);
$idx = $sobj->add_rule($rule, $hash);
unless ($sobj->{idobject}) {
emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
return -1;
}
ar_rule(1, $sobj, $idx, $ruleid, $hash);
return 0;
}
sub defoma_subst_remove_rule_by_num {
my $sobj = shift;
my $i = shift;
my @rule = split(' ', $sobj->{rule}->[$i]);
my $ruleid = shift(@rule);
my $hash = $sobj->{rule_hash}->[$i];
unless ($hash) {
$hash = generate_hash(@rule);
}
$sobj->delete_rule($i);
unless ($sobj->{idobject}) {
emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
next;
}
ar_rule(0, $sobj, $i, $ruleid, $hash);
}
sub defoma_subst_remove_rule {
my $sobj = shift;
my ($rule, $ruleid);
my @l;
return -1 if (@_ == 0);
if (@_ == 1) {
$ruleid = shift;
@l = $sobj->grep_rule('', $ruleid);
} else {
$ruleid = shift;
$rule = join(' ', $ruleid, @_);
@l = $sobj->grep_rule($rule);
}
my @r;
foreach my $i (@l) {
my $hash = $sobj->{rule_hash}->[$i];
unless ($hash) {
@r = split(' ', $sobj->{rule}->[$i]);
shift(@r);
$hash = generate_hash(@r);
}
$sobj->delete_rule($i);
unless ($sobj->{idobject}) {
emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
next;
}
ar_rule(0, $sobj, $i, $ruleid, $hash);
}
return 0;
}
sub defoma_subst_newrule {
my $file = shift;
my $rulename = shift;
if (open(F, '>' . $file)) {
my $text = <<EOF
# Debian Font Manager: Substitute Rule for $rulename
#
# DO NOT EDIT THIS FILE DIRECTLY! IF YOU WANT TO EDIT, TYPE
# defoma-subst edit-rule $rulename
# INSTEAD.
#
# This file describes identifiers that other fonts must substitute for and
# their information.
# Each line contains one identifier of a font and some hints about the font.
# Syntax of hints is:
# --<HintTypeA>[,Score] <hint1> .. --<HintTypeB>[,Score] <hintA>..
# HintType specifies the type of hint, like Family, Weight and Charset.
# Score specifies the degree of importance of the HintType and is either of
# 1, 2, 3 or *. The larger number, the more important. '*' means the
# specified HintType is required to match.
#
# Each item in a line is separated by space.
# Lines starting with '#' are ignored.
#
EOF
;
print F $text;
foreach my $i (@_) {
print F $i, "\n";
}
close F;
}
}
1;