home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _7d95aa67cbac8bcbfc92f54c7d0b6dca < prev    next >
Encoding:
Text File  |  2004-06-01  |  18.6 KB  |  670 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. "C:\TEMP\perl--------------------------------please-run-the-install-script--------------------------------\bin\perl.exe"  -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl_ppminst
  6. :WinNT
  7. "C:\TEMP\perl--------------------------------please-run-the-install-script--------------------------------\bin\perl.exe"  -x -S %0 %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl_ppminst
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  11. goto endofperl_ppminst
  12. @rem ';
  13. #!perl
  14. #line 15
  15. use strict;
  16. use FindBin;
  17. use Data::Dumper;
  18. use PPM::Config;
  19.  
  20. my $VERSION;
  21. BEGIN { $VERSION = '3.05' }
  22.  
  23. my %INST;
  24. my %CONF;
  25. my %keys = (
  26.         root        => 1,
  27.         tempdir        => 1,
  28.         rebuildhtml        => 1,
  29.  
  30.         ARCHITECTURE    => 0,
  31.         CPU            => 0,
  32.         OSVALUE        => 0,
  33.         OSVERSION        => 0,
  34.         PERLCORE        => 0,
  35.         TARGET_TYPE        => 0,
  36.         LANGUAGE        => 0,
  37.         VERSION        => 0,
  38.        );
  39. my $ERR;
  40.  
  41. #============================================================================
  42. # Register a dummy object which implements the required interface.
  43. #============================================================================
  44. my $i = Implementation->new($ENV{PPM_PORT});
  45.  
  46. #============================================================================
  47. # Command Implementors
  48. #============================================================================
  49. package Implementation;
  50. use base qw(PPM::InstallerClient);
  51.  
  52. use Config;
  53. use Fcntl qw(LOCK_SH LOCK_UN LOCK_EX);
  54. use PPM::PPD;
  55. use PPM::Search;
  56. use Data::Dumper;
  57. require File::Spec;
  58.  
  59. # There's a bug in ExtUtils::Install in perl 5.6.1.
  60. # Also exists in ActivePerl 522 (line 168)
  61. BEGIN {
  62.     local $^W;
  63.     require ExtUtils::Install;
  64. }
  65.  
  66. # Query installed packages: returns a list of records about the results.
  67. sub query {
  68.     my $inst = shift;
  69.     my $query = shift;
  70.     my $case = shift;
  71.  
  72.     load_pkgs();
  73.     my @ppds = map { $_->{ppd} } values %INST;
  74.     my $compiled = PPM::PPD::Search->new($query, $case);
  75.     unless ($compiled->valid) {
  76.     $ERR = $compiled->error;
  77.     return 0;
  78.     }
  79.     $ERR = '';
  80.     my @matches = $compiled->search(@ppds);
  81.     return 1, map { $_->ppd } @matches;
  82. }
  83.  
  84. sub properties {
  85.     my $inst = shift;
  86.     my $pkg = shift;
  87.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  88.     return ($INST{$pkg}{ppd}->ppd,
  89.         $INST{$pkg}{pkg}{INSTDATE},
  90.         $INST{$pkg}{pkg}{LOCATION});
  91.     }
  92.     $ERR = "package '$pkg' is not installed.";
  93.     return ();
  94. }
  95.  
  96. sub dependents {
  97.     my $inst = shift;
  98.     my $pkg = shift;
  99.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  100.     return @{ $INST{$pkg}{pkg}{dependents} || [] };
  101.     }
  102.     undef;
  103. }
  104.  
  105. sub remove {
  106.     my ($inst, $pkg, $verbose) = @_;
  107.  
  108.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  109.  
  110.     # Is there an uninstall script?
  111.     my $u_script = eval {
  112.         $INST{$pkg}{ppd}->find_impl_raw($inst)->uninstall_script
  113.     };
  114.     if ($u_script) {
  115.         my %opts = (
  116.         PPM_INSTARCHLIB => $Config{installsitearch},
  117.         PPM_INSTPACKLIST => $INST{$pkg}{pkg}{INSTPACKLIST},
  118.         PPM_INSTROOT => $INST{$pkg}{pkg}{INSTROOT},
  119.         PPM_ACTION => 'uninstall',
  120.         );
  121.         $inst->run_script(pkg_uninstaller($pkg), $u_script, \%opts)
  122.           or return 0;
  123.     }
  124.  
  125.     my $packlist = $INST{$pkg}{pkg}{INSTPACKLIST};
  126.     (my $altpacklist = $packlist) =~ s<\Q$CONF{ARCHITECTURE}\E[\\/]><>i;
  127.     my $forceunlink = \&ExtUtils::Install::forceunlink;
  128.     eval {
  129.         *ExtUtils::Install::forceunlink = sub {
  130.         goto &$forceunlink if -f $_[0];
  131.         warn "Warning: $_[0] was already deleted\n";
  132.         };
  133.         if (-f $packlist) {
  134.         ExtUtils::Install::uninstall($packlist, $verbose, 0);
  135.         }
  136.         elsif (-f $altpacklist) {
  137.         ExtUtils::Install::uninstall($altpacklist, $verbose, 0);
  138.         }
  139.     };
  140.     *ExtUtils::Install::forceunlink = $forceunlink;
  141.     $ERR = "$@" and return 0 if $@;
  142.  
  143.     # Update html and table of contents, if ActivePerl::DocTools is installed:
  144.     if (eval { require ActivePerl::DocTools; 1 }) {
  145.         ActivePerl::DocTools::WriteTOC();
  146.     }
  147.  
  148.     # Remove the package and references to it:
  149.     my $ppd_ref = $INST{$pkg}{ppd};
  150.     my @prereqs;
  151.     eval { @prereqs = $ppd_ref->find_impl_raw($inst)->prereqs };
  152.     del_dependent($_->name, $ppd_ref->name) for @prereqs;
  153.     purge_pkg($pkg);
  154.     }
  155.     else {
  156.     $ERR = "package '$pkg' not installed.";
  157.     return 0;
  158.     }
  159.     return 1;
  160. }
  161.  
  162. sub precious {
  163.     return @{$CONF{precious}};
  164. }
  165.  
  166. sub bundled {
  167.     return @{$CONF{bundled}};
  168. }
  169.  
  170. sub upgrade {
  171.     my ($inst, $pkg, $ppmpath, $ppd, $repos, $verbose) = @_;
  172.     local %ENV = %ENV;
  173.     $ENV{PPM_ACTION} = 'upgrade';
  174.     $inst->install($pkg, $ppmpath, $ppd, $repos, $verbose);
  175. }
  176.  
  177. # This sub is called when the frontend has found an implementation suitable
  178. # for this target, and is double-checking whether we can actually install this
  179. # "content-type".
  180. sub can_install {
  181.     my ($inst, $lang, $version, $compat_type) = @_;
  182.     return 0 unless $lang eq $inst->config_get('LANGUAGE');
  183.     
  184.     # There are two distinct version number schemes for Perl: 5.00x_yy, and
  185.     # 5.x.y. At least, those are the ones I care about. To handle both, I'm
  186.     # going to detect the new format and demote it to the old format. Then I
  187.     # can compare using a regular numeric comparison. The reason I use the old
  188.     # one is so that the PPM3 backend will still work with pre-5.6.0 perls.
  189.     my @parts = split /\./, $version;
  190.     if (@parts > 2) {
  191.     $version = sprintf("%i.%.03i%.03i", @parts);
  192.     }
  193.     return $] >= $version;
  194. }
  195.  
  196. sub install {
  197.     my ($inst, $pkg, $ppmpath, $ppd, $repos, $verbose) = @_;
  198.     use Cwd qw(cwd);
  199.     my $cwd = cwd();
  200.     my $ppd_obj = PPM::PPD->new($ppd);
  201.  
  202.     # Install:
  203.     # 1. chdir to temp directory
  204.     chdir $ppmpath or do {
  205.     $ERR = "can't chdir to $ppmpath: $!";
  206.     return 0;
  207.     };
  208.     chdir $pkg; # this is expected to fail!
  209.  
  210.     use ActiveState::RelocateTree qw(relocate spongedir);
  211.     relocate (
  212.     to      => '.',
  213.     inplace => 1,
  214.     search  => spongedir('ppm'),
  215.     replace => $Config{prefix},
  216.     ) if $Config{osname} ne 'MSWin32';
  217.  
  218.     # 2. set up the install parameters:
  219.     my ($packlist, %opts, %inst_opts);
  220.     {
  221.     my $inst_archlib = $Config{installsitearch};
  222.     my $inst_root = $Config{prefix};
  223.     $packlist = File::Spec->catfile("$inst_archlib/auto",
  224.                 split(/-/, $pkg), ".packlist");
  225.     
  226.     # Copied from ExtUtils::Install
  227.     my $INST_LIB = File::Spec->catdir(File::Spec->curdir, "blib", "lib");
  228.     my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir, "blib", "arch");
  229.     my $INST_BIN = File::Spec->catdir(File::Spec->curdir, "blib", "bin");
  230.     my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir, "blib", "script");
  231.     my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir, "blib", "man1");
  232.     my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir, "blib", "man3");
  233.     my $INST_HTMLDIR = File::Spec->catdir(File::Spec->curdir, "blib", "html");
  234.     my $INST_HTMLHELPDIR = File::Spec->catdir(File::Spec->curdir, "blib", "htmlhelp");
  235.  
  236.     my $inst_script = $Config{installscript};
  237.     my $inst_man1dir = $Config{installman1dir};
  238.     my $inst_man3dir = $Config{installman3dir};
  239.     my $inst_bin = $Config{installbin};
  240.     my $inst_htmldir = $Config{installhtmldir};
  241.     my $inst_htmlhelpdir = $Config{installhtmlhelpdir};
  242.     my $inst_lib = $Config{installsitelib};
  243.     $inst_htmldir ||= "$inst_bin/../html";
  244.     $inst_htmlhelpdir ||= "$inst_bin/../html";
  245.  
  246.     # %inst_opts is used for ExtUtils::Install installs.
  247.     %opts = (
  248.         PPM_INSTARCHLIB => $inst_archlib,
  249.         PPM_INSTROOT => $inst_root,
  250.         PPM_INSTPACKLIST => $packlist,
  251.         PPM_ACTION => (
  252.         defined $ENV{PPM_ACTION} ? $ENV{PPM_ACTION} : 'install'
  253.         ),
  254.         PPM_NEW_VERSION => $ppd_obj->version,
  255.         (
  256.         pkg_installed($pkg) && load_pkg($pkg)
  257.         ? (PPM_PREV_VERSION => $INST{$pkg}{ppd}->version)
  258.         : ()
  259.         ),
  260.     );
  261.     %inst_opts = (
  262.         read => $packlist,
  263.         write => $packlist,
  264.         $INST_LIB => $inst_lib,
  265.         $INST_ARCHLIB => $inst_archlib,
  266.         $INST_BIN => $inst_bin,
  267.         $INST_SCRIPT => $inst_script,
  268.         $INST_MAN1DIR => $inst_man1dir,
  269.         $INST_MAN3DIR => $inst_man3dir,
  270.         $INST_HTMLDIR => $inst_htmldir,
  271.         $INST_HTMLHELPDIR => $inst_htmlhelpdir
  272.     );
  273.     if ($CONF{root} && $CONF{root} !~ /^\Q$inst_root\E$/i) {
  274.         my $root = $CONF{root};
  275.         $_ =~ s/\Q$inst_root/$root\E/i for values %inst_opts;
  276.         $_ =~ s/\Q$inst_root/$root\E/i for values %opts;
  277.         $inst_root = $root;
  278.     }
  279.     }
  280.  
  281.     # 3. Install the package.
  282.     #    This operates slightly differently than PPM2. First,
  283.     #    ExtUtils::Install is only called if q(blib) exists and is a
  284.     #    directory. Next, the install script is run. If it fails, then the
  285.     #    results of ExtUtils::Install are backed out.
  286.     my $inst_blib = -d "blib";
  287.     my $inst_script = eval { $ppd_obj->find_impl_raw($inst)->install_script };
  288.     if ($inst_blib) {
  289.     while (1) {
  290.         eval {
  291.         my $verbose = $verbose - 1; # $verbose < 0 implies silence.
  292.         ExtUtils::Install::install(
  293.             {%inst_opts},
  294.             $verbose,0,0
  295.         );
  296.         };
  297.         # install might have croaked in another directory
  298.         chdir $ppmpath;
  299.         # Can't remove some DLLs, but we can rename them and try again.
  300.         if ($@ && $@ =~ /Cannot forceunlink (\S+)/) {
  301.         my $oldname = $1;
  302.         $oldname =~ s/:$//;
  303.         my $newname = $oldname . "." . time();
  304.         unless (rename($oldname, $newname)) {
  305.             $ERR = "renaming $oldname to $newname: $!";
  306.             return 0;
  307.         }
  308.         }
  309.         # Some other error
  310.         elsif($@) {
  311.         $ERR = "$@";
  312.         return 0;
  313.         }
  314.         else { last; }
  315.     }
  316.     }
  317.     if ($inst_script) {
  318.     $inst->run_script("install_script", $inst_script, \%opts, $verbose)
  319.         or do {
  320.         # Back out ExtUtils::Install
  321.         if ($inst_blib) {
  322.         ExtUtils::Install::uninstall($packlist, $verbose, 0);
  323.         }
  324.         return 0;
  325.     };
  326.     }
  327.     chdir $cwd;
  328.  
  329.     # 4. update html table of contents, if ActivePerl::DocTools is installed:
  330.     if (eval { require ActivePerl::DocTools; 1 }) {
  331.     ActivePerl::DocTools::UpdateHTML()
  332.         if $inst->config_get('rebuildhtml');  # XXX this doesn't work
  333.     ActivePerl::DocTools::WriteTOC();
  334.     }
  335.  
  336.     # Add the package to the list of installed packages
  337.     $INST{$pkg} = {
  338.     pkg => {
  339.         INSTDATE => scalar localtime,
  340.         LOCATION => $repos,
  341.         INSTROOT => $opts{PPM_INSTROOT},
  342.         INSTPACKLIST => $packlist,
  343.            },
  344.     ppd => $ppd_obj,
  345.     };
  346.     save_pkg($pkg, "$ppmpath/uninstall_script");
  347.  
  348.     # "Register" the package as dependent on each prerequisite:
  349.     my @prereqs;
  350.     eval { @prereqs = $ppd_obj->find_impl_raw($inst)->prereqs };
  351.     add_dependent($_->name, $pkg) for @prereqs;
  352.  
  353.     return 1;
  354. }
  355.  
  356. sub config_keys {
  357.     map { [$_, $keys{$_}] } keys %keys;
  358. }
  359.  
  360. sub _str {
  361.     my $a = shift;
  362.     return '' unless defined $a;
  363.     $a;
  364. }
  365.  
  366. sub config_info {
  367.     map { [$_, _str($CONF{$_})] } keys %keys;
  368. }
  369.  
  370. sub config_set {
  371.     my $inst = shift;
  372.     my ($key, $val) = @_;
  373.     unless (defined $keys{$key}) {
  374.     $ERR = "unknown config key '$key'";
  375.     return 0;
  376.     }
  377.  
  378.     $CONF{$key} = $val;
  379.     save_conf();
  380.     return 1;
  381. }
  382.  
  383. sub config_get {
  384.     my $inst = shift;
  385.     my $key = shift;
  386.     unless (defined $key and exists $keys{$key}) {
  387.     $key = '' unless defined $key;
  388.     $ERR = "unknown config key '$key'";
  389.     return undef;
  390.     }
  391.     _str($CONF{$key});
  392. }
  393.  
  394. sub error_str {
  395.     defined $ERR ? $ERR : 'No error';
  396. }
  397.  
  398. #----------------------------------------------------------------------------
  399. # Utilities
  400. #----------------------------------------------------------------------------
  401.  
  402. # This can deal with files as well as directories
  403. sub abspath {
  404.     use Cwd qw(abs_path);
  405.     my ($path, $file) = shift;
  406.     if (-f $path) {
  407.         my @p = split '/', $path;
  408.         $path = join '/', @p[0..$#p-1]; # can't use -2 in a range
  409.         $file = $p[-1];
  410.     }
  411.     $path = abs_path($path || '.');
  412.     return ($path, $file, defined $file ? join '/', $path, $file : ())
  413.       if wantarray;
  414.     return defined $file ? join '/', $path, $file : $path;
  415. }
  416.  
  417. sub run_script {
  418.     my $o    = shift;
  419.     my $file    = shift;
  420.     my $inst    = shift;
  421.     my $setenv    = shift;
  422.     my $verbose    = shift;
  423.     my ($exec, $href, $content) = map { $inst->$_ } qw(exec href script);
  424.  
  425.     # Export %setenv to %ENV:
  426.     local %ENV = %ENV;
  427.     my %setenv = (
  428.     PPM_VERSION => $VERSION,
  429.     PPM_PERL => $Config{perlpath},
  430.     %$setenv,
  431.     );
  432.     $ENV{$_} = $setenv->{$_} for keys %setenv;
  433.  
  434.     # Evaluate special case of EXEC:
  435.     $exec =~ s/\bPPM_PERL\b/$Config{perlpath}/i;
  436.  
  437.     # Four cases:
  438.     # 1. !EXEC && !HREF: system($_) for split ';;';
  439.     # 2. !EXEC &&  HREF: system($_) for split '\n';
  440.     # 3.  EXEC && !HREF: split ';;' => $tmpfile; system($exec, $tmpfile);
  441.     # 4.  EXEC &&  HREF: system($exec, $file);
  442.  
  443.     if (not $exec and not $href) {
  444.     for (split ';;', $content) {
  445.         system($_) == 0 and next;
  446.         $ERR = "system() return non-zero value ($?): '$_'";
  447.         return 0;
  448.     }
  449.     }
  450.     elsif (not $exec) {    # and $href (of course)
  451.     local *INPUT;
  452.     open (INPUT, $file) or do {
  453.         $ERR = "can't open $file: $!";
  454.         return 0;
  455.     };
  456.     while (<INPUT>) {
  457.         system($_) == 0 and next;
  458.         $ERR = "system() returned non-zero value ($?): '$_'";
  459.         return 0;
  460.     }
  461.     }
  462.     elsif (not $href) { # and $exec (of course)
  463.     local *INPUT;
  464.     open (INPUT, "> $file") or die "can't write $file: $!";
  465.     print INPUT "$_\n" for (split ';;', $content);
  466.     close (INPUT) or die "can't close $file: $!";
  467.     system("$exec $file") == 0 or do {
  468.         $ERR = "system() returned non-zero value ($?): '$exec $file'";
  469.         return 0;
  470.     };
  471.     # only a convenience: this whole directory will be removed.
  472.     unlink $file;
  473.     }
  474.     else {
  475.     $exec =~ s/\bSELF\b/abspath($file)/ei and chmod(0777, $file);
  476.     -f $file or do {
  477.         $ERR = "can't run '$exec $file': $!";
  478.         return 0;
  479.     };
  480.     system("$exec $file") == 0 or do {
  481.         $ERR = "(un)install script failed: '$exec $file'";
  482.         return 0;
  483.     };
  484.     }
  485.     $ERR = "";
  486.     return 1;
  487. }
  488.  
  489. sub abs_packlist {
  490.     my $pl = shift;
  491.     $pl =~ s[\%SITELIB\%][$Config{sitelib}]g;
  492.     unless (-f $pl) {
  493.     my $i = $^O eq 'MSWin32' ? '(?i)' : '';
  494.     $pl =~ s[$i^\Q$Config{sitelib}\E][$Config{sitearch}];
  495.     return undef unless -f $pl;
  496.     }
  497.     return $pl;
  498. }
  499.  
  500. #============================================================================
  501. # Settings and packages
  502. #============================================================================
  503. my ($conf_dir, $conf, $conf_obj);
  504. BEGIN {
  505.     # By putting an invalid package character in the directory, we're making
  506.     # sure no real package could overwrite our settings, and vice versa.
  507.     $conf_dir = PPM::Config::tree_conf_dir();
  508.     $conf = join '/', $conf_dir, 'ppm.cfg';
  509. }
  510.  
  511. # Loads the configuration file and populates %CONF
  512. sub load_conf {
  513.     $conf_obj = PPM::Config->new->loadfile($conf);
  514.     %CONF = $conf_obj->config;
  515.  
  516.     # Special values; set them here
  517.     $CONF{ARCHITECTURE} = $Config{archname};
  518.     # Append "-5.8" to architecture name for Perl 5.8 and later
  519.     if (length($^V) && ord(substr($^V,1)) >= 8) {
  520.         $CONF{ARCHITECTURE} .= sprintf("-%d.%d", ord($^V), ord(substr($^V,1)));
  521.     }
  522.     $CONF{PERLCORE} = $Config{version};
  523.     $CONF{TARGET_TYPE} = "perl";
  524.     $CONF{LANGUAGE} = "Perl";
  525.     $CONF{VERSION} = $VERSION;
  526.     $CONF{OSVALUE} = $^O;
  527.     $CONF{OSVERSION} = join(
  528.     ',',
  529.     (((split '\.', $Config{osvers}), (0) x 4)[0..3])
  530.     );
  531. }
  532.  
  533. # Saves %CONF to the configuration file
  534. sub save_conf {
  535.     $conf_obj->merge(\%CONF);
  536.     # Make the file writeable if it isn't already:
  537.     chmod 0666, $conf;
  538.     $conf_obj->save($conf);
  539. }
  540.  
  541. # Loads the given package into $INST{$pkg}. Returns true if the package could
  542. # be loaded, false otherwise.
  543. sub load_pkg {
  544.     my $pkg = shift;
  545.  
  546.     return 1 if exists $INST{$pkg};
  547.  
  548.     return 0 unless -f "$conf_dir/$pkg.ppd";
  549.     return 0 unless -f "$conf_dir/$pkg.pkg";
  550.  
  551.     my $ppdref = PPM::PPD->new("$conf_dir/$pkg.ppd");
  552.     my $pkgfile = "$conf_dir/$pkg.pkg";
  553.     my $pkgref = PPM::Config->new->loadfile($pkgfile);
  554.  
  555.     $INST{$pkg}{ppd} = $ppdref;
  556.     $INST{$pkg}{pkg} = $pkgref->config;
  557.  
  558.     # Substitute the %SITELIB% variable properly.
  559.     $INST{$pkg}{pkg}{INSTPACKLIST} =
  560.     abs_packlist($INST{$pkg}{pkg}{INSTPACKLIST});
  561.     defined $INST{$pkg}{pkg}{INSTPACKLIST}
  562.     or do { purge_pkg($pkg); return 0 };
  563.  
  564.     return 1;
  565. }
  566.  
  567. # Saves the given package from $INST{$pkg}.
  568. sub save_pkg {
  569.     my $pkg = shift;
  570.     my $uninst = shift;
  571.     return 0 unless exists $INST{$pkg};
  572.  
  573.     # the PPD file:
  574.     my $ppdfile = "$conf_dir/$pkg.ppd";
  575.     if (-f $ppdfile) {
  576.     unlink $ppdfile        or die "$0: can't delete $ppdfile: $!";
  577.     }
  578.     open PPD, "> $ppdfile"    or die "$0: can't write $ppdfile: $!";
  579.     print PPD $INST{$pkg}{ppd}->ppd;
  580.     close PPD            or die "$0: can't close $ppdfile: $!";
  581.  
  582.     # the PKG file:
  583.     my $c = PPM::Config->new;
  584.     $c->load($INST{$pkg}{pkg});
  585.     $c->save("$conf_dir/$pkg.pkg");
  586.  
  587.     # save the uninstall script:
  588.     if ($uninst && -f $uninst) {
  589.     my $saveto = "$conf_dir/$pkg.u";
  590.     use File::Copy qw(copy);
  591.     copy($uninst, $saveto);
  592.     }
  593.     return 1;
  594. }
  595.  
  596. sub add_dependent {
  597.     my $package = shift;
  598.     my $dependent = shift;
  599.     return 0 unless load_pkg($package);
  600.     push @{$INST{$package}{pkg}{dependents}}, $dependent;
  601.     save_pkg($package);
  602. }
  603.  
  604. sub del_dependent {
  605.     my $package = shift;
  606.     my $dependent = shift;
  607.     return 0 unless load_pkg($package);
  608.     @{$INST{$package}{pkg}{dependents}}
  609.       = grep { $_ ne $dependent }
  610.     @{$INST{$package}{pkg}{dependents}};
  611.     save_pkg($package);
  612. }
  613.  
  614. sub purge_pkg {
  615.     my $pkg = shift;
  616.  
  617.     # The PPD file:
  618.     my $ppdfile = "$conf_dir/$pkg.ppd";
  619.     if (-f $ppdfile) {
  620.     unlink $ppdfile        or die "$0: can't delete $ppdfile: $!";
  621.     }
  622.  
  623.     # The %INST entry:
  624.     delete $INST{$pkg};
  625.  
  626.     # The PKG file:
  627.     my $pkgfile = "$conf_dir/$pkg.pkg";
  628.     if (-f $pkgfile) {
  629.     unlink $pkgfile        or die "$0: can't delete $pkgfile: $!";
  630.     }
  631.  
  632.     # The uninstall file:
  633.     my $ufile = "$conf_dir/$pkg.u";
  634.     if (-f $ufile) {
  635.     unlink $ufile        or die "$0: can't delete $ufile: $!";
  636.     }
  637.  
  638.     return 1;
  639. }
  640.  
  641. sub pkg_uninstaller {
  642.     my $pkg = shift;
  643.     return "$conf_dir/$pkg.u";
  644. }
  645.  
  646. # Load all packages: only needed when doing an advanced query
  647. sub load_pkgs {
  648.     my @pkgs = map { s/\.ppd$//; s!.*/([^/]+)$!$1!g; $_ } #!
  649.       glob "$conf_dir/*.ppd"; 
  650.     load_pkg($_) for @pkgs;
  651. }
  652.  
  653. sub pkg_installed {
  654.     my $pkg = $_[0];
  655.     return unless -f "$conf_dir/$pkg.ppd" && -f "$conf_dir/$pkg.pkg";
  656.     if ($^O eq "MSWin32") {
  657.     # Make sure $pkg uses the same "spelling" as the file system
  658.     my $name = Win32::GetLongPathName("$conf_dir/$pkg.pkg");
  659.     $_[0] = substr((Win32::GetFullPathName($name))[1], 0, -4);
  660.     }
  661.     return 1;
  662. }
  663.  
  664. BEGIN {
  665.     load_conf();
  666. }
  667.  
  668. __END__
  669. :endofperl_ppminst
  670.