home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl5 / Debian / Defoma / Common.pm next >
Encoding:
Perl POD Document  |  2006-06-17  |  26.0 KB  |  1,337 lines
  1. package Debian::Defoma::Common;
  2.  
  3. use strict;
  4. use POSIX;
  5. use Exporter;
  6. use FileHandle;
  7.  
  8. use vars qw(@EXPORT @EXPORT_OK @ISA $ROOTDIR $DEFOMA_TEST_DIR
  9.         $DEFAULT_PACKAGE $DEFAULT_CATEGORY);
  10.  
  11. my ($Scriptdir, $Substruledir, $Homedir, $Lockfile, $Quiet, $Error, $Verbose,
  12.     $Debug, $Userspace, @Scriptdirs, $Locale, $Login);
  13. my ($Defoma_Test_Dir, $Rootdir);
  14. my $Version = "0.10.0";
  15. my @Args;
  16. my @Options;
  17.  
  18. BEGIN {
  19.     @ISA = qw(Exporter);
  20.     @EXPORT = qw(&printm &printw &printe &printv &printd &add_hash_list
  21.          &parse_hints_start
  22.          &parse_hints_cut &parse_hints_cut_except &parse_hints_build
  23.          &parse_hints_subhints &parse_hints_subhints_inherit
  24.          &get_xencoding &get_charset
  25.          &weight_a2i &weight_ascii2integer
  26.          &get_xlfd_of_font
  27.          &app_readfile &app_writefile &app_symlink &app_unlink
  28.          $DEFOMA_TEST_DIR $ROOTDIR
  29.          &DEFOMA_TEST_DIR &ROOTDIR &USERSPACE &HOMEDIR &LOCALE
  30.          &SCRIPTDIR &SUBSTRULEDIR &LOCKFILE &ERROR 
  31.          &SCRIPTDIRS &VERSION &ARGS &USERLOGIN &OPTIONS
  32.          );
  33.     @EXPORT_OK = qw(&mylock ®ister_id_object ®ister_subst_object
  34.             &get_id_object &get_subst_object &get_system_categories
  35.             &get_files &diff_files &arg_check &arg_check_category
  36.             &readfile &writefile
  37.             $DEFAULT_PACKAGE $DEFAULT_CATEGORY
  38.             );
  39.  
  40.     $Quiet = 0;
  41.     $Error = 0;
  42.     $Verbose = 0;
  43.     $Debug = 0;
  44.     $Userspace = 0;
  45.  
  46.     my @unknown = ();
  47.  
  48.     @Args = @ARGV;
  49.     
  50.     while (@ARGV > 0 && $ARGV[0] =~ /^-/ && $ARGV[0] !~ /^--/) {
  51.     my $options = shift(@ARGV);
  52.     $options =~ s/^-//;
  53.  
  54.     my %h = (q => \$Quiet, t => \$Error, v => \$Verbose, d => \$Debug,
  55.          u => \$Userspace);
  56.     
  57.     foreach my $option (split(//, $options)) {
  58.         if (my $s = $h{$option}) {
  59.         $$s = 1;
  60.         push(@Options, '-' . $option);
  61.         } else {
  62.         push(@unknown, '-' . $option);
  63.         }
  64.     }
  65.     }
  66.  
  67.     $Error = 1 - $Error;
  68.     
  69.     unshift(@ARGV, @unknown);
  70.  
  71.     $Defoma_Test_Dir = $DEFOMA_TEST_DIR = '';
  72.     if ($Debug) {
  73.     if (exists($ENV{'DEFOMA_TEST_DIR'})) {
  74.         $Defoma_Test_Dir = $DEFOMA_TEST_DIR = $ENV{'DEFOMA_TEST_DIR'};
  75.     }
  76.     
  77.     push(@Scriptdirs, "$DEFOMA_TEST_DIR/usr/local/share/defoma/scripts");
  78.     }
  79.  
  80.     push(@Scriptdirs, "$DEFOMA_TEST_DIR/usr/share/defoma/scripts");
  81.  
  82.     if (exists($ENV{'LC_ALL'})) {
  83.     $Locale = $ENV{'LC_ALL'};
  84.     } elsif (exists($ENV{'LANG'})) {
  85.     $Locale = $ENV{'LANG'};
  86.     } else {
  87.     $Locale = '';
  88.     }
  89.  
  90.     $Homedir = '';
  91.     if ($Userspace) {
  92.     my @l = getpwuid($<);
  93.     $Homedir = "$DEFOMA_TEST_DIR$l[7]";
  94.     $Login = $l[0];
  95.     $Rootdir = $ROOTDIR = "$Homedir/.defoma";
  96.     } else {
  97.     $Rootdir = $ROOTDIR = "$DEFOMA_TEST_DIR/var/lib/defoma";
  98.     }
  99.     
  100.     $Substruledir = "$DEFOMA_TEST_DIR/etc/defoma";
  101.     $Scriptdir = "$ROOTDIR/scripts";
  102.     $Lockfile = "$ROOTDIR/locked";
  103.     
  104.     $DEFAULT_PACKAGE = $DEFAULT_CATEGORY = '';
  105. }
  106.  
  107. sub OPTIONS {
  108.     return @Options;
  109. }
  110.  
  111. sub ARGS {
  112.     return @Args;
  113. }
  114.  
  115. sub DEFOMA_TEST_DIR {
  116.     return $Defoma_Test_Dir;
  117. }
  118.  
  119. sub ROOTDIR {
  120.     return $Rootdir;
  121. }
  122.  
  123. sub SCRIPTDIR {
  124.     return $Scriptdir;
  125. }
  126.  
  127. sub SCRIPTDIRS {
  128.     return @Scriptdirs;
  129. }
  130.  
  131. sub SUBSTRULEDIR {
  132.     return $Substruledir;
  133. }
  134.  
  135. sub HOMEDIR {
  136.     return $Homedir;
  137. }
  138.  
  139. sub LOCKFILE {
  140.     return $Lockfile;
  141. }
  142.  
  143. sub QUIET {
  144.     return $Quiet;
  145. }
  146.  
  147. sub ERROR {
  148.     return $Error;
  149. }
  150.  
  151. sub LOCALE {
  152.     return $Locale;
  153. }
  154.  
  155. sub USERSPACE {
  156.     return $Userspace;
  157. }
  158.  
  159. sub VERSION {
  160.     return $Version;
  161. }
  162.  
  163. sub USERLOGIN {
  164.     return $Login;
  165. }
  166.  
  167. sub printd {
  168.     return unless ($Debug);
  169.     my @c = caller(0);
  170.  
  171.     print STDERR $c[3], " at line ", $c[2], " in ", $c[1], ": ", @_, "\n";
  172. }
  173.  
  174. sub printm {
  175.     return if ($Quiet);
  176.  
  177.     print STDERR @_, "\n";
  178. }
  179.  
  180. my $CALLERLEVEL = 0;
  181.  
  182. sub printw {
  183.     print "W: ", @_, "\n";
  184. }
  185.  
  186. sub printe {
  187.     print "E: ", @_, "\n";
  188. }
  189.  
  190.  
  191. sub printee {
  192.     my @c = caller($CALLERLEVEL);
  193.     $CALLERLEVEL = 0;
  194.     
  195.     print STDERR $c[3], " at line ", $c[2], " in ", $c[1], ": ", @_, "\n";
  196. }
  197.  
  198. sub printv {
  199.     return unless ($Verbose);
  200.  
  201.     print @_, "\n";
  202. }
  203.  
  204. sub get_files {
  205.     my $pattern = shift;
  206.     my $directory = shift;
  207.     my $i;
  208.     my @caches = ();
  209.     my @list;
  210.  
  211.     opendir(D, $directory) || return ();
  212.     @list = readdir(D);
  213.     closedir(D);
  214.  
  215.     foreach $i (@list) {
  216.     if ($i =~ /$pattern/) {
  217.         push(@caches, $i);
  218.     }
  219.     }
  220.  
  221.     return @caches;
  222. }
  223.  
  224. sub diff_files {
  225.     my $file1 = shift;
  226.     my $file2 = shift;
  227.  
  228.     return 1 if ((-s $file1) != (-s $file2));
  229.  
  230.     my $err = system("/usr/bin/cmp", "-s", $file1, $file2);
  231.     return $err;
  232. }
  233.  
  234. sub arg_check {
  235.     my @b = @_;
  236.     while (@_ > 0) {
  237.     my $s = shift;
  238.     if ($s =~ /[ \t]/ || $s eq '') {
  239.         $CALLERLEVEL = 2;
  240.         printee "(", join(', ', @b), "): Illegal argument.";
  241.         return 0;
  242.     }
  243.     }
  244.  
  245.     return 1;
  246. }
  247.  
  248. sub arg_check_category {
  249.     while (@_ > 0) {
  250.     my $s = shift;
  251.     if ($s !~ /^[A-Za-z0-9-]+$/) {
  252.         $CALLERLEVEL = 2;
  253.         printee "'$s': Illegal Category name.";
  254.         return 0 ;
  255.     }
  256.     }
  257.  
  258.     return 1;
  259. }
  260.  
  261. sub add_hash_list {
  262.     my $hashptr = shift;
  263.     my $key = shift;
  264.     my $str = shift;
  265.  
  266.     if (exists($hashptr->{$key})) {
  267.     $hashptr->{$key} .= ' ';
  268.     } else {
  269.     $hashptr->{$key} = '';
  270.     }
  271.  
  272.     $hashptr->{$key} .= $str;
  273. }
  274.  
  275. sub mylock {
  276.     my $flag = 0;
  277.     my $op = shift;
  278.     my $bg = (@_ > 0) ? shift(@_) : '';
  279.  
  280.     if (USERSPACE) {
  281.     mkdir(ROOTDIR) unless (-d ROOTDIR);
  282.     mkdir(SCRIPTDIR) unless (-d SCRIPTDIR);
  283.     
  284.     if ((-e ROOTDIR && ! -d ROOTDIR) || -l ROOTDIR) {
  285.         printe("Defoma-root-dir " . ROOTDIR . " is occupied.");
  286.         exit ERROR;
  287.     }
  288.     if ((-e SCRIPTDIR && ! -d SCRIPTDIR) || -l SCRIPTDIR) {
  289.         printe("Script-dir " . SCRIPTDIR . " is occupied.");
  290.         exit ERROR;
  291.     }
  292.     }
  293.     
  294.     if ($op == 0) {
  295.     unlink($Lockfile);
  296.     } elsif ($op == 1) {
  297.     symlink("locknow", $Lockfile) && return 0;
  298.  
  299.     printe("$Lockfile exists.");
  300.     unless (USERSPACE) {
  301.         printe("Another defoma process seems running, or you aren't root.");
  302.         printe("If you are root and defoma process isn't running undoubtedly,");
  303.         printe("it is possible that defoma might have aborted.");
  304.         printe("Please run defoma-reconfigure -f to fix its broken status.");
  305.         exit ERROR;
  306.     } else {
  307.         printe("Another defoma process seems running, or defoma might ".
  308.            "have aborted.");
  309.         printe("Please run defoma-user reconfigure to fix its broken status.");
  310.         exit ERROR;
  311.     }
  312.     }
  313. }
  314.  
  315. sub get_system_categories {
  316.     # update defoma-reconfigure too.
  317.     return ('x-postscript', 'postscript', 'xfont', 'pspreview', 'obsoleted');
  318. }
  319.  
  320. ###### IdObject And SubstObject 
  321.  
  322. my %IdObject = ();
  323.  
  324. sub register_id_object {
  325.     my $o = shift;
  326.     my $pkg = shift;
  327.     my $suffix = shift;
  328.  
  329.     $IdObject{"$pkg/$suffix"} = $o;
  330. }
  331.  
  332. sub get_id_object {
  333.     my $pkg = shift;
  334.     my $suffix = shift;
  335.  
  336.     if (exists($IdObject{"$pkg/$suffix"})) {
  337.     return $IdObject{"$pkg/$suffix"};
  338.     }
  339.  
  340.     return '';
  341. }
  342.  
  343. sub clear_id_object {
  344.     %IdObject = ();
  345. }
  346.  
  347. my %SubstObject = ();
  348.  
  349. sub register_subst_object {
  350.     my $o = shift;
  351.     my $rulename = shift;
  352.  
  353.     $SubstObject{$rulename} = $o;
  354. }
  355.  
  356. sub get_subst_object {
  357.     my $rulename = shift;
  358.  
  359.     if (exists($SubstObject{$rulename})) {
  360.     return $SubstObject{$rulename};
  361.     }
  362.  
  363.     return '';
  364. }
  365.  
  366. sub clear_subst_object {
  367.     %SubstObject = ();
  368. }
  369.  
  370. ###### Parsehints 
  371.  
  372. sub parse_hints_start {
  373.     my $ret = {};
  374.     my $key = '';
  375.     my $addflag = 0;
  376.  
  377.     foreach my $item (@_) {
  378.     if ($item =~ /^--(.*)/) {
  379.         if ($key && $addflag == 0) {
  380.         $ret->{$key} = '';
  381.         }
  382.         $key = $1;
  383.         $addflag = 0;
  384.     } elsif ($key) {
  385.         $addflag = 1;
  386.         add_hash_list($ret, $key, $item);
  387.     }
  388.     }
  389.  
  390.     if ($key && $addflag == 0) {
  391.     $ret->{$key} = '';
  392.     }
  393.  
  394.     return $ret;
  395. }
  396.  
  397. sub parse_hints_subhints {
  398.     my $parsed = shift;
  399.     my $subnum = shift;
  400.     my $ret = {};
  401.  
  402.     $subnum = '' if ($subnum == 0);
  403.  
  404.     foreach my $k (keys(%{$parsed})) {
  405.     if ($k =~ /(.*[^0-9-])-?$subnum$/) {
  406.         $ret->{$1} = $parsed->{$k};
  407.     }
  408.     }
  409.  
  410.     return $ret;
  411. }
  412.  
  413. sub parse_hints_subhints_inherit {
  414.     my $parsed = shift;
  415.     my $subnum = shift;
  416.  
  417.     my $ret = parse_hints_subhints($parsed, $subnum);
  418.  
  419.     return $ret if ($subnum == 0 || ! exists($parsed->{Inherit}));
  420.  
  421.     my @l = split(' ', $parsed->{Inherit});
  422.  
  423.     foreach my $k (@l) {
  424.     unless (exists($ret->{$k})) {
  425.         $ret->{$k} = $parsed->{$k};
  426.     }
  427.     }
  428.  
  429.     return $ret;
  430. }
  431.  
  432. sub parse_hints_cut {
  433.     my $parsed = shift;
  434.     my $key;
  435.  
  436.     foreach $key (@_) {
  437.     if (exists($parsed->{$key})) {
  438.         delete($parsed->{$key});
  439.     }
  440.     }
  441. }
  442.  
  443. sub parse_hints_cut_except {
  444.     my $parsed = shift;
  445.     my $key;
  446.     my @l = keys(%{$parsed});
  447.  
  448.     foreach $key (@l) {
  449.     unless (grep($_ eq $key, @_)) {
  450.         delete($parsed->{$key});
  451.     }
  452.     }
  453. }
  454.  
  455. sub parse_hints_build {
  456.     my $parsed = shift;
  457.     my $key;
  458.     my @keys = keys(%{$parsed});
  459.     my @ret = ();
  460.  
  461.     foreach $key (@keys) {
  462.     push(@ret, '--' . $key);
  463.     push(@ret, split(' ', $parsed->{$key}));
  464.     }
  465.  
  466.     return @ret;
  467. }
  468.  
  469. ###### File Handler ######
  470.  
  471. sub readfile {
  472.     my $file = shift;
  473.     my $fh = new FileHandle($file, "r");
  474.     my @ret = ();
  475.  
  476.     if (defined($fh)) {
  477.     while (<$fh>) {
  478.         chomp($_);
  479.         push(@ret, $_);
  480.     }
  481.  
  482.     $fh->close();
  483.     }
  484.  
  485.     return @ret;
  486. }
  487.  
  488. sub writefile {
  489.     my $file = shift;
  490.     my $fh = new FileHandle($file, "w");
  491.  
  492.     if (defined($fh)) {
  493.     while (@_) {
  494.         $fh->print(shift, "\n");
  495.     }
  496.     
  497.     $fh->close();
  498.     }
  499. }
  500.  
  501. sub app_readfile {
  502.     my $file = shift;
  503.     
  504.     return readfile("$Rootdir/$DEFAULT_PACKAGE.d/$file");
  505. }
  506.  
  507. sub app_writefile {
  508.     my $file = shift;
  509.  
  510.     return writefile("$Rootdir/$DEFAULT_PACKAGE.d/$file", @_);
  511. }
  512.  
  513. sub app_symlink {
  514.     my $src = shift;
  515.     my $dest = shift;
  516.  
  517.     return symlink($src, "$Rootdir/$DEFAULT_PACKAGE.d/$dest");
  518. }
  519.  
  520. sub app_unlink {
  521.     my $file = shift;
  522.  
  523.     return unlink("$Rootdir/$DEFAULT_PACKAGE.d/$file");
  524. }
  525.  
  526. ###### DataFile Handler ######
  527.  
  528. my @XencData;
  529.  
  530. sub read_csetenc_xenc_data {
  531.     my $dir = shift;
  532.     $dir .= "/csetenc-xenc.data2";
  533.  
  534.     unless (@XencData) {
  535.     my @file = readfile($dir);
  536.  
  537.     while (@file) {
  538.         my $a = shift(@file);
  539.         
  540.         next if ($a =~ /^\#/);
  541.  
  542.         my @l = split(/[ \t]+/, $a);
  543.         next if (@l < 3);
  544.  
  545.         $l[0] =~ s/\*/\.\*/g;
  546.         $l[0] =~ s/\?/\./g;
  547.  
  548.         $l[1] =~ s/\*/\.\*/g;
  549.         $l[1] =~ s/\?/\./g;
  550.  
  551.         my $p = [];
  552.         $p->[0] = $l[0];
  553.         $p->[1] = $l[1];
  554.         $p->[2] = $l[2];
  555.  
  556.         push(@XencData, $p);
  557.     }
  558.     }
  559. }
  560.  
  561. sub get_xencoding {
  562.     my $charset = shift;;
  563.     my $encoding = shift || '';
  564.  
  565.     unless (@XencData) {
  566.     read_csetenc_xenc_data("$DEFOMA_TEST_DIR/etc/defoma");
  567.     read_csetenc_xenc_data("$DEFOMA_TEST_DIR/usr/share/defoma");
  568.     }
  569.     
  570.     foreach my $i (@XencData) {
  571.     if ($charset =~ /^($i->[0])$/ && $encoding =~ /^($i->[1])$/) {
  572.         if ($i->[2] eq 'ignore' || $i->[2] eq 'none') {
  573.         return '';
  574.         } else {
  575.         return $i->[2];
  576.         }
  577.     }
  578.     }
  579.  
  580.     return '';
  581. }
  582.  
  583. my @X2C;
  584.  
  585. sub read_xenc_cset_file {
  586.     my $dir = shift;
  587.     $dir .= "/xenc-cset.data";
  588.     
  589.     my $i;
  590.     my @l;
  591.     my @file = readfile($dir);
  592.  
  593.     while (@file) {
  594.     my $a = shift(@file);
  595.  
  596.     next if ($a =~ /^\#/);
  597.     
  598.     @l = split(' ', $a);
  599.     if (@l >= 2) {
  600.         $l[0] =~ s/\./\\./g;
  601.         $l[0] =~ s/\*/\.*/g;
  602.         $l[0] =~ s/\?/\./g;
  603.         
  604.         push(@X2C, $l[0], $l[1]);
  605.     }
  606.     }
  607. }
  608.  
  609. sub get_charset {
  610.     my $xfont = shift;
  611.     my $i;
  612.  
  613.     unless (@X2C) {
  614.     read_xenc_cset_file("$DEFOMA_TEST_DIR/etc/defoma");
  615.     read_xenc_cset_file("$DEFOMA_TEST_DIR/usr/share/defoma");
  616.     }
  617.     
  618.     $xfont =~ /([^-]+-[^-]+)$/;
  619.     my $xenc = $1;
  620.     
  621.     for ($i = 0; $i < @X2C; $i += 2) {
  622.     return $X2C[$i + 1] if ($xenc =~ /^($X2C[$i])$/);
  623.     }
  624.  
  625.     return '';
  626. }
  627.  
  628. ###### Weight -> Numeric ######
  629.  
  630. my %Weight2Numeric = ( Medium => 0,
  631.                Regular => 0,
  632.                Normal => 0,
  633.                Book => 0,
  634.                UltraBold => 4,
  635.                Ultrabold => 4,
  636.                ExtraBold => 3,
  637.                Extrabold => 3,
  638.                Bold => 2,
  639.                Semibold => 1,
  640.                DemiBold => 1,
  641.                Demibold => 1,
  642.                ExtraLight => -3,
  643.                Extralight => -3,
  644.                Light => -2,
  645.                SemiLight => -1,
  646.                Semilight => -1);
  647.  
  648. sub weight_a2i {
  649.     my $weight = shift;
  650.  
  651.     return 0 unless ($weight);
  652.  
  653.     exists($Weight2Numeric{$weight}) && return $Weight2Numeric{$weight};
  654.  
  655.     $weight =~ tr/A-Z/a-z/;
  656.     my @l = keys(%Weight2Numeric);
  657.     foreach my $k (@l) {
  658.     my $j = $k;
  659.     $j =~ tr/A-Z/a-z/;
  660.  
  661.     return $Weight2Numeric{$k} if ($j eq $weight);
  662.     }
  663.  
  664.     return 0;
  665. }
  666.  
  667. sub weight_ascii2integer {
  668.     return weight_a2i(@_);
  669. }
  670.  
  671. ###### get XLFD from x-ttcidfont-conf database ######
  672.  
  673. my ($XId, $XId2);
  674.  
  675. sub get_xlfd_of_font {
  676.     my $font = shift;
  677.     my %op = @_;
  678.     
  679.     my $level = $op{level} || '';
  680.     my $face = $op{face};
  681.     
  682.     unless ($XId) {
  683.     my $pkg = 'x-ttcidfont-conf';
  684.     $XId = &Debian::Defoma::Id::defoma_id_open_cache('', $pkg);
  685.     $XId2 = &Debian::Defoma::Id::defoma_id_open_cache('sub', $pkg);
  686.     return () unless ($XId && $XId2);
  687.     }
  688.  
  689.     my @ret;
  690.     my @l = &Debian::Defoma::Id::defoma_id_grep_cache($XId, 'real',
  691.                               font => $font);
  692.     foreach my $i (@l) {
  693.     next if ($XId->{2}->[$i] ne 'SrI');
  694.  
  695.     my @hints = split(' ', $XId->{7}->[$i]);
  696.     my $ttcap = shift(@hints);
  697.  
  698.     if (defined($face)) {
  699.         next if ($ttcap !~ /fn=$face/ && $ttcap !~ /:$face:/);
  700.     }
  701.  
  702.     if ($level eq 'min') {
  703.         next if ($ttcap =~ /ds=y/ || $ttcap =~ /ai=/);
  704.     }
  705.  
  706.     push(@ret, $XId->{0}->[$i]);
  707.     }
  708.  
  709.     if ($level eq 'max') {
  710.     @l = &Debian::Defoma::Id::defoma_id_grep_cache($XId2, 'real',
  711.                                font => $font);
  712.     foreach my $i (@l) {
  713.         next if ($XId2->{2}->[$i] ne 'SrI');
  714.         
  715.         my @hints = split(' ', $XId2->{7}->[$i]);
  716.         my $ttcap = shift(@hints);
  717.  
  718.         if (defined($face)) {
  719.         next if ($ttcap !~ /fn=$face/ && $ttcap !~ /:$face:/);
  720.         }
  721.  
  722.         push(@ret, $XId2->{0}->[$i]);
  723.     }
  724.     }
  725.  
  726.     return @ret;
  727. }
  728.     
  729. package Debian::Defoma::Configure;
  730. use strict;
  731. #no strict 'subs';
  732. use POSIX;
  733. use File::Copy;
  734.  
  735. use vars qw(@ISA $DEFAULT_PACKAGE $DEFAULT_CATEGORY
  736.         @ACCEPT_CATEGORIES $APPINFO);
  737.  
  738. use Debian::Defoma::Common;
  739. import Debian::Defoma::Common qw($DEFAULT_CATEGORY $DEFAULT_PACKAGE
  740.                  &get_files &diff_files &readfile &writefile);
  741.  
  742.  
  743. my %AppInfo = ();
  744. my %Initialized = ();
  745. my %Categories = ();
  746. my @DefaultPackage = ();
  747. my @DefaultCategory = ();
  748. my %OriginalScripts;
  749. my %RootScripts;
  750. my %FontTouchTime;
  751. my $UpdateTime;
  752.  
  753. sub read_status_cache {
  754.     my $rootdir = shift;
  755.  
  756.     %FontTouchTime = ();
  757.     $UpdateTime = 0;
  758.     
  759.     my @file = readfile($rootdir . "/status-cache");
  760.  
  761.     while (@file) {
  762.     my @l = split(' ', shift(@file));
  763.  
  764.     my $mode = shift(@l);
  765.     
  766.     if ($mode eq 'font-last-modified') {
  767.         $FontTouchTime{$l[0]} = $l[1];
  768.     } elsif ($mode eq 'app-ignore') {
  769.         hash_app_info($l[0], 'ignore_category', $l[1], undef);
  770.     } elsif ($mode eq 'app-subdirs') {
  771.         push_app_info($l[0], 'subdirs', $l[1]);
  772.     } elsif ($mode eq 'app-links') {
  773.         push_app_info($l[0], 'links', $l[1].' '.$l[2]);
  774.     } elsif ($mode eq 'defoma-last-run') {
  775.         $UpdateTime = $l[0];
  776.     }
  777.     }
  778. }
  779.  
  780. sub write_status_cache {
  781.     my $time = time();
  782.     my @file = ();
  783.     
  784.     foreach my $fobj (values(%Debian::Defoma::Font::Fobjs)) {
  785.     my $c = $fobj->{category};
  786.     my $t = ($fobj->{updated} || ! $FontTouchTime{$c}) ?
  787.         $time : $FontTouchTime{$c};
  788.     
  789.     push(@file, "font-last-modified $c $t");
  790.     }
  791.     
  792.     foreach my $app (keys(%AppInfo)) {
  793.     if ($AppInfo{$app}->{ignore_category}) {
  794.         foreach my $i (keys(%{$AppInfo{$app}->{ignore_category}})) {
  795.         push(@file, "app-ignore $app $i");
  796.         }
  797.     }
  798.     if ($AppInfo{$app}->{subdirs}) {
  799.         foreach my $d (@{$AppInfo{$app}->{subdirs}}) {
  800.         push(@file, "app-subdirs $app $d") if ($d ne '');
  801.         }
  802.     }
  803.     if ($AppInfo{$app}->{links}) {
  804.         foreach my $l (@{$AppInfo{$app}->{links}}) {
  805.         push(@file, "app-links $app $l") if ($l ne '');
  806.         }
  807.     }
  808.     }
  809.     
  810.     push(@file, "defoma-last-run $time");
  811.  
  812.     writefile(ROOTDIR . "/status-cache", @file);
  813. }
  814.  
  815. sub set_app_info {
  816.     my $app = shift;
  817.     my $key = shift;
  818.     my $value = shift;
  819.  
  820.     unless (exists($AppInfo{$app})) {
  821.     $AppInfo{$app} = {};
  822.     }
  823.  
  824.     $AppInfo{$app}->{$key} = $value;
  825. }
  826.  
  827. sub push_app_info {
  828.     my $app = shift;
  829.     my $key = shift;
  830.  
  831.     unless (exists($AppInfo{$app})) {
  832.     $AppInfo{$app} = {};
  833.     }
  834.  
  835.     unless (exists($AppInfo{$app}->{$key})) {
  836.     $AppInfo{$app}->{$key} = [];
  837.     }
  838.  
  839.     push(@{$AppInfo{$app}->{$key}}, @_);
  840. }
  841.  
  842. sub hash_app_info {
  843.     my $app = shift;
  844.     my $key = shift;
  845.     my $hkey = shift;
  846.     my $hvalue = shift;
  847.  
  848.     unless (exists($AppInfo{$app})) {
  849.     $AppInfo{$app} = {};
  850.     }
  851.  
  852.     unless (exists($AppInfo{$app}->{$key})) {
  853.     $AppInfo{$app}->{$key} = {};
  854.     }
  855.  
  856.     $AppInfo{$app}->{$key}->{$hkey} = $hvalue;
  857. }
  858.  
  859. sub set_app_categories {
  860.     my $app = shift;
  861.     
  862.     foreach my $i (@_) {
  863.     $Categories{$i} = [] unless (exists($Categories{$i}));
  864.     if ($app eq 'x-ttcidfont-conf' || $app eq 'psfontmgr') {
  865.         unshift(@{$Categories{$i}}, $app);
  866.     } else {
  867.         push(@{$Categories{$i}}, $app);
  868.     }
  869.     }
  870.  
  871.     push_app_info($app, 'category', @_);
  872. }
  873.  
  874. sub clear_app_info {
  875.     my $app = shift;
  876.  
  877.     if (defined($app)) {
  878.     delete($AppInfo{$app});
  879.     } else {
  880.     %AppInfo = ();
  881.     }
  882. }
  883.  
  884. sub get_app_info {
  885.     my $app = shift;
  886.     
  887.     return $AppInfo{$app};
  888. }
  889.  
  890. sub get_status {
  891.     my $fonttouchtime = shift;
  892.     my $updatetime = shift;
  893.  
  894.     %{$fonttouchtime} = %FontTouchTime;
  895.     $$updatetime = $UpdateTime;
  896. }
  897.  
  898. sub diff_scripts {
  899.     foreach my $app (keys(%OriginalScripts), keys(%RootScripts)) {
  900.     next if (exists($AppInfo{$app}->{script_change}));
  901.     
  902.     if (! $RootScripts{$app} && $OriginalScripts{$app}) {
  903.         set_app_info($app, 'script_change', 'new');
  904.     } elsif ($RootScripts{$app} && ! $OriginalScripts{$app}) {
  905.         set_app_info($app, 'script_change', 'obsoleted');
  906.         set_app_info($app, 'ignoreall', 1);
  907.         printw("$app is already removed. ".
  908.            "It is recommended to run defoma-app purge $app.");
  909.     } else {
  910.         if (diff_files($RootScripts{$app}, $OriginalScripts{$app})) {
  911.         set_app_info($app, 'script_change', 'updated');
  912.         set_app_info($app, 'ignoreall', 1);
  913.         } else {
  914.         set_app_info($app, 'script_change', 'same');
  915.         }
  916.     }
  917.     }
  918.  
  919.     return 0;
  920. }
  921.  
  922. sub init_scripts {
  923.     # Check out /usr/share/defoma/scripts
  924.  
  925.     my $pat = (USERSPACE) ? "\\.udefoma\$" : "\\.defoma\$";
  926.     my @scripts;
  927.     my $script;
  928.  
  929.     %OriginalScripts = ();
  930.  
  931.     foreach my $dir (SCRIPTDIRS) {
  932.     next unless (-d $dir);
  933.  
  934.     @scripts = get_files($pat, $dir);
  935.     
  936.     foreach $script (@scripts) {
  937.         my $app = $script;
  938.         $app =~ s/$pat//;
  939.         
  940.         unless (exists($OriginalScripts{$app})) {
  941.         $OriginalScripts{$app} = "$dir/$script";
  942.         }
  943.     }
  944.     }
  945.  
  946.     %RootScripts = ();
  947.  
  948.     @scripts = get_files($pat, SCRIPTDIR);
  949.  
  950.     foreach $script (@scripts) {
  951.     my $app = $script;
  952.     $app =~ s/$pat//;
  953.     
  954.     $RootScripts{$app} = SCRIPTDIR ."/$script";
  955.     }
  956. }
  957.  
  958. sub update_script {
  959.     my $app = shift;
  960.  
  961.     my $suffix = (USERSPACE) ? "udefoma" : "defoma";
  962.  
  963.     unless (copy($OriginalScripts{$app}, SCRIPTDIR . "/$app.$suffix")) {
  964.     printe("Failed to copy " . $OriginalScripts{$app} . "to " .
  965.            SCRIPTDIR . ".");
  966.     set_app_info($app, 'error', 1);
  967.     
  968.     return 1;
  969.     }
  970.     
  971.     mkdir(ROOTDIR . "/$app.d");
  972.  
  973.     unless (-d ROOTDIR . "/$app.d") {
  974.     printe("Failed to create application directory: " . ROOTDIR . ".");
  975.     set_app_info($app, 'error', 1);
  976.     
  977.     return 1;
  978.     }
  979.  
  980.     return 0;
  981. }
  982.  
  983. sub remove_script {
  984.     my $app = shift;
  985.  
  986.     my $suffix = (USERSPACE) ? "udefoma" : "defoma";
  987.  
  988.     unlink(SCRIPTDIR . "/$app.$suffix");
  989. }
  990.  
  991. sub purge_script {
  992.     my $app = shift;
  993.  
  994.     remove_script($app);
  995.     
  996.     rrm("$app.d") if (compare_version_app($app, "0.10") >= 0);
  997.     
  998.     links_purge($app);
  999.  
  1000.     clear_app_info($app);
  1001. }
  1002.  
  1003. sub load_scripts {
  1004.     my $updateapp = shift || '';
  1005.     
  1006.     foreach my $app (keys(%AppInfo)) {
  1007.     if ($AppInfo{$app}->{script_change} eq 'new' && $app eq $updateapp) {
  1008.         # new script
  1009.         next if (update_script($app));
  1010.     }
  1011.  
  1012.     my $suffix = (USERSPACE) ? "udefoma" : "defoma";
  1013.     my $script = SCRIPTDIR . "/$app.$suffix";
  1014.     
  1015.     next unless (-f $script);
  1016.  
  1017.     @ACCEPT_CATEGORIES = ();
  1018.     undef $APPINFO;
  1019.     $APPINFO = {};
  1020.     
  1021.     eval('require($script);');
  1022.     if ($@) {
  1023.         printe("Unable to load: $script because:\n$@");
  1024.         set_app_info($app, 'error', 1);
  1025.     }
  1026.     
  1027.     if (compare_version_app($app, VERSION) > 0) {
  1028.         printe("$app.$suffix requires defoma ", $AppInfo{$app}->{require},
  1029.            " or later version while the installed version is ",
  1030.            VERSION, ".");
  1031.         set_app_info($app, 'error', 1);
  1032.         
  1033.         next;
  1034.     }
  1035.     
  1036.     if ($AppInfo{$app}->{script_change} eq 'new' && $app eq $updateapp &&
  1037.         compare_version_app($app, "0.10") >= 0) {
  1038.         # new script
  1039.         subdirs_update($app) && next;
  1040.         links_update($app) && next;
  1041.     }
  1042.  
  1043.     set_app_categories($app, @ACCEPT_CATEGORIES);
  1044. #    set_app_info($app, 'info', $APPINFO);
  1045.     }
  1046. }
  1047.  
  1048. sub init {
  1049.     read_status_cache(ROOTDIR);
  1050.  
  1051.     init_scripts();
  1052.  
  1053.     diff_scripts();
  1054. }
  1055.  
  1056. sub init2 {
  1057.     load_scripts(@_);
  1058.     write_status_cache();
  1059. }
  1060.  
  1061. sub term {
  1062.     my @list = keys(%Initialized);
  1063.     my ($i, $c, $a);
  1064.     
  1065.     foreach $i (@list) {
  1066.     $i =~ /(.*)\/(.*)/;
  1067.     $c = $1;
  1068.     $a = $2;
  1069.     
  1070.     push(@DefaultPackage, $DEFAULT_PACKAGE);
  1071.     push(@DefaultCategory, $DEFAULT_CATEGORY);
  1072.     
  1073.     $DEFAULT_PACKAGE = $a;
  1074.     $DEFAULT_CATEGORY = $c;
  1075.  
  1076.     $a =~ s/[^a-zA-Z0-9]/_/g;
  1077.     $c =~ s/[^a-zA-Z0-9]/_/g;
  1078.     
  1079.     eval("${a}::${c}('term')");
  1080.     printw("In ${a}::${c}('term'): ", $@) if ($@);
  1081.  
  1082.     $DEFAULT_PACKAGE = pop(@DefaultPackage);
  1083.     $DEFAULT_CATEGORY = pop(@DefaultCategory);
  1084.     }
  1085.  
  1086.     write_status_cache();
  1087.  
  1088.     foreach my $app (keys(%AppInfo)) {
  1089.     if ($AppInfo{$app}->{error}) {
  1090.         remove_script($app);
  1091.         
  1092.         printe("$app was excluded from configuration due to the error " .
  1093.            "in the header.");
  1094.         printe("Please perform the following things.");
  1095.         printe("  (1) run defoma-app purge $app.");
  1096.         printe("  (2) upgrade $app and/or defoma.");
  1097.         printe("  (3) run defoma-app update $app.");
  1098.     }
  1099.     }
  1100.     
  1101.     return 0;
  1102. }
  1103.  
  1104. sub subdirs_update {
  1105.     my $app = shift;
  1106.     my $pkgdir = ROOTDIR . "/$app.d";
  1107.     
  1108.     if ($APPINFO->{subdirs}) {
  1109.     if ($AppInfo{$app}->{subdirs}) {
  1110.         foreach my $dir (@{$AppInfo{$app}->{subdirs}}) {
  1111.         unless (grep($_ eq $dir, @{$APPINFO->{subdirs}})) {
  1112.             # obsoleted subdirectory
  1113.             rrm("$app.d/$dir");
  1114.             $dir = '';
  1115.         }
  1116.         }
  1117.     }
  1118.     
  1119.     foreach my $dir (@{$APPINFO->{subdirs}}) {
  1120.         if ($dir =~ /^\// || $dir =~ /\.\./) {
  1121.         printe("Illegal app subdirs: $pkgdir/$dir. ");
  1122.         set_app_info($app, 'error', 1);
  1123.         return 1;
  1124.         }
  1125.         unless (-d "$pkgdir/$dir") {
  1126.         # new subdirectory
  1127.         if (mkdirp("$pkgdir/$dir")) {
  1128.             printe("$pkgdir/$dir: mkdir failed. ");
  1129.             set_app_info($app, 'error', 1);
  1130.             return 1;
  1131.         }
  1132.  
  1133.         push_app_info($app, 'subdirs', $dir);
  1134.         }
  1135.     }
  1136.     } elsif ($AppInfo{$app}->{subdirs}) {
  1137.     foreach my $dir (@{$AppInfo{$app}->{subdirs}}) {
  1138.         # obsoleted subdirectory
  1139.         rrm("$app.d/$dir");
  1140.         $dir = '';
  1141.     }
  1142.     }
  1143. }
  1144.  
  1145. sub links_update {
  1146.     my $app = shift;
  1147.     my $pkgdir = ROOTDIR . "/$app.d";
  1148.     
  1149.     if ($APPINFO->{links}) {
  1150.     if ($AppInfo{$app}->{links}) {
  1151.         foreach my $links (@{$AppInfo{$app}->{links}}) {
  1152.         unless (grep($_ eq $links, @{$APPINFO->{links}})) {
  1153.             # obsoleted link
  1154.             my @l = split(' ', $links);
  1155.             unlink(DEFOMA_TEST_DIR . $l[1]);
  1156.             $links = '';
  1157.         }
  1158.         }
  1159.     }
  1160.     
  1161.     foreach my $links (@{$APPINFO->{links}}) {
  1162.         next if ($AppInfo{$app}->{links} &&
  1163.              grep($_ eq $links, @{$AppInfo{$app}->{links}}));
  1164.         # new link
  1165.         
  1166.         my @l = split(' ', $links);
  1167.  
  1168.         unless (@l == 2) {
  1169.         printe("$app contains illegal links in the header.");
  1170.         next;
  1171.         }
  1172.         
  1173.         my $src = $l[0];
  1174.         my $dest = DEFOMA_TEST_DIR . "$l[1]";
  1175.  
  1176.         if ($dest !~ /^\// || index($dest, ROOTDIR) != -1 ||
  1177.         $src =~ /^\// || $src =~ /\.\./) {
  1178.         printe("Illegal app links: $dest -> $pkgdir/$src. ");
  1179.         set_app_info($app, 'error', 1);
  1180.         return 1;
  1181.         }
  1182.         
  1183.         unless (symlink("$pkgdir/$src", $dest)) {
  1184.         printe("$dest -> $pkgdir/$src: symlink failed. ");
  1185.         set_app_info($app, 'error', 1);
  1186.         return 1;
  1187.         }
  1188.         
  1189.         push_app_info($app, 'links', $links);
  1190.     }
  1191.     } elsif ($AppInfo{$app}->{links}) {
  1192.     links_purge($app);
  1193.     }
  1194. }
  1195.  
  1196. sub links_purge {
  1197.     my $app = shift;
  1198.     
  1199.     if ($AppInfo{$app}->{links}) {
  1200.     foreach my $links (@{$AppInfo{$app}->{links}}) {
  1201.         my @l = split(' ', $links);
  1202.         unlink(DEFOMA_TEST_DIR . $l[1]);
  1203.         $links = '';
  1204.     }
  1205.     }
  1206. }
  1207.  
  1208. sub call_1 {
  1209.     my $fobj = shift;
  1210.     my $app = shift;
  1211.     my $com = shift;
  1212.     my $category = shift;
  1213.     my $font = shift;
  1214.  
  1215.     return 0 if ($AppInfo{$app}->{ignoreall});
  1216.     return 0 if ($AppInfo{$app}->{ignore_category} &&
  1217.          exists($AppInfo{$app}->{ignore_category}->{$category}));
  1218.  
  1219.     push(@DefaultPackage, $DEFAULT_PACKAGE);
  1220.     push(@DefaultCategory, $DEFAULT_CATEGORY);
  1221.  
  1222.     $DEFAULT_PACKAGE = $app;
  1223.     $DEFAULT_CATEGORY = $category;
  1224.  
  1225.     my $appi = $app;
  1226.     $appi =~ s/[^a-zA-Z0-9]/_/g;
  1227.     my $ctgi = $category;
  1228.     $ctgi =~ s/[^a-zA-Z0-9]/_/g;
  1229.  
  1230.     unless (exists($Initialized{"$category/$app"})) {
  1231.     $Initialized{"$category/$app"} = '';
  1232.     eval("${appi}::${ctgi}('init')");
  1233.     printw("In ${appi}::${ctgi}('init'): ", $@) if ($@);
  1234.     }
  1235.  
  1236.     my $ret = eval("${appi}::${ctgi}(\$com, \$font, \@_)");
  1237.     printw("In ${appi}::${ctgi}('$com', '$font', ...): ", $@) if ($@);
  1238.  
  1239.     $DEFAULT_PACKAGE = pop(@DefaultPackage);
  1240.     $DEFAULT_CATEGORY = pop(@DefaultCategory);
  1241.  
  1242.     if ($fobj && $com eq 'unregister') {
  1243.     if ($fobj->remove_failed($font, $app)) {
  1244.         return 0;
  1245.     }
  1246.     }
  1247.  
  1248.     if ($ret && $fobj && $com eq 'register') {
  1249.     $fobj->add_failed($font, $app, $ret);
  1250.     printv("$font: failed to register for package $app, status($ret).");
  1251.     }
  1252.  
  1253.     return $ret;
  1254. }
  1255.  
  1256. sub call_m {
  1257.     my $fobj = shift;
  1258.     my $com = shift;
  1259.     my $category = shift;
  1260.     my $font = shift;
  1261.  
  1262.     return unless (exists($Categories{$category}));
  1263.  
  1264.     foreach my $app (@{$Categories{$category}}) {
  1265.     call_1($fobj, $app, $com, $category, $font, @_);
  1266.     }
  1267.  
  1268.     return 0;
  1269. }
  1270.  
  1271. sub rrm {
  1272.     my $dir = shift;
  1273.     my $cwd = getcwd();
  1274.  
  1275.     chdir(ROOTDIR);
  1276.     return 1 unless (ROOTDIR eq getcwd());
  1277.     return 1 if ($dir =~ /^\// || $dir =~ /\.\./);
  1278.  
  1279.     system("/bin/rm", "-r", $dir) if (-e $dir);
  1280.  
  1281.     chdir($cwd);
  1282.  
  1283.     return 0;
  1284. }
  1285.  
  1286. sub mkdirp {
  1287.     my $dir = shift;
  1288.  
  1289.     my $dirs = '';
  1290.     foreach my $d (split('/', $dir)) {
  1291.     $dirs .= "/" . $d;
  1292.     next if (-d $dirs);
  1293.     
  1294.     mkdir($dirs) || return 1;
  1295.     }
  1296.  
  1297.     return 0;
  1298. }
  1299.  
  1300. sub compare_version {
  1301.     my @v1 = split(/\./, shift);
  1302.     my @v2 = split(/\./, shift);
  1303.  
  1304.     while (@v1 > 0 || @v2 > 0) {
  1305.     my $vv1 = (@v1 > 0) ? shift(@v1) : 0;
  1306.     my $vv2 = (@v2 > 0) ? shift(@v2) : 0;
  1307.  
  1308.     return -1 if ($vv1 < $vv2);
  1309.     return 1 if ($vv1 > $vv2);
  1310.     }
  1311.  
  1312.     return 0;
  1313. }
  1314.  
  1315. sub compare_version_app {
  1316.     my $app = shift;
  1317.  
  1318.     my $v = ($AppInfo{$app} && $AppInfo{$app}->{require}) ?
  1319.     $AppInfo{$app}->{require} : 0;
  1320.  
  1321.     return compare_version($v, shift);
  1322. }
  1323.  
  1324. sub get_app_categories {
  1325.     my $app = shift;
  1326.  
  1327.     return () unless (exists($AppInfo{$app}) &&
  1328.               exists($AppInfo{$app}->{category}));
  1329.     return @{$AppInfo{$app}->{category}};
  1330. }
  1331.  
  1332. sub get_apps {
  1333.     return keys(%AppInfo);
  1334. }
  1335.  
  1336. 1;    
  1337.