Файловый менеджер

Файловый менеджер - Редактировать - /usr/share/perl5/Debian/Defoma/Subst.pm

Назад
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(&register_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;

| ver. 1.4 | Github | . | PHP 5.4.45-1~dotdeb+6.1 | Генерация страницы: 0.02 | proxy | phpinfo | Настройка