home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / Debian / Defoma / Id.pm < prev    next >
Encoding:
Perl POD Document  |  2006-06-17  |  14.5 KB  |  659 lines
  1. package Debian::Defoma::Id;
  2.  
  3. use strict;
  4. use POSIX;
  5. use Exporter;
  6.  
  7. use vars qw(@EXPORT @EXPORT_OK @ISA $DEFAULT_PACKAGE $DEFAULT_CATEGORY
  8.         $Purge $IDOBJECT);
  9.  
  10. use Debian::Defoma::Common;
  11. use Debian::Defoma::IdCache;
  12. import Debian::Defoma::Common qw(®ister_id_object &get_id_object
  13.                  &arg_check
  14.                  $DEFAULT_PACKAGE $DEFAULT_CATEGORY);
  15.  
  16.  
  17. @ISA = qw(Exporter);
  18.  
  19. @EXPORT = qw(&defoma_id_register &defoma_id_unregister
  20.          &defoma_id_open_cache &defoma_id_close_cache
  21.          &defoma_id_get_font &defoma_id_grep_cache
  22.          &defoma_id_set &defoma_id_unset
  23.          &defoma_id_update &defoma_id_get_hints);
  24. @EXPORT_OK = qw($IDOBJECT);
  25.  
  26. my %TYPE = ('r' => 'real', 'a' => 'alias', 'S' => 'subst');
  27. my %RTYPE = ('real' => 'Sr', 'alias' => 'Sa', 'subst' => 'SS',
  28.          'useralias' => 'Ua');
  29.  
  30. $Purge = 0;
  31. undef $IDOBJECT;
  32.  
  33. sub emes {
  34.     my $o = shift;
  35.     my $pkg = $o->{pkg} || $DEFAULT_PACKAGE || 'Unknown';
  36.     
  37.     printw("Id: $pkg: ", @_);
  38. }
  39.  
  40. sub emesd {
  41.     my $o = shift;
  42.     my $pkg = $o->{pkg} || $DEFAULT_PACKAGE || 'Unknown';
  43.     
  44.     printd("Id: $pkg: ", @_);
  45. }
  46.  
  47. my $Obj;
  48.  
  49. sub sorter {
  50.     my $a1 = $Obj->{2}->[$a];
  51.     $a1 =~ s/^(..)(.*)/$1/;
  52.     my $a2 = $2;
  53.     my $a3 = $Obj->{3}->[$a];
  54.   
  55.     my $b1 = $Obj->{2}->[$b];
  56.     $b1 =~ s/^(..)(.*)/$1/;
  57.     my $b2 = $2;
  58.     my $b3 = $Obj->{3}->[$b];
  59.  
  60.     ($b1 ne $a1) && return ($b1 cmp $a1);
  61.     ($b3 != $a3) && return ($b3 <=> $a3);
  62.  
  63.     return -1 if ($a2);
  64.     return 1 if ($b2);
  65.     
  66.     return 0;
  67. }
  68.  
  69. sub check_if_installed {
  70.     my $obj = shift;
  71.     my $id = shift;
  72.     my $font = shift;
  73.     my @ret = ();
  74.  
  75.     if ($id ne '.' && $font ne '.') {
  76.     if (exists($obj->{hash01}->{$id.' '.$font})) {
  77.         my $i = $obj->{hash01}->{$id.' '.$font};
  78.         return ($obj->{2}->[$i] =~ /I$/);
  79.     } else {
  80.         return 0;
  81.     }
  82. #    return $obj->grep('installed', f0 => $id, f1 => $font);
  83.     } elsif ($id ne '.' && $font eq '.') {
  84. #    return $obj->grep('installed', f0 => $id);
  85.     return exists($obj->{hash0_installed}->{$id});
  86.     } elsif ($id eq '.' && $font ne '.') {
  87.     return $obj->grep('installed', f1 => $font);
  88.     }
  89.  
  90.     return @ret;
  91. }
  92.  
  93. sub get_top_prior {
  94.     my $obj = shift;
  95.     my $id = shift;
  96.     my @index;
  97.     my %exclude = ();
  98.     my $i;
  99.     my $j;
  100.     my @list;
  101.  
  102.     # Check marked fonts providing the id first.
  103.     @index = $obj->grep('mark', f0 => $id);
  104.     @index = sort (@index);
  105.  
  106.     foreach $i (@index) {
  107.     # If a certain font is marked as 'install'...
  108.     if ($obj->{2}->[$i] eq 'Mu') {
  109.         # Check if the font is actually registered,
  110. #        @list = $obj->grep('font', f1 => $obj->{1}->[$i],
  111. #                   f0 => $obj->{0}->[$i]);
  112. #        if (@list) {
  113. #        $j = $list[0];
  114.         if (exists($obj->{hash01}->{$obj->{0}->[$i].' '.$obj->{1}->[$i]})){
  115.         # In case the font is registered:
  116.         $j = $obj->{hash01}->{$obj->{0}->[$i].' '.$obj->{1}->[$i]};
  117.  
  118.         if ($obj->{5}->[$j] ne '.' || $obj->{6}->[$j] ne '.') {
  119.             # If the font depends on another font, and that font
  120.             # is not actually installed, ignore the 'install' flag.
  121.             next unless (check_if_installed($obj, $obj->{5}->[$j],
  122.                             $obj->{6}->[$j]));
  123.         }
  124.         
  125.         return $j;
  126.         }
  127.     } elsif ($obj->{2}->[$i] eq 'Mx' or $obj->{2}->[$i] eq 'MX') {
  128.         # If a certain font is marked as 'exclude'...
  129.         $exclude{$obj->{1}->[$i]} = 1;
  130.     }
  131.     }
  132.  
  133.     # Check all fonts providing the id.
  134.     @index = $obj->grep('font', f0 => $id);
  135.     $Obj = $obj;
  136.     @index = sort sorter (@index);
  137.  
  138.     foreach $i (@index) {
  139.     next if (exists($exclude{$obj->{1}->[$i]}));
  140.     next if (exists($obj->{unregistering}->{$i}));
  141.  
  142.     my $did = $obj->{5}->[$i];
  143.     my $dfont = $obj->{6}->[$i];
  144.  
  145.     if ($did ne '.' || $dfont ne '.') {
  146.         # If the font depends on another font, and that font is not
  147.         # actually installed, ignore it.
  148.         next unless (check_if_installed($obj, $did, $dfont));
  149.     }
  150.  
  151.     return $i;
  152.     }
  153.  
  154.     return -1;
  155. }
  156.  
  157. sub call_do_remove {
  158.     my $obj = shift;
  159.     my $i = shift;
  160.  
  161.     my $id = $obj->{0}->[$i];
  162.     
  163.     $obj->{2}->[$i] =~ /^.(.)I$/;
  164.     my $typestr = $TYPE{$1};
  165.  
  166.     my $depid = ($obj->{5}->[$i] eq '.') ? '' : $obj->{5}->[$i];
  167.     my $depfont = ($obj->{6}->[$i] eq '.') ? '' : $obj->{6}->[$i];
  168.  
  169.     my @hints = defoma_id_get_hints($obj, $i);
  170.  
  171.     $IDOBJECT = $obj;
  172.     
  173.     &Debian::Defoma::Configure::call_1(0, $obj->{pkg},
  174.                        "do-remove-$typestr", $obj->{4}->[$i],
  175.                        $obj->{1}->[$i], $id, $depfont, $depid,
  176.                        @hints) if ($obj->{callback});
  177.  
  178.     $obj->uninstall($i);
  179.  
  180.     do_update_depend(0, $obj, $id, $obj->{1}->[$i]);
  181. }
  182.  
  183. sub call_do_install {
  184.     my $obj = shift;
  185.     my $i = shift;
  186.  
  187.     my $id = $obj->{0}->[$i];
  188.  
  189.     $obj->{2}->[$i] =~ /^.(.)$/;
  190.     my $typestr = $TYPE{$1};
  191.     
  192.     my $depid = ($obj->{5}->[$i] eq '.') ? '' : $obj->{5}->[$i];
  193.     my $depfont = ($obj->{6}->[$i] eq '.') ? '' : $obj->{6}->[$i];
  194.  
  195.     my @hints = defoma_id_get_hints($obj, $i);
  196.  
  197.     my $font = $obj->{1}->[$i];
  198.     my $ctg = $obj->{4}->[$i];
  199.  
  200.     $obj->install($i);
  201.  
  202.     $IDOBJECT = $obj;
  203.     
  204.     my $ret = 0;
  205.     $ret = &Debian::Defoma::Configure::call_1(0, $obj->{pkg},
  206.                           "do-install-$typestr", $ctg,
  207.                           $font, $id, $depfont, $depid,
  208.                           @hints) if ($obj->{callback});
  209.     
  210.     if ($ret) {
  211.     $obj->uninstall($i);
  212.     
  213.     do_set($obj, $id, $font, 'error');
  214.     
  215.     my $text = <<EOF
  216. Following package\'s configuration script returned error($ret) during doing do-install-$typestr.
  217.   Package\: $obj->{pkg}
  218.   Category\: $ctg
  219.   Installing Font\: $font
  220.   Installing ID\: $id
  221. Defoma has set this font as \'exclude\' to keep it from being installed.
  222. You can still have it installed by unsetting the \'exclude\' mark after the cause of the error gets removed.
  223. EOF
  224.     ;
  225.     printw($text) if ($ret == 1);
  226.  
  227.     do_update($obj, $id);
  228.     } else {
  229.     do_update_depend(1, $obj, $id, $font);
  230.     }
  231. }
  232.     
  233. sub do_update {
  234.     my $obj = shift;
  235.     my $id = shift;
  236.     my $i1 = -1;
  237.     my $i2 = -1;
  238.     my $font1 = '';
  239.     my $font2 = '';
  240.     my @list;
  241.  
  242. #    @list = $obj->grep('installed', f0 => $id);
  243. #    if (@list > 0) {
  244. #    $i1 = $list[0];
  245.     
  246.     if (exists($obj->{hash0_installed}->{$id})) {
  247.     $i1 = $obj->{hash0_installed}->{$id};
  248.     
  249.     $font1 = $obj->{1}->[$i1];
  250.     }
  251.  
  252.     $i2 = get_top_prior($obj, $id);
  253.     if ($i2 >= 0) {
  254.     $font2 = $obj->{1}->[$i2];
  255.     }
  256.  
  257.     return if ($font1 eq $font2);
  258.  
  259.     if ($i1 >= 0) {
  260.     call_do_remove($obj, $i1);
  261.     }
  262.  
  263.     return if ($obj->{delay});
  264.  
  265.     if ($i2 >= 0) {
  266.     call_do_install($obj, $i2);
  267.     }
  268. }
  269.  
  270. sub do_update_depend {
  271.     my $com = shift;
  272.     my $obj = shift;
  273.     my $id = shift;
  274.     my $font = shift;
  275.  
  276.     my @l;
  277.     my %list;
  278.     
  279.     if (exists($obj->{hash5}->{$id})) {
  280.     @l = keys(%{$obj->{hash5}->{$id}});
  281.     grep($list{$_} = undef, @l);
  282.     }
  283.     if (exists($obj->{hash6}->{$font})) {
  284.     @l = keys(%{$obj->{hash6}->{$font}});
  285.     grep($list{$_} = undef, @l);
  286.     }
  287.  
  288.     foreach my $i (keys(%list)) {
  289.     next if ($obj->{5}->[$i] ne '.' && $obj->{5}->[$i] ne $id);
  290.     next if ($obj->{6}->[$i] ne '.' && $obj->{6}->[$i] ne $font);
  291.     next if ($com == 0 && $obj->{2}->[$i] !~ /I$/);
  292.     next if ($com == 1 && $obj->{2}->[$i] =~ /I$/);
  293.  
  294.     do_update($obj, $obj->{0}->[$i]);
  295.     }
  296. }
  297.  
  298. sub do_unset {
  299.     my $obj = shift;
  300.     my $id = shift;
  301.     my $font = shift;
  302.  
  303. #    my @list = $obj->grep('mark', f0 => $id, f1 => $font, r2 => '^M[ux]');
  304. #    if (@list > 0) {
  305. #    $obj->delete(@list);
  306.     if (exists($obj->{hash01_mark}->{$id.' '.$font})) {
  307.     $obj->delete($obj->{hash01_mark}->{$id.' '.$font});
  308.     }
  309. }
  310.  
  311. sub do_set {
  312.     my $obj = shift;
  313.     my $id = shift;
  314.     my $font = shift;
  315.     my $type = shift;
  316.     my $typestr;
  317.  
  318.     if ($type eq 'install') {
  319.     $typestr = 'Mu';
  320.     } elsif ($type eq 'exclude') {
  321.     $typestr = 'MX';
  322.     } elsif ($type eq 'error') {
  323.     $typestr = 'Mx';
  324.     }
  325.     
  326.     if ($type eq 'install') {
  327.     my @list = $obj->grep('mark', f0 => $id, f2 => 'Mu');
  328.     if (@list > 0) {
  329.         $obj->delete($list[0]);
  330.     }
  331.     }
  332.  
  333.     if (exists($obj->{hash01_mark}->{$id . ' '. $font})) {
  334.     $obj->delete($obj->{hash01_mark}->{$id . ' '. $font});
  335.     }
  336.  
  337.     return $obj->add($id, $font, $typestr, '-', '-', '-', '-', '-');
  338. }
  339.  
  340. sub defoma_id_open_cache {
  341.     my $suffix = (@_ > 0) ? shift(@_) : '';
  342.     my $pkg = (@_ > 0) ? shift(@_) : $DEFAULT_PACKAGE;
  343.     my $o;
  344.  
  345.     $suffix =~ s/[^a-zA-Z0-9_-]/_/g;
  346.  
  347.     $o = get_id_object($pkg, $suffix);
  348.     return $o if ($o);
  349.  
  350.     my $file = ROOTDIR . '/' . $pkg . '.d/id-cache';
  351.     $file .= '.' . $suffix if ($suffix);
  352.  
  353.     $o = new Debian::Defoma::IdCache($file, $pkg, $suffix);
  354.     $o->read();
  355.  
  356.     register_id_object($o, $pkg, $suffix);
  357.  
  358.     return $o;
  359. }
  360.  
  361. sub defoma_id_close_cache {
  362.     my $o = shift;
  363.     if ($o) {
  364.     $o->write();
  365.     }
  366. }
  367.  
  368. sub defoma_id_register {
  369.     my $obj = shift;
  370.     my %args = @_;
  371.  
  372.     unless (exists($args{type}) && exists($args{font}) && exists($args{id}) &&
  373.         exists($args{priority})) {
  374.     emes($obj, "register: Required argument is missing.");
  375.     return -1;
  376.     }
  377.  
  378.     my $comtype = $args{type};
  379.     my $font = $args{font};
  380.     my $id = $args{id};
  381.     my $priority = $args{priority};
  382.  
  383.     if ($comtype !~ /^(real|alias|useralias|subst)$/) {
  384.     emes($obj, "Unknown type '$comtype'.");
  385.     return -1;
  386.     }
  387.     
  388.     my $type = $RTYPE{$comtype};
  389.  
  390.     arg_check($id, $font, $priority) || return -1;
  391.  
  392.     return -1 if ($priority =~ /[^0-9]/);
  393.     $priority = 999 if ($priority >= 1000);
  394.     $priority = 0 if ($priority < 0);
  395.  
  396.     my $category = $DEFAULT_CATEGORY;
  397.     my $depfont = '.';
  398.     my $depid = '.';
  399.     my $hints = '';
  400.     my $i;
  401.     my $dependflag = 0;
  402.     my @l;
  403.  
  404.     $category = $args{category} if (exists($args{category}));
  405.  
  406.     if (exists($args{depend})) {
  407.     @l = split(/ /, $args{depend});
  408.     if (@l == 2) {
  409.         $depfont = $l[0];
  410.         $depid = $l[1];
  411.     }
  412.     }
  413.  
  414.     if (exists($args{origin})) {
  415.     $depfont = $font;
  416.     $depid = $args{origin};
  417.     }
  418.  
  419.     if (exists($args{hints})) {
  420.     if ($type eq 'Sr') {
  421.         $hints = $args{hints};
  422.     } else {
  423.         emesd($obj, "register: Only type => 'real' accepts 'hints'.");
  424.     }
  425.     }
  426.  
  427.     if ($type ne 'Sr' && ($depid eq '.' || $depfont eq '.')) {
  428.     emes($obj, "'$comtype' requires 'origin' be specified.");
  429.     return -1;
  430.     }
  431.  
  432. #    if ($obj->grep('font', f0 => $id, f1 => $font)) {
  433.     if (exists($obj->{hash01}->{$id.' '.$font})) {
  434.     emesd($obj, "$id: already registered by $font.");
  435.     return -1;
  436.     }
  437.  
  438.     $obj->add($id, $font, $type, $priority, $category, $depid, $depfont,
  439.           $hints);
  440.  
  441.     do_update($obj, $id);
  442.  
  443.     return 0;
  444. }
  445.  
  446. sub defoma_id_unregister {
  447.     my $obj = shift;
  448.     my %args = @_;
  449.  
  450.     unless (exists($args{type}) && exists($args{font})) {
  451.     emes($obj, "register: Required argument is missing.");
  452.     return -1;
  453.     }
  454.  
  455.     my $comtype = $args{type};
  456.     my $font = $args{font};
  457.     my $id = (exists($args{id})) ? $args{id} : '';
  458.  
  459.     if ($comtype !~ /^(real|alias|subst)$/) {
  460.     emes($obj, "Unknown type '$comtype'.");
  461.     return -1;
  462.     }
  463.  
  464.     my @index;
  465.     my ($i, $m);
  466.  
  467.     my $j = -1;
  468.     if ($id eq '') {
  469.     @index = $obj->grep($comtype, f1 => $font);
  470.     } else {
  471. #    @index = $obj->grep($comtype, f0 => $id, f1 => $font);
  472.     if (exists($obj->{hash01}->{$id.' '.$font})) {
  473.         $j = $obj->{hash01}->{$id.' '.$font};
  474.         $index[0] = $j if ($obj->{2}->[$j] =~ /^$RTYPE{$comtype}/);
  475.     }
  476.     }
  477.  
  478.     return -1 unless(@index);
  479.  
  480.     foreach $i (@index) {
  481.     next if ($obj->{2}->[$i] =~ /^Ua/ && $Purge == 0);
  482.     $id = $obj->{0}->[$i];
  483.  
  484.     $obj->{unregistering}->{$i} = '';
  485.  
  486.  
  487.     do_update($obj, $id);
  488.  
  489. #    do_unset($obj, $id, $font) if ($Purge);
  490.  
  491.     $obj->delete($i);
  492.     delete($obj->{unregistering}->{$i});
  493.  
  494.     if (exists($obj->{hash01_mark}->{$id.' '.$font})) {
  495.         $j = $obj->{hash01_mark}->{$id.' '.$font};
  496.         $obj->delete($j) if ($obj->{2}->[$j] eq 'Mx' || $Purge);
  497.     }
  498.  
  499. #    my @l = $obj->grep('mark', f0 => $id, f1 => $font);
  500. #    if (@l) {
  501. #        $obj->delete(@l);
  502. #    }
  503.     }
  504. }
  505.  
  506. sub sort_result {
  507.     $Obj = shift;
  508.     my $sorttype = shift;
  509.     my $sortkey = shift;
  510.     
  511.     if ($sorttype eq 'p') {
  512.     return sort sorter (@_);
  513.     } elsif ($sorttype eq 'n') {
  514.     return sort { $Obj->{$sortkey}->[$a] <=> $Obj->{$sortkey}->[$b] } (@_);
  515.     } elsif ($sorttype eq 'a') {
  516.     return sort { $Obj->{$sortkey}->[$a] cmp $Obj->{$sortkey}->[$b] } (@_);
  517.     }
  518. }
  519.  
  520. my %Conv = ( id => 'f0', font => 'f1', type => 'f2', priority => 'f3',
  521.          category => 'f4', depid => 'f5', depfont => 'f6', hints => 'f7');
  522.  
  523. sub convert_grep_argument {
  524.     my @ret = ();
  525.     
  526.     while (@_ > 0) {
  527.     my $key = shift;
  528.     my $value = shift;
  529.  
  530.     if (exists($Conv{$key})) {
  531.         push(@ret, $Conv{$key}, $value);
  532.     } else {
  533.         push(@ret, $key, $value);
  534.     }
  535.     }
  536.  
  537.     return @ret;
  538. }
  539.  
  540. sub defoma_id_grep_cache {
  541.     my $o = shift;
  542.     my $t = shift;
  543.     my %args = convert_grep_argument(@_);
  544.     my @ret = ();
  545.     my $sorttype = '';
  546.     my $sortkey;
  547.  
  548.     if (exists($args{sortkey})) {
  549.     $sortkey = $args{sortkey};
  550.     if (exists($Conv{$sortkey})) {
  551.         $Conv{$sortkey} =~ /^(.)(.)/;
  552.         $sortkey = $2;
  553.     } else {
  554.         undef $sortkey;
  555.     }
  556.     delete $args{sortkey};
  557.     }
  558.  
  559.     if (exists($args{sorttype})) {
  560.     $sorttype = $args{sorttype};
  561.     undef $sorttype if ($sorttype !~ /^[nap]$/);
  562.     undef $sorttype if ($sorttype =~ /^[na]$/ && ! defined($sortkey));
  563.     delete $args{sorttype};
  564.     }
  565.     
  566.     if (exists($args{f0}) && exists($args{f1})) {
  567.     if ($t eq 'mark') {
  568.         if (exists($o->{hash01_mark}->{$args{f0}.' '.$args{f1}})) {
  569.         push(@ret, $o->{hash01_mark}->{$args{f0}.' '.$args{f1}});
  570.         }
  571.     } else {
  572.         if (exists($o->{hash01}->{$args{f0}.' '.$args{f1}})) {
  573.         push(@ret, $o->{hash01}->{$args{f0}.' '.$args{f1}});
  574.         }
  575.     }
  576.     @ret = sort_result($o, $sorttype, $sortkey, @ret) if ($sorttype);
  577.     return @ret;
  578.     }
  579.  
  580.     if (exists($args{f0}) && $t eq 'installed') {
  581.     if (exists($o->{hash0_installed}->{$args{f0}})) {
  582.         push(@ret, $o->{hash0_installed}->{$args{f0}});
  583.     }
  584.     @ret = sort_result($o, $sorttype, $sortkey, @ret) if ($sorttype);
  585.     return @ret;
  586.     }
  587.  
  588.     @ret = $o->grep($t, %args);
  589.     @ret = sort_result($o, $sorttype, $sortkey, @ret) if ($sorttype);
  590.     return @ret;
  591. }
  592.  
  593. sub defoma_id_get_font {
  594.     return defoma_id_grep_cache(@_);
  595. }
  596.  
  597. sub defoma_id_update {
  598.     my $o = shift;
  599.     my $id = shift;
  600.  
  601.     do_update($o, $id);
  602. }
  603.  
  604. sub defoma_id_get_hints {
  605.     my $obj = shift;
  606.     my $i = shift;
  607.  
  608.     my $type = $obj->{2}->[$i];
  609.     my $id;
  610.     my $font;
  611.     my $h;
  612.  
  613.     if ($type =~ /^Sr/) {
  614.     return split(' ', $obj->{7}->[$i]);
  615.     } else {
  616.     $id = $obj->{5}->[$i];
  617.     $font = $obj->{6}->[$i];
  618.     
  619.     if (exists($obj->{hash01}->{$id.' '.$font})) {
  620.         my $j = $obj->{hash01}->{$id.' '.$font};
  621.         return split (' ', $obj->{7}->[$j]);
  622.     } else {
  623.         return undef;
  624.     }
  625.     }
  626.     
  627. #    my @list = $obj->grep('real', f0 => $id, f1 => $font);
  628. #    if (@list > 0) {
  629. #    return $obj->{7}->[$list[0]];
  630. #    } else {
  631. #    return '';
  632. #    }
  633. }
  634.  
  635. sub defoma_id_set {
  636.     my $obj = shift;
  637.     my $id = shift;
  638.     my $font = shift;
  639.     my $mark = shift;
  640.  
  641.     do_set($obj, $id, $font, $mark);
  642.     do_update($obj, $id);
  643. }
  644.  
  645. sub defoma_id_unset {
  646.     my $obj = shift;
  647.     my $id = shift;
  648.     my $font = shift;
  649.  
  650.     do_unset($obj, $id, $font);
  651.     do_update($obj, $id);
  652. }
  653.  
  654.  
  655.     
  656.  
  657. 1;
  658.  
  659.