home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / Debian / Defoma / IdCache.pm < prev    next >
Encoding:
Perl POD Document  |  2006-06-17  |  7.5 KB  |  394 lines
  1. package Debian::Defoma::IdCache;
  2. use strict;
  3. use POSIX;
  4. use FileHandle;
  5.  
  6. my %TYPE = ( 'Sr' => 'real', 'SrI' => 'real',
  7.          'Sa' => 'alias', 'SaI' => 'alias',
  8.          'Ua' => 'alias', 'UaI' => 'alias',
  9.          'SS' => 'subst', 'SSI' => 'subst',
  10.          'Mu' => 'mark', 'Mx' => 'mark', 'MX' => 'mark' );
  11.  
  12. sub new {
  13.     my $class = shift;
  14.  
  15.     my $o = {
  16.     0 => [],
  17.     1 => [],
  18.     2 => [],
  19.     3 => [],
  20.     4 => [],
  21.     5 => [],
  22.     6 => [],
  23.     7 => [],
  24.     real => {},
  25.     alias => {},
  26.     mark => {},
  27.     subst => {},
  28.     installed => {},
  29.     deleted => [],
  30.     g0 => {},
  31.     g1 => {},
  32.     hash01 => {},
  33.     hash01_mark => {},
  34.     hash0_installed => {},
  35.     hash5 => {},
  36.     hash6 => {},
  37.     file => shift,
  38.     cnt => 0,
  39.     pkg => shift,
  40.     suffix => shift,
  41.     unregistering => {},
  42.     delay => 0,
  43.     callback => 1
  44.     };
  45.  
  46.     $o->{e_id} = $o->{0};
  47.     $o->{e_font} = $o->{1};
  48.     $o->{e_type} = $o->{2};
  49.     $o->{e_priority} = $o->{3};
  50.     $o->{e_category} = $o->{4};
  51.     $o->{e_depid} = $o->{5};
  52.     $o->{e_depfont} = $o->{6};
  53.     $o->{e_hints} = $o->{7};
  54.  
  55.     $o->{g0}->{real} = {};
  56.     $o->{g0}->{alias} = {};
  57.     $o->{g0}->{subst} = {};
  58.     $o->{g0}->{mark} = {};
  59.  
  60.     $o->{g1}->{real} = {};
  61.     $o->{g1}->{alias} = {};
  62.     $o->{g1}->{subst} = {};
  63.     $o->{g1}->{mark} = {};
  64.     $o->{g1}->{installed} = {};
  65.  
  66.     bless $o;
  67.     return $o;
  68. }
  69.  
  70. sub hash_add_install {
  71.     my ($o, $i, $k0, $k1) = @_;
  72.  
  73.     $o->{installed}->{$i} = undef;
  74.     $o->{hash0_installed}->{$k0} = $i;
  75.  
  76.     unless (exists($o->{g1}->{installed}->{$k1})) {
  77.     $o->{g1}->{installed}->{$k1} = {};
  78.     }
  79.     $o->{g1}->{installed}->{$k1}->{$i} = undef;
  80. }
  81.  
  82. sub hash_add {
  83.     my ($o, $i, $k0, $k1, $k2, $k5, $k6) = @_;
  84.  
  85.     my $type = $TYPE{$k2};
  86.  
  87.     unless (exists($o->{g0}->{real}->{$k0})) {
  88.     $o->{g0}->{real}->{$k0} = {};
  89.     $o->{g0}->{alias}->{$k0} = {};
  90.     $o->{g0}->{subst}->{$k0} = {};
  91.     $o->{g0}->{mark}->{$k0} = {};
  92.     }
  93.     unless (exists($o->{g1}->{real}->{$k1})) {
  94.     $o->{g1}->{real}->{$k1} = {};
  95.     $o->{g1}->{alias}->{$k1} = {};
  96.     $o->{g1}->{subst}->{$k1} = {};
  97.     $o->{g1}->{mark}->{$k1} = {};
  98.     }
  99.     unless ($k5 eq '.') {
  100.     unless (exists($o->{hash5}->{$k5})) {
  101.         $o->{hash5}->{$k5} = {};
  102.     }
  103.     $o->{hash5}->{$k5}->{$i} = undef;
  104.     }
  105.     unless ($k6 eq '.') {
  106.     unless (exists($o->{hash6}->{$k6})) {
  107.         $o->{hash6}->{$k6} = {};
  108.     }
  109.     $o->{hash6}->{$k6}->{$i} = undef;
  110.     }
  111.     
  112.     $o->{g0}->{$type}->{$k0}->{$i} = undef;
  113.     $o->{g1}->{$type}->{$k1}->{$i} = undef;
  114.     
  115.     if ($k2 =~ /..I$/) {
  116.     $o->hash_add_install($i, $k0, $k1, $k2);
  117.     }
  118.         
  119.     if ($type ne 'mark') {
  120.     $o->{$type}->{$i} = undef;
  121.     
  122.     $o->{hash01}->{$k0.' '.$k1} = $i;
  123.     } else {
  124.     $o->{mark}->{$i} = undef;
  125.     
  126.     $o->{hash01_mark}->{$k0.' '.$k1} = $i;
  127.     }
  128. }
  129.  
  130. sub hash_remove_install {
  131.     my ($o, $i, $k0, $k1) = @_;
  132.  
  133.     delete($o->{installed}->{$i});
  134.     delete($o->{hash0_installed}->{$k0});
  135.  
  136.     delete($o->{g1}->{installed}->{$k1}->{$i});
  137. }
  138.  
  139. sub hash_remove {
  140.     my ($o, $i) = @_;
  141.     my $k0 = $o->{0}->[$i];
  142.     my $k1 = $o->{1}->[$i];
  143.     my $k2 = $o->{2}->[$i];
  144.     my $k5 = $o->{5}->[$i];
  145.     my $k6 = $o->{6}->[$i];
  146.  
  147.     my $type = $TYPE{$k2};
  148.  
  149.     delete($o->{g0}->{$type}->{$k0}->{$i});
  150.     delete($o->{g1}->{$type}->{$k1}->{$i});
  151.     delete($o->{hash5}->{$k5}->{$i}) unless ($k5 eq '.');
  152.     delete($o->{hash6}->{$k6}->{$i}) unless ($k6 eq '.');
  153.     
  154.     if ($k2 =~ /..I$/) {
  155.     $o->hash_remove_install($i, $k0, $k1);
  156.     }
  157.         
  158.     if ($type ne 'mark') {
  159.     delete($o->{$type}->{$i});
  160.     delete($o->{hash01}->{$k0.' '.$k1});
  161.     } else {
  162.     delete($o->{mark}->{$i});
  163.     delete($o->{hash01_mark}->{$k0.' '.$k1});
  164.     }
  165. }
  166.  
  167. sub read {
  168.     my $o = shift;
  169.  
  170.     my $file = $o->{file};
  171.     my $i = 0;
  172.     my $j;
  173.     my $type;
  174.  
  175.     my $fh = new FileHandle($o->{file}, "r");
  176.     if (defined($fh)) {
  177.     while(<$fh>) {
  178.         chomp($_);
  179.         my @list = split(' ', $_);
  180.         my ($k0, $k1, $k2, $k5, $k6);
  181.  
  182.         # code to keep backword compatibility.
  183.         if ($list[2] eq 'Ir' || $list[2] eq 'Ia' || $list[2] eq 'IS') {
  184.         if (exists($o->{hash01}->{$list[0].' '.$list[1]})) {
  185.             $j = $o->{hash01}->{$list[0].' '.$list[1]};
  186.  
  187.             $o->{2}->[$j] .= 'I';
  188.  
  189.             $o->hash_add_install($j, $list[0], $list[1]);
  190.         }
  191.  
  192.         next;
  193.         }
  194.  
  195.         # fallback for the code above.
  196.         if ($list[2] =~ /^M.I$/) {
  197.         next;
  198.         }
  199.  
  200.         # fallback for broken id-cache.
  201.         next if (@list < 7);
  202.         
  203.         $o->{0}->[$i] = $k0 = shift(@list);
  204.         $o->{1}->[$i] = $k1 = shift(@list);
  205.         $o->{2}->[$i] = $k2 = shift(@list);
  206.         $o->{3}->[$i] = shift(@list);
  207.         $o->{4}->[$i] = shift(@list);
  208.         $o->{5}->[$i] = $k5 = shift(@list);
  209.         $o->{6}->[$i] = $k6 = shift(@list);
  210.         $o->{7}->[$i] = (@list > 0) ? join(' ', @list) : '';
  211.  
  212.         $o->hash_add($i, $k0, $k1, $k2, $k5, $k6);
  213.  
  214.         $i++;
  215.     }
  216.     $fh->close();
  217.     }
  218.     $o->{cnt} = $i;
  219.  
  220.     return 0;
  221. }
  222.  
  223. sub write {
  224.     my $o = shift;
  225.  
  226.     my $file = $o->{file};
  227.     my $max = $o->{cnt};
  228.     my ($i, $j);
  229.  
  230.     my $fh = new FileHandle($o->{file}, "w");
  231.     if (defined($fh)) {
  232.     for ($i = 0; $i < $max; $i++) {
  233.         $j = $o->{0}->[$i];
  234.         if ($j ne '') {
  235.         $fh->print($j, ' ', $o->{1}->[$i], ' ', $o->{2}->[$i], ' ',
  236.                $o->{3}->[$i], ' ', $o->{4}->[$i], ' ',
  237.                $o->{5}->[$i], ' ', $o->{6}->[$i], ' ',
  238.                $o->{7}->[$i], "\n");
  239.         }
  240.     }
  241.     $fh->close();
  242.     }
  243.     unlink($file) unless(-s $file);
  244.  
  245.     return 0;
  246. }
  247.  
  248. sub grep {
  249.     my $o = shift;
  250.     my $t = shift;
  251.     my %op = @_;
  252.     my @pat = ();
  253.     my @idx = ();
  254.     my ($i, $j, $k, $ii, $max, $or, $match, $pmax);
  255.     my @nul = ();
  256.     my @lines = ();
  257.     my @ret = ();
  258.     my $gflag = 0;
  259.  
  260.     $or = 0;
  261.     $pmax = 0;
  262.     foreach $i (keys(%op)) {
  263.     if ($i eq 'or') {
  264.         $or = 1;
  265.     } elsif ($i =~ /(.)(.)/) {
  266.         $ii = $2;
  267.         $ii += 8 if ($1 eq 'r');
  268.         $j = $op{$i};
  269.  
  270.         if ($ii <= 1) {
  271.         my $gn = 'g'.$ii;
  272.         $gflag = 1;
  273.         
  274.         if ($t eq 'font') {
  275.             if (exists($o->{$gn}->{real}->{$j})) {
  276.  
  277.             @lines = (keys(%{$o->{$gn}->{real}->{$j}}),
  278.                   keys(%{$o->{$gn}->{alias}->{$j}}),
  279.                   keys(%{$o->{$gn}->{subst}->{$j}}));
  280.             } else {
  281.             return @nul;
  282.             }
  283.         } else {
  284.             if (exists($o->{$gn}->{$t}->{$j})) {
  285.             @lines = keys(%{$o->{$gn}->{$t}->{$j}});
  286.             } else {
  287.             return @nul;
  288.             }
  289.         }
  290.         } else {
  291.         $idx[$pmax] = $ii;
  292.         $pat[$pmax] = $j;
  293.         
  294.         $pmax++;
  295.         }
  296.     }
  297.     }
  298.  
  299.     if ($gflag == 0) {
  300.     if ($t eq 'font') {
  301.         @lines = (keys(%{$o->{real}}), keys(%{$o->{alias}}),
  302.               keys(%{$o->{subst}}));
  303.     } else {
  304.         @lines = keys(%{$o->{$t}});
  305.     }
  306.     }
  307.  
  308.     if ($pmax == 0) {
  309.     return @lines;
  310.     }
  311.     
  312.     foreach $i (@lines) {
  313.     next unless ($o->{0}->[$i]);
  314.     
  315.     $match = 1;
  316.     for ($j = 0; $j < $pmax; $j++) {
  317.         $match = 0;
  318.         $ii = $idx[$j];
  319.         if ($ii >= 8) {
  320.         $ii -= 8;
  321.         $match = 1 if ($o->{$ii}->[$i] =~ /$pat[$j]/);
  322.         } else {
  323.         $match = 1 if ($o->{$ii}->[$i] eq $pat[$j]);
  324.         }
  325.         
  326.         if ($or) {
  327.         last if ($match);
  328.         } else {
  329.         last if ($match == 0);
  330.         }
  331.     }
  332.     
  333.     push(@ret, $i) if ($match);
  334.     }
  335.     
  336.     return @ret;
  337. }
  338.  
  339. sub add {
  340.     my $o = shift;
  341.     my $j = 0;
  342.     my $i;
  343.  
  344.     if (@{$o->{deleted}} > 0) {
  345.     $i = pop(@{$o->{deleted}});
  346.     } else {
  347.     $i = $o->{cnt};
  348.     $o->{cnt}++;
  349.     }
  350.  
  351.     $o->hash_add($i, $_[0], $_[1], $_[2], $_[5], $_[6]);
  352.     
  353.     my $font = shift;
  354.     for ($j = 1; $j < 8; $j++) {
  355.     $o->{$j}->[$i] = shift;
  356.     }
  357.     $o->{0}->[$i] = $font;
  358.  
  359.     return $i;
  360. }
  361.  
  362. sub delete {
  363.     my $o = shift;
  364.  
  365.     foreach my $i (@_) {
  366.     $o->hash_remove($i);
  367.     
  368.     $o->{0}->[$i] = '';
  369.     push(@{$o->{deleted}}, $i);
  370.     }
  371.  
  372.     return 0;
  373. }
  374.  
  375. sub install {
  376.     my $o = shift;
  377.     my $i = shift;
  378.  
  379.     $o->{2}->[$i] .= 'I';
  380.  
  381.     $o->hash_add_install($i, $o->{0}->[$i], $o->{1}->[$i]);
  382. }
  383.  
  384. sub uninstall {
  385.     my $o = shift;
  386.     my $i = shift;
  387.  
  388.     $o->{2}->[$i] =~ s/I$//;
  389.  
  390.     $o->hash_remove_install($i, $o->{0}->[$i], $o->{1}->[$i]);
  391. }
  392.  
  393. 1;
  394.