home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / Debian / Defoma / Subst.pm < prev    next >
Encoding:
Perl POD Document  |  2006-06-17  |  11.8 KB  |  550 lines
  1. package Debian::Defoma::Subst;;
  2.  
  3. use strict;
  4. use POSIX;
  5. use Exporter;
  6. use Debian::Defoma::Common;
  7. use Debian::Defoma::SubstCache;
  8. use Debian::Defoma::Id;
  9. import Debian::Defoma::Common qw(®ister_subst_object &get_subst_object
  10.                  $DEFAULT_PACKAGE $DEFAULT_CATEGORY);
  11.  
  12. use vars qw(@EXPORT @ISA $DEFAULT_PACKAGE $DEFAULT_CATEGORY);
  13.  
  14. @ISA = qw(Exporter);
  15. @EXPORT = qw(&defoma_subst_open &defoma_subst_close
  16.          &defoma_subst_register &defoma_subst_unregister
  17.          &defoma_subst_add_rule &defoma_subst_remove_rule
  18.          &defoma_subst_remove_rule_by_num &defoma_subst_newrule);
  19.  
  20. sub emes {
  21.     if ($DEFAULT_PACKAGE && $DEFAULT_CATEGORY) {
  22.     printw("Subst: $DEFAULT_PACKAGE/$DEFAULT_CATEGORY: ", @_);
  23.     } else {
  24.     printw("Subst: ", @_);
  25.     }
  26. }
  27.  
  28. sub emesd {
  29.     if ($DEFAULT_PACKAGE && $DEFAULT_CATEGORY) {
  30.     printd("Subst: $DEFAULT_PACKAGE/$DEFAULT_CATEGORY: ", @_);
  31.     } else {
  32.     printd("Subst: ", @_);
  33.     }
  34. }
  35.  
  36. sub generate_hash {
  37.     my @list = @_;
  38.     my $key = '';
  39.     my $hashptr = {};
  40.     my $flagptr = {};
  41.     my $flag;
  42.  
  43.     for (my $i = 0; $i < @list; $i++) {
  44.     if ($list[$i] =~ /^--(.*)/) {
  45.         $key = $list[$i];
  46.  
  47.         if ($key =~ /(.+),(.)/) {
  48.         $key = $1;
  49.         $flag = $2;
  50.         } else {
  51.         $flag = 1;
  52.         }
  53.  
  54.         $flagptr->{$key} = $flag;
  55.     } elsif ($key ne '') {
  56.         add_hash_list($hashptr, $key, $list[$i]);
  57.     }
  58.     }
  59.  
  60.     $hashptr->{flag} = $flagptr;
  61.  
  62.     return $hashptr;
  63. }
  64.  
  65. sub get_base_priority {
  66.     my $hints = shift;
  67.     my $rule = shift;
  68.     my $priority = 0;
  69.     my ($p, $pc);
  70.     my $matchflag;
  71.     my $i;
  72.     my $j;
  73.     my $k;
  74.     my $key;
  75.     my $max = 0;
  76.  
  77.     my @rule_keys = keys(%{$rule});
  78.     my @hints_values;
  79.     my @rule_values;
  80.  
  81.     for ($i = 0; $i < @rule_keys; $i++) {
  82.     $key = $rule_keys[$i];
  83.     next if ($key eq 'flag');
  84.  
  85.     if (exists($hints->{$key})) {
  86.         @hints_values = split(' ', $hints->{$key});
  87.     } else {
  88.         @hints_values = ();
  89.     }
  90.     
  91.     @rule_values = split(/ /, $rule->{$key});
  92.  
  93.     $matchflag = 0;
  94.  
  95.     $pc = $p = $rule->{flag}->{$key};
  96.     $p = 1 if ($pc =~ /[^123]/);
  97.     
  98.     for ($j = 0; $j < @rule_values; $j++) {
  99.         $max += $p;
  100.         
  101.         for ($k = 0; $k < @hints_values; $k++) {
  102.         if ($rule_values[$j] eq $hints_values[$k]) {
  103.             $priority += $p;
  104.             $matchflag++;
  105.         }
  106.         }
  107.     }
  108.  
  109.     if ($matchflag == 0 && $pc eq '*') {
  110.         return -1;
  111.     }
  112.     }
  113.  
  114.     return -1 if ($max == 0);
  115.  
  116.     $priority = int($priority * 100 / $max);
  117.     
  118.     return $priority;
  119. }
  120.  
  121. sub ar_rule {
  122.     my $com = shift;
  123.     my $sobj = shift;
  124.     my $idx = shift;
  125.     my $ruleid = shift;
  126.     my $prule = shift;
  127.  
  128.     my $rulename = $sobj->{rulename};
  129.     my $iobj = $sobj->{idobject};
  130.     my $threshold = $sobj->{threshold};
  131.     
  132.     my ($i, $id, $font, $pri, $phints, $ctg, $p, $ret, $j);
  133.     my (@l, @list);
  134.     my @hints;
  135.  
  136.     $iobj->{delay}++;
  137.  
  138.     @list = keys(%{$sobj->{cache}});
  139.  
  140.     foreach $i (@list) {
  141.     @l = split(/ /, $i);
  142.     $font = $l[0];
  143.     $id = $l[1];
  144.  
  145.     $j = $sobj->{cache}->{$i};
  146.  
  147.     $phints = $j->{hash};
  148.     $ctg = $j->{category};
  149.     $pri = $j->{priority};
  150.  
  151.     unless ($phints) {
  152. #        @l = $iobj->grep('real', f0 => $id, f1 => $font);
  153. #        next unless(@l);
  154.         if (exists($iobj->{hash01}->{$id.' '.$font})) {
  155.         $l[0] = $iobj->{hash01}->{$id.' '.$font};
  156.         next unless ($iobj->{2}->[$l[0]] =~ /^Sr/);
  157.         } else {
  158.         next;
  159.         }
  160.         
  161.         
  162.         @hints = split(' ', $iobj->{7}->[$l[0]]);
  163.         
  164.         $phints = generate_hash(@hints);
  165.         $j->{hash} = $phints;
  166.         $j->{category} = $ctg = $iobj->{4}->[$l[0]];
  167.         $j->{priority} = $pri = $iobj->{3}->[$l[0]] / 10;
  168.     }
  169.  
  170.     $p = get_base_priority($phints, $prule);
  171.     
  172.     next if ($p < 40);
  173.     next if ($com && $p < $threshold && $sobj->{rule_regnum}->[$idx]);
  174.  
  175.     $p += $pri;
  176.  
  177.     if ($com) {
  178.         $ret = defoma_id_register($iobj, type => 'subst', font => $font,
  179.                       id => $ruleid, priority => $p,
  180.                       category => $ctg, origin => $id);
  181.         $sobj->{rule_regnum}->[$idx]++ unless ($ret);
  182.     } else {
  183.         $ret = defoma_id_unregister($iobj, type => 'subst', font => $font,
  184.                     id => $ruleid);
  185.         $sobj->{rule_regnum}->[$idx]-- unless ($ret);
  186.     }
  187.     
  188.     }
  189.  
  190.     $iobj->{delay}--;
  191.     defoma_id_update($iobj, $ruleid);
  192. }
  193.  
  194. sub ar_font {
  195.     my $com = shift;
  196.     my $sobj = shift;
  197.     my $font = shift;
  198.     my $id = shift;
  199.     my $pri = shift(@_);
  200.     my $ctg = shift;
  201.     my $phints = shift;
  202.  
  203.     my $rulename = $sobj->{rulename};
  204.     my $iobj = $sobj->{idobject};
  205.     my $threshold = $sobj->{threshold};
  206.  
  207.     my @rule;
  208.     
  209.     my ($i, $max, $j, $ruleid, $prule, $p, $ret);
  210.     $max = $sobj->{rule_cnt};
  211.  
  212.     for ($i = 0; $i < $max; $i++) {
  213.     $j = $sobj->{rule}->[$i];
  214.     next if ($j eq '' || $j =~ /^\#/);
  215.     
  216.     @rule = split(/[ \t]+/, $j);
  217.     $ruleid = shift(@rule);
  218.     $prule = $sobj->{rule_hash}->[$i];
  219.     unless ($prule) {
  220.         $prule = generate_hash(@rule);
  221.         $sobj->{rule_hash}->[$i] = $prule;
  222.     }
  223.  
  224.     $p = get_base_priority($phints, $prule);
  225.  
  226.     next if ($p < 40);
  227.     next if ($com && $p < $threshold && $sobj->{rule_regnum}->[$i]);
  228.  
  229.     $p += $pri;
  230.  
  231.     if ($com) {
  232.         $ret = defoma_id_register($iobj, type => 'subst', font => $font,
  233.                       id => $ruleid, priority => $p,
  234.                       category => $ctg, origin => $id);
  235.         $sobj->{rule_regnum}->[$i]++ unless ($ret);
  236.     } else {
  237.         $ret = defoma_id_unregister($iobj, type => 'subst', font => $font,
  238.                     id => $ruleid);
  239.         $sobj->{rule_regnum}->[$i]-- unless ($ret);
  240.     }
  241.  
  242. #    &Debian::Defoma::Configure::call_1(0, $sobj->{pkg}, $com, $ctg, $font,
  243. #                       $ruleid, $p, $id, $rulename);
  244.     }
  245. }
  246.  
  247. sub defoma_subst_open {
  248.     my %args = @_;
  249.  
  250.     return -1 unless (exists($args{rulename}));
  251.     
  252.     my $rulename = $args{rulename};
  253.  
  254.     my $threshold = exists($args{threshold}) ? $args{threshold} : 30;
  255.     
  256.     my $idobject = exists($args{idobject}) ? $args{idobject} : '';
  257.     my $pkg = '';
  258.     my $suffix = '';
  259.     if ($idobject) {
  260.     $pkg = $idobject->{pkg};
  261.     $suffix = $idobject->{suffix};
  262.     }
  263.  
  264.     my $prv = $args{private};
  265.     my $private = '';
  266.  
  267.     if ($prv) {
  268.     return -1 unless ($idobject);
  269.     $private = $pkg.'/';
  270.     }
  271.     
  272.     my $o = get_subst_object($private . $rulename);
  273.     return $o if ($o);
  274.  
  275.     my $rulefile;
  276.     my $cachefile;
  277.     
  278.     if ($prv) {
  279.     my $dir = ROOTDIR . '/' . $pkg . '.d/';
  280.     
  281.     $rulefile = $dir . $rulename . '.private-subst-rule';
  282.     $cachefile = $dir . $rulename . '.private-subst-cache';
  283.     } else {
  284.     $rulefile = SUBSTRULEDIR . '/' . $rulename . '.subst-rule';
  285.     $cachefile = ROOTDIR . '/' . $rulename . '.subst-cache';
  286.     }
  287.  
  288.     $o = new Debian::Defoma::SubstCache($rulename, $cachefile, $rulefile, 
  289.                     $pkg, $suffix, $idobject);
  290.     $o->{threshold} = $threshold;
  291.     $o->read();
  292.     
  293.     if (! $idobject && $o->{pkg}) {
  294.     $idobject = $o->{idobject} = defoma_id_open_cache($o->{idsuffix},
  295.                                $o->{pkg});
  296.     }
  297.  
  298.     if ($idobject) {
  299.     my $max = $o->{rule_cnt};
  300.     my ($i, $j);
  301.     for ($i = 0; $i < $max; $i++) {
  302.         $j = $o->{rule}->[$i];
  303.         next if ($j eq '' || $j =~ /^\#/);
  304.         $j =~ /^([^ \t]+) /;
  305.         my $ruleid = $1;
  306.  
  307.         $o->{rule_regnum}->[$i] = $idobject->grep('subst', f0 => $ruleid);
  308.     }
  309.     }
  310.  
  311.     register_subst_object($o, $private . $rulename);
  312.  
  313.     return $o;
  314. }
  315.  
  316. sub defoma_subst_close {
  317.     my $o = shift;
  318.     if ($o) {
  319.     $o->write();
  320.     }
  321. }
  322.  
  323. sub defoma_subst_register {
  324.     return -1 if (@_ < 3);
  325.     my $sobj = shift;
  326.     my $font = shift;
  327.     my $id = shift;
  328.     my $iobj = $sobj->{idobject};
  329.     my @l;
  330.  
  331.     unless ($iobj) {
  332.     emes("IdObject is not set in SubstObject.");
  333.     return -1;
  334.     }
  335.  
  336.     if (exists($sobj->{cache}->{$font.' '.$id})) {
  337.     emesd("$font, $id: already registered in subst-cache.");
  338.     return -1;
  339.     }
  340.  
  341. #    @l = $iobj->grep('real', f0 => $id, f1 => $font);
  342. #    unless (@l) {
  343.     unless (exists($iobj->{hash01}->{$id.' '.$font})) {
  344.     emesd("$font, $id: not registered in id-cache.");
  345.     return -1;
  346.     }
  347.     $l[0] = $iobj->{hash01}->{$id.' '.$font};
  348.     unless ($iobj->{2}->[$l[0]] =~ /^Sr/) {
  349.     emesd("$font, $id: not registered in id-cache.");
  350.     return -1;
  351.     }
  352.  
  353.     my @hints = split(' ', $iobj->{7}->[$l[0]]);
  354.     my $hash = generate_hash(@hints);
  355.     my $pri = $iobj->{3}->[$l[0]] / 10;
  356.     my $ctg = $iobj->{4}->[$l[0]];
  357.     
  358.     $sobj->add_cache($font, $id, $hash, $pri, $ctg);
  359.  
  360.     ar_font(1, $sobj, $font, $id, $pri, $ctg, $hash);
  361.  
  362.     return 0;
  363. }
  364.  
  365. sub defoma_subst_unregister {
  366.     return -1 if (@_ < 2);
  367.     my $sobj = shift;
  368.     my $font = shift;
  369.     my $id = shift;
  370.     my $iobj = $sobj->{idobject};
  371.     my ($hash, $pri, $ctg);
  372.     my (@hints, @l);
  373.  
  374.     unless ($iobj) {
  375.     emes("$sobj->{rulename}: IdObject is not set in SubstObject.");
  376.     return -1;
  377.     }
  378.  
  379.     my @ids = ();
  380.     
  381.     if ($id) {
  382.     if (exists($sobj->{cache}->{$font.' '.$id})) {
  383.         push(@ids, $id);
  384.     } else {
  385.         emesd("$font, $id: not registered in subst-cache.");
  386.         return -1;
  387.     }
  388.     } else {
  389.     @l = keys(%{$sobj->{cache}});
  390.     foreach $id (@l) {
  391.         $id =~ /^([^ ]+) ([^ ]+)$/;
  392.         push(@ids, $2) if ($1 eq $font);
  393.     }
  394.     }
  395.  
  396.     foreach $id (@ids) {
  397.     my $p = $sobj->{cache}->{$font.' '.$id};
  398.  
  399.     $hash = $p->{hash};
  400.     $ctg = $p->{category};
  401.     $pri = $p->{priority};
  402.     unless ($hash) {
  403. #        @l = $iobj->grep('real', f0 => $id, f1 => $font);
  404.         if (exists($iobj->{hash01}->{$id.' '.$font})) {
  405.         $l[0] = $iobj->{hash01}->{$id.' '.$font};
  406.         next unless ($iobj->{2}->[$l[0]] =~ /^Sr/);
  407.         } else {
  408.         next;
  409.         }
  410.         @hints = split(' ', $iobj->{7}->[$l[0]]);
  411.  
  412.         $hash = generate_hash(@hints);
  413.         $pri = $iobj->{3}->[$l[0]];
  414.     }
  415.  
  416.     ar_font(0, $sobj, $font, $id, $pri, $ctg, $hash);
  417.  
  418.     delete($sobj->{cache}->{$font.' '.$id});
  419.     }
  420.     
  421.     return 0;
  422. }
  423.     
  424. sub defoma_subst_add_rule {
  425.     my $sobj = shift;
  426.     my $rule = join(' ', @_);
  427.     my $idx;
  428.  
  429.     if ($sobj->grep_rule($rule)) {
  430.     emesd("$sobj->{rulename}: Specified rule already exists.");
  431.     return -1;
  432.     }
  433.  
  434.     my $ruleid = shift;
  435.     my $hash = generate_hash(@_);
  436.  
  437.     $idx = $sobj->add_rule($rule, $hash);
  438.  
  439.     unless ($sobj->{idobject}) {
  440.     emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
  441.     return -1;
  442.     }
  443.  
  444.     ar_rule(1, $sobj, $idx, $ruleid, $hash);
  445.  
  446.     return 0;
  447. }
  448.  
  449. sub defoma_subst_remove_rule_by_num {
  450.     my $sobj = shift;
  451.     my $i = shift;
  452.  
  453.     my @rule = split(' ', $sobj->{rule}->[$i]);
  454.     my $ruleid = shift(@rule);
  455.     my $hash = $sobj->{rule_hash}->[$i];
  456.     unless ($hash) {
  457.     $hash = generate_hash(@rule);
  458.     }
  459.     
  460.     $sobj->delete_rule($i);
  461.     
  462.     unless ($sobj->{idobject}) {
  463.     emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
  464.     next;
  465.     }
  466.     
  467.     ar_rule(0, $sobj, $i, $ruleid, $hash);
  468. }
  469.  
  470.     
  471.  
  472. sub defoma_subst_remove_rule {
  473.     my $sobj = shift;
  474.     my ($rule, $ruleid);
  475.     my @l;
  476.  
  477.     return -1 if (@_ == 0);
  478.     
  479.     if (@_ == 1) {
  480.     $ruleid = shift;
  481.     @l = $sobj->grep_rule('', $ruleid);
  482.     } else {
  483.     $ruleid = shift;
  484.     $rule = join(' ', $ruleid, @_);
  485.     @l = $sobj->grep_rule($rule);
  486.     }
  487.  
  488.     my @r;
  489.     foreach my $i (@l) {
  490.     my $hash = $sobj->{rule_hash}->[$i];
  491.     unless ($hash) {
  492.         @r = split(' ', $sobj->{rule}->[$i]);
  493.         shift(@r);
  494.         $hash = generate_hash(@r);
  495.     }
  496.  
  497.     $sobj->delete_rule($i);
  498.  
  499.     unless ($sobj->{idobject}) {
  500.         emesd("$sobj->{rulename}: IdObject is not set in SubstObject.");
  501.         next;
  502.     }
  503.  
  504.     ar_rule(0, $sobj, $i, $ruleid, $hash);
  505.     }
  506.  
  507.     return 0;
  508. }
  509.  
  510. sub defoma_subst_newrule {
  511.     my $file = shift;
  512.     my $rulename = shift;
  513.  
  514.     if (open(F, '>' . $file)) {
  515.     my $text = <<EOF
  516. # Debian Font Manager: Substitute Rule for $rulename
  517. # 
  518. # DO NOT EDIT THIS FILE DIRECTLY! IF YOU WANT TO EDIT, TYPE
  519. # defoma-subst edit-rule $rulename
  520. # INSTEAD.
  521. # 
  522. # This file describes identifiers that other fonts must substitute for and
  523. # their information.
  524. # Each line contains one identifier of a font and some hints about the font.
  525. # Syntax of hints is:
  526. #  --<HintTypeA>[,Score] <hint1> .. --<HintTypeB>[,Score] <hintA>..
  527. # HintType specifies the type of hint, like Family, Weight and Charset.
  528. # Score specifies the degree of importance of the HintType and is either of 
  529. # 1, 2, 3 or *. The larger number, the more important. '*' means the 
  530. # specified HintType is required to match.
  531. # 
  532. # Each item in a line is separated by space.
  533. # Lines starting with '#' are ignored.
  534. #
  535. EOF
  536.     ;
  537.     print F $text;
  538.  
  539.     foreach my $i (@_) {
  540.         print F $i, "\n";
  541.     }
  542.     
  543.     close F;
  544.     }
  545. }
  546.  
  547.  
  548. 1;
  549.  
  550.