home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _7d95aa67cbac8bcbfc92f54c7d0b6dca < prev    next >
Encoding:
Text File  |  2004-04-13  |  23.1 KB  |  816 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. "C:\p4view\Apps\ActivePerl\MSI\data\ActivePerl\Perl\bin\perl.exe"  -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl_ppminst
  6. :WinNT
  7. "C:\p4view\Apps\ActivePerl\MSI\data\ActivePerl\Perl\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::Compat;
  55. use PPM::PPD;
  56. use PPM::Search;
  57. use Data::Dumper;
  58. require File::Spec;
  59.  
  60. # There's a bug in ExtUtils::Install in perl 5.6.1.
  61. # Also exists in ActivePerl 522 (line 168)
  62. BEGIN {
  63.     local $^W;
  64.     require ExtUtils::Install;
  65. }
  66.  
  67. # Query installed packages: returns a list of records about the results.
  68. sub query {
  69.     my $inst = shift;
  70.     my $query = shift;
  71.     my $case = shift;
  72.  
  73.     load_pkgs();
  74.     my @ppds = map { $_->{ppd} } values %INST;
  75.     my $compiled = PPM::PPD::Search->new($query, $case);
  76.     unless ($compiled->valid) {
  77.     $ERR = $compiled->error;
  78.     return 0;
  79.     }
  80.     $ERR = '';
  81.     my @matches = $compiled->search(@ppds);
  82.     return 1, map { $_->ppd } @matches;
  83. }
  84.  
  85. sub properties {
  86.     my $inst = shift;
  87.     my $pkg = shift;
  88.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  89.     return ($INST{$pkg}{ppd}->ppd,
  90.         $INST{$pkg}{pkg}{INSTDATE},
  91.         $INST{$pkg}{pkg}{LOCATION});
  92.     }
  93.     $ERR = "package '$pkg' is not installed.";
  94.     return ();
  95. }
  96.  
  97. sub dependents {
  98.     my $inst = shift;
  99.     my $pkg = shift;
  100.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  101.     return @{ $INST{$pkg}{pkg}{dependents} || [] };
  102.     }
  103.     undef;
  104. }
  105.  
  106. sub remove {
  107.     my ($inst, $pkg, $verbose) = @_;
  108.  
  109.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  110.  
  111.     # Is there an uninstall script?
  112.     my $u_script = eval {
  113.         $INST{$pkg}{ppd}->find_impl_raw($inst)->uninstall_script
  114.     };
  115.     if ($u_script) {
  116.         my %opts = (
  117.         PPM_INSTARCHLIB => $Config{installsitearch},
  118.         PPM_INSTPACKLIST => $INST{$pkg}{pkg}{INSTPACKLIST},
  119.         PPM_INSTROOT => $INST{$pkg}{pkg}{INSTROOT},
  120.         PPM_ACTION => 'uninstall',
  121.         );
  122.         $inst->run_script(pkg_uninstaller($pkg), $u_script, \%opts)
  123.           or return 0;
  124.     }
  125.  
  126.     my $packlist = $INST{$pkg}{pkg}{INSTPACKLIST};
  127.     (my $altpacklist = $packlist) =~ s<\Q$CONF{ARCHITECTURE}\E[\\/]><>i;
  128.     eval {
  129.         if (-f $packlist) {
  130.         ExtUtils::Install::uninstall($packlist, $verbose, 0);
  131.         }
  132.         elsif (-f $altpacklist) {
  133.         ExtUtils::Install::uninstall($altpacklist, $verbose, 0);
  134.         }
  135.     };
  136.     $ERR = "$@" and return 0 if $@;
  137.  
  138.     # Update html and table of contents, if ActivePerl::DocTools is installed:
  139.     if (eval { require ActivePerl::DocTools; 1 }) {
  140.         ActivePerl::DocTools::WriteTOC();
  141.     }
  142.  
  143.     # Remove the package and references to it:
  144.     my $ppd_ref = $INST{$pkg}{ppd};
  145.     my @prereqs;
  146.     eval { @prereqs = $ppd_ref->find_impl_raw($inst)->prereqs };
  147.     del_dependent($_->name, $ppd_ref->name) for @prereqs;
  148.     purge_pkg($pkg);
  149.     }
  150.     else {
  151.     $ERR = "package '$pkg' not installed.";
  152.     return 0;
  153.     }
  154.     return 1;
  155. }
  156.  
  157. sub precious {
  158.     return @{$CONF{precious}};
  159. }
  160.  
  161. sub bundled {
  162.     return @{$CONF{bundled}};
  163. }
  164.  
  165. sub upgrade {
  166.     my ($inst, $pkg, $ppmpath, $ppd, $repos, $verbose) = @_;
  167.     local %ENV = %ENV;
  168.     $ENV{PPM_ACTION} = 'upgrade';
  169.     $inst->install($pkg, $ppmpath, $ppd, $repos, $verbose);
  170. }
  171.  
  172. # This sub is called when the frontend has found an implementation suitable
  173. # for this target, and is double-checking whether we can actually install this
  174. # "content-type".
  175. sub can_install {
  176.     my ($inst, $lang, $version, $compat_type) = @_;
  177.     return 0 unless $lang eq $inst->config_get('LANGUAGE');
  178.     
  179.     # There are two distinct version number schemes for Perl: 5.00x_yy, and
  180.     # 5.x.y. At least, those are the ones I care about. To handle both, I'm
  181.     # going to detect the new format and demote it to the old format. Then I
  182.     # can compare using a regular numeric comparison. The reason I use the old
  183.     # one is so that the PPM3 backend will still work with pre-5.6.0 perls.
  184.     my @parts = split /\./, $version;
  185.     if (@parts > 2) {
  186.     $version = sprintf("%i.%.03i%.03i", @parts);
  187.     }
  188.     return $] >= $version;
  189. }
  190.  
  191. sub install {
  192.     my ($inst, $pkg, $ppmpath, $ppd, $repos, $verbose) = @_;
  193.     use Cwd qw(cwd);
  194.     my $cwd = cwd();
  195.     my $ppd_obj = PPM::PPD->new($ppd);
  196.  
  197.     # Install:
  198.     # 1. chdir to temp directory
  199.     chdir $ppmpath or do {
  200.     $ERR = "can't chdir to $ppmpath: $!";
  201.     return 0;
  202.     };
  203.     chdir $pkg; # this is expected to fail!
  204.  
  205.     use ActiveState::RelocateTree qw(relocate spongedir);
  206.     relocate (
  207.     to      => '.',
  208.     inplace => 1,
  209.     search  => spongedir('ppm'),
  210.     replace => $Config{prefix},
  211.     ) if $Config{osname} ne 'MSWin32';
  212.  
  213.     # 2. set up the install parameters:
  214.     my ($packlist, %opts, %inst_opts);
  215.     {
  216.     my $inst_archlib = $Config{installsitearch};
  217.     my $inst_root = $Config{prefix};
  218.     $packlist = File::Spec->catfile("$inst_archlib/auto",
  219.                 split(/-/, $pkg), ".packlist");
  220.     
  221.     # Copied from ExtUtils::Install
  222.     my $INST_LIB = File::Spec->catdir(File::Spec->curdir, "blib", "lib");
  223.     my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir, "blib", "arch");
  224.     my $INST_BIN = File::Spec->catdir(File::Spec->curdir, "blib", "bin");
  225.     my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir, "blib", "script");
  226.     my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir, "blib", "man1");
  227.     my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir, "blib", "man3");
  228.     my $INST_HTMLDIR = File::Spec->catdir(File::Spec->curdir, "blib", "html");
  229.     my $INST_HTMLHELPDIR = File::Spec->catdir(File::Spec->curdir, "blib", "htmlhelp");
  230.  
  231.     my $inst_script = $Config{installscript};
  232.     my $inst_man1dir = $Config{installman1dir};
  233.     my $inst_man3dir = $Config{installman3dir};
  234.     my $inst_bin = $Config{installbin};
  235.     my $inst_htmldir = $Config{installhtmldir};
  236.     my $inst_htmlhelpdir = $Config{installhtmlhelpdir};
  237.     my $inst_lib = $Config{installsitelib};
  238.     $inst_htmldir ||= "$inst_bin/../html";
  239.     $inst_htmlhelpdir ||= "$inst_bin/../html";
  240.  
  241.     # %inst_opts is used for ExtUtils::Install installs.
  242.     %opts = (
  243.         PPM_INSTARCHLIB => $inst_archlib,
  244.         PPM_INSTROOT => $inst_root,
  245.         PPM_INSTPACKLIST => $packlist,
  246.         PPM_ACTION => (
  247.         defined $ENV{PPM_ACTION} ? $ENV{PPM_ACTION} : 'install'
  248.         ),
  249.         PPM_NEW_VERSION => $ppd_obj->version,
  250.         (
  251.         pkg_installed($pkg) && load_pkg($pkg)
  252.         ? (PPM_PREV_VERSION => $INST{$pkg}{ppd}->version)
  253.         : ()
  254.         ),
  255.     );
  256.     %inst_opts = (
  257.         read => $packlist,
  258.         write => $packlist,
  259.         $INST_LIB => $inst_lib,
  260.         $INST_ARCHLIB => $inst_archlib,
  261.         $INST_BIN => $inst_bin,
  262.         $INST_SCRIPT => $inst_script,
  263.         $INST_MAN1DIR => $inst_man1dir,
  264.         $INST_MAN3DIR => $inst_man3dir,
  265.         $INST_HTMLDIR => $inst_htmldir,
  266.         $INST_HTMLHELPDIR => $inst_htmlhelpdir
  267.     );
  268.     if ($CONF{root} && $CONF{root} !~ /^\Q$inst_root\E$/i) {
  269.         my $root = $CONF{root};
  270.         $_ =~ s/\Q$inst_root/$root\E/i for values %inst_opts;
  271.         $_ =~ s/\Q$inst_root/$root\E/i for values %opts;
  272.         $inst_root = $root;
  273.     }
  274.     }
  275.  
  276.     # 3. Install the package.
  277.     #    This operates slightly differently than PPM2. First,
  278.     #    ExtUtils::Install is only called if q(blib) exists and is a
  279.     #    directory. Next, the install script is run. If it fails, then the
  280.     #    results of ExtUtils::Install are backed out.
  281.     my $inst_blib = -d "blib";
  282.     my $inst_script = eval { $ppd_obj->find_impl_raw($inst)->install_script };
  283.     if ($inst_blib) {
  284.     while (1) {
  285.         eval {
  286.         my $verbose = $verbose - 1; # $verbose < 0 implies silence.
  287.         ExtUtils::Install::install(
  288.             {%inst_opts},
  289.             $verbose,0,0
  290.         );
  291.         };
  292.         # install might have croaked in another directory
  293.         chdir $ppmpath;
  294.         # Can't remove some DLLs, but we can rename them and try again.
  295.         if ($@ && $@ =~ /Cannot forceunlink (\S+)/) {
  296.         my $oldname = $1;
  297.         $oldname =~ s/:$//;
  298.         my $newname = $oldname . "." . time();
  299.         unless (rename($oldname, $newname)) {
  300.             $ERR = "renaming $oldname to $newname: $!";
  301.             return 0;
  302.         }
  303.         }
  304.         # Some other error
  305.         elsif($@) {
  306.         $ERR = "$@";
  307.         return 0;
  308.         }
  309.         else { last; }
  310.     }
  311.     }
  312.     if ($inst_script) {
  313.     $inst->run_script("install_script", $inst_script, \%opts, $verbose)
  314.         or do {
  315.         # Back out ExtUtils::Install
  316.         if ($inst_blib) {
  317.         ExtUtils::Install::uninstall($packlist, $verbose, 0);
  318.         }
  319.         return 0;
  320.     };
  321.     }
  322.     chdir $cwd;
  323.  
  324.     # 4. update html table of contents, if ActivePerl::DocTools is installed:
  325.     if (eval { require ActivePerl::DocTools; 1 }) {
  326.     ActivePerl::DocTools::UpdateHTML()
  327.         if $inst->config_get('rebuildhtml');  # XXX this doesn't work
  328.     ActivePerl::DocTools::WriteTOC();
  329.     }
  330.  
  331.     # Add the package to the list of installed packages
  332.     $INST{$pkg} = {
  333.     pkg => {
  334.         INSTDATE => scalar localtime,
  335.         LOCATION => $repos,
  336.         INSTROOT => $opts{PPM_INSTROOT},
  337.         INSTPACKLIST => $packlist,
  338.            },
  339.     ppd => $ppd_obj,
  340.     };
  341.     save_pkg($pkg, "$ppmpath/uninstall_script");
  342.  
  343.     # "Register" the package as dependent on each prerequisite:
  344.     my @prereqs;
  345.     eval { @prereqs = $ppd_obj->find_impl_raw($inst)->prereqs };
  346.     add_dependent($_->name, $pkg) for @prereqs;
  347.  
  348.     return 1;
  349. }
  350.  
  351. sub config_keys {
  352.     map { [$_, $keys{$_}] } keys %keys;
  353. }
  354.  
  355. sub _str {
  356.     my $a = shift;
  357.     return '' unless defined $a;
  358.     $a;
  359. }
  360.  
  361. sub config_info {
  362.     map { [$_, _str($CONF{$_})] } keys %keys;
  363. }
  364.  
  365. sub config_set {
  366.     my $inst = shift;
  367.     my ($key, $val) = @_;
  368.     unless (defined $keys{$key}) {
  369.     $ERR = "unknown config key '$key'";
  370.     return 0;
  371.     }
  372.  
  373.     $CONF{$key} = $val;
  374.     save_conf();
  375.     return 1;
  376. }
  377.  
  378. sub config_get {
  379.     my $inst = shift;
  380.     my $key = shift;
  381.     unless (defined $key and exists $keys{$key}) {
  382.     $key = '' unless defined $key;
  383.     $ERR = "unknown config key '$key'";
  384.     return undef;
  385.     }
  386.     _str($CONF{$key});
  387. }
  388.  
  389. sub error_str {
  390.     defined $ERR ? $ERR : 'No error';
  391. }
  392.  
  393. #----------------------------------------------------------------------------
  394. # Utilities
  395. #----------------------------------------------------------------------------
  396.  
  397. # This can deal with files as well as directories
  398. sub abspath {
  399.     use Cwd qw(abs_path);
  400.     my ($path, $file) = shift;
  401.     if (-f $path) {
  402.         my @p = split '/', $path;
  403.         $path = join '/', @p[0..$#p-1]; # can't use -2 in a range
  404.         $file = $p[-1];
  405.     }
  406.     $path = abs_path($path || '.');
  407.     return ($path, $file, defined $file ? join '/', $path, $file : ())
  408.       if wantarray;
  409.     return defined $file ? join '/', $path, $file : $path;
  410. }
  411.  
  412. sub run_script {
  413.     my $o    = shift;
  414.     my $file    = shift;
  415.     my $inst    = shift;
  416.     my $setenv    = shift;
  417.     my $verbose    = shift;
  418.     my ($exec, $href, $content) = map { $inst->$_ } qw(exec href script);
  419.  
  420.     # Export %setenv to %ENV:
  421.     local %ENV = %ENV;
  422.     my %setenv = (
  423.     PPM_VERSION => $VERSION,
  424.     PPM_PERL => $Config{perlpath},
  425.     %$setenv,
  426.     );
  427.     $ENV{$_} = $setenv->{$_} for keys %setenv;
  428.  
  429.     # Evaluate special case of EXEC:
  430.     $exec =~ s/\bPPM_PERL\b/$Config{perlpath}/i;
  431.  
  432.     # Four cases:
  433.     # 1. !EXEC && !HREF: system($_) for split ';;';
  434.     # 2. !EXEC &&  HREF: system($_) for split '\n';
  435.     # 3.  EXEC && !HREF: split ';;' => $tmpfile; system($exec, $tmpfile);
  436.     # 4.  EXEC &&  HREF: system($exec, $file);
  437.  
  438.     if (not $exec and not $href) {
  439.     for (split ';;', $content) {
  440.         system($_) == 0 and next;
  441.         $ERR = "system() return non-zero value ($?): '$_'";
  442.         return 0;
  443.     }
  444.     }
  445.     elsif (not $exec) {    # and $href (of course)
  446.     local *INPUT;
  447.     open (INPUT, $file) or do {
  448.         $ERR = "can't open $file: $!";
  449.         return 0;
  450.     };
  451.     while (<INPUT>) {
  452.         system($_) == 0 and next;
  453.         $ERR = "system() returned non-zero value ($?): '$_'";
  454.         return 0;
  455.     }
  456.     }
  457.     elsif (not $href) { # and $exec (of course)
  458.     local *INPUT;
  459.     open (INPUT, "> $file") or die "can't write $file: $!";
  460.     print INPUT "$_\n" for (split ';;', $content);
  461.     close (INPUT) or die "can't close $file: $!";
  462.     system("$exec $file") == 0 or do {
  463.         $ERR = "system() returned non-zero value ($?): '$exec $file'";
  464.         return 0;
  465.     };
  466.     # only a convenience: this whole directory will be removed.
  467.     unlink $file;
  468.     }
  469.     else {
  470.     $exec =~ s/\bSELF\b/abspath($file)/ei and chmod(0777, $file);
  471.     -f $file or do {
  472.         $ERR = "can't run '$exec $file': $!";
  473.         return 0;
  474.     };
  475.     system("$exec $file") == 0 or do {
  476.         $ERR = "(un)install script failed: '$exec $file'";
  477.         return 0;
  478.     };
  479.     }
  480.     $ERR = "";
  481.     return 1;
  482. }
  483.  
  484. sub abs_packlist {
  485.     my $pl = shift;
  486.     $pl =~ s[\%SITELIB\%][$Config{sitelib}]g;
  487.     unless (-f $pl) {
  488.     my $i = $^O eq 'MSWin32' ? '(?i)' : '';
  489.     $pl =~ s[$i^\Q$Config{sitelib}\E][$Config{sitearch}];
  490.     return undef unless -f $pl;
  491.     }
  492.     return $pl;
  493. }
  494.  
  495. #============================================================================
  496. # Settings and packages
  497. #============================================================================
  498. my ($conf_dir, $conf, $conf_obj);
  499. BEGIN {
  500.     # By putting an invalid package character in the directory, we're making
  501.     # sure no real package could overwrite our settings, and vice versa.
  502.     $conf_dir = PPM::Config::tree_conf_dir();
  503.     $conf = join '/', $conf_dir, 'ppm.cfg';
  504. }
  505.  
  506. # Loads the configuration file and populates %CONF
  507. sub load_conf {
  508.     $conf_obj = PPM::Config->new->loadfile($conf);
  509.     %CONF = $conf_obj->config;
  510.  
  511.     # Special values; set them here
  512.     $CONF{ARCHITECTURE} = $Config{archname};
  513.     # Append "-5.8" to architecture name for Perl 5.8 and later
  514.     if (length($^V) && ord(substr($^V,1)) >= 8) {
  515.         $CONF{ARCHITECTURE} .= sprintf("-%d.%d", ord($^V), ord(substr($^V,1)));
  516.     }
  517.     $CONF{PERLCORE} = $Config{version};
  518.     $CONF{TARGET_TYPE} = "perl";
  519.     $CONF{LANGUAGE} = "Perl";
  520.     $CONF{VERSION} = $VERSION;
  521.     $CONF{OSVALUE} = $^O;
  522.     $CONF{OSVERSION} = join(
  523.     ',',
  524.     (((split '\.', $Config{osvers}), (0) x 4)[0..3])
  525.     );
  526. }
  527.  
  528. # Saves %CONF to the configuration file
  529. sub save_conf {
  530.     $conf_obj->merge(\%CONF);
  531.     # Make the file writeable if it isn't already:
  532.     chmod 0666, $conf;
  533.     $conf_obj->save($conf);
  534. }
  535.  
  536. # Loads the given package into $INST{$pkg}. Returns true if the package could
  537. # be loaded, false otherwise.
  538. sub load_pkg {
  539.     my $pkg = shift;
  540.  
  541.     return 1 if exists $INST{$pkg};
  542.  
  543.     return 0 unless -f "$conf_dir/$pkg.ppd";
  544.     return 0 unless -f "$conf_dir/$pkg.pkg";
  545.  
  546.     my $ppdref = PPM::PPD->new("$conf_dir/$pkg.ppd");
  547.     my $pkgfile = "$conf_dir/$pkg.pkg";
  548.     my $pkgref = PPM::Config->new->loadfile($pkgfile);
  549.  
  550.     $INST{$pkg}{ppd} = $ppdref;
  551.     $INST{$pkg}{pkg} = $pkgref->config;
  552.  
  553.     # Substitute the %SITELIB% variable properly.
  554.     $INST{$pkg}{pkg}{INSTPACKLIST} =
  555.     abs_packlist($INST{$pkg}{pkg}{INSTPACKLIST});
  556.     defined $INST{$pkg}{pkg}{INSTPACKLIST}
  557.     or do { purge_pkg($pkg); return 0 };
  558.  
  559.     return 1;
  560. }
  561.  
  562. # Saves the given package from $INST{$pkg}.
  563. sub save_pkg {
  564.     my $pkg = shift;
  565.     my $uninst = shift;
  566.     return 0 unless exists $INST{$pkg};
  567.  
  568.     # the PPD file:
  569.     my $ppdfile = "$conf_dir/$pkg.ppd";
  570.     if (-f $ppdfile) {
  571.     unlink $ppdfile        or die "$0: can't delete $ppdfile: $!";
  572.     }
  573.     open PPD, "> $ppdfile"    or die "$0: can't write $ppdfile: $!";
  574.     print PPD $INST{$pkg}{ppd}->ppd;
  575.     close PPD            or die "$0: can't close $ppdfile: $!";
  576.  
  577.     # the PKG file:
  578.     my $c = PPM::Config->new;
  579.     $c->load($INST{$pkg}{pkg});
  580.     $c->save("$conf_dir/$pkg.pkg");
  581.  
  582.     # save the uninstall script:
  583.     if ($uninst && -f $uninst) {
  584.     my $saveto = "$conf_dir/$pkg.u";
  585.     use File::Copy qw(copy);
  586.     copy($uninst, $saveto);
  587.     }
  588.     return 1;
  589. }
  590.  
  591. sub add_dependent {
  592.     my $package = shift;
  593.     my $dependent = shift;
  594.     return 0 unless load_pkg($package);
  595.     push @{$INST{$package}{pkg}{dependents}}, $dependent;
  596.     save_pkg($package);
  597. }
  598.  
  599. sub del_dependent {
  600.     my $package = shift;
  601.     my $dependent = shift;
  602.     return 0 unless load_pkg($package);
  603.     @{$INST{$package}{pkg}{dependents}}
  604.       = grep { $_ ne $dependent }
  605.     @{$INST{$package}{pkg}{dependents}};
  606.     save_pkg($package);
  607. }
  608.  
  609. sub purge_pkg {
  610.     my $pkg = shift;
  611.  
  612.     # The PPD file:
  613.     my $ppdfile = "$conf_dir/$pkg.ppd";
  614.     if (-f $ppdfile) {
  615.     unlink $ppdfile        or die "$0: can't delete $ppdfile: $!";
  616.     }
  617.  
  618.     # The %INST entry:
  619.     delete $INST{$pkg};
  620.  
  621.     # The PKG file:
  622.     my $pkgfile = "$conf_dir/$pkg.pkg";
  623.     if (-f $pkgfile) {
  624.     unlink $pkgfile        or die "$0: can't delete $pkgfile: $!";
  625.     }
  626.  
  627.     # The uninstall file:
  628.     my $ufile = "$conf_dir/$pkg.u";
  629.     if (-f $ufile) {
  630.     unlink $ufile        or die "$0: can't delete $ufile: $!";
  631.     }
  632.  
  633.     return 1;
  634. }
  635.  
  636. sub pkg_uninstaller {
  637.     my $pkg = shift;
  638.     return "$conf_dir/$pkg.u";
  639. }
  640.  
  641. # Load all packages: only needed when doing an advanced query
  642. sub load_pkgs {
  643.     my @pkgs = map { s/\.ppd$//; s!.*/([^/]+)$!$1!g; $_ } #!
  644.       glob "$conf_dir/*.ppd"; 
  645.     load_pkg($_) for @pkgs;
  646. }
  647.  
  648. sub pkg_installed {
  649.     my $pkg = $_[0];
  650.     return unless -f "$conf_dir/$pkg.ppd" && -f "$conf_dir/$pkg.pkg";
  651.     if ($^O eq "MSWin32") {
  652.     # Make sure $pkg uses the same "spelling" as the file system
  653.     my $name = Win32::GetLongPathName("$conf_dir/$pkg.pkg");
  654.     $_[0] = substr((Win32::GetFullPathName($name))[1], 0, -4);
  655.     }
  656.     return 1;
  657. }
  658.  
  659. # PPM2 compatibility: load the ppm.xml file and synchronize PPM3 with it. If
  660. # the person has loaded things with PPM2 since the last "sync", they will be
  661. # sucked in.
  662. sub import_ppm2 {
  663.     my $ppm_xml = "$Config{installsitelib}/ppm.xml";
  664.     return () unless -f $ppm_xml;
  665.     my ($conf, $reps, $inst, $cmd, $extra) = ({}, {}, {}, {}, {});
  666.     eval {
  667.     PPM::Compat::read_ppm_xml($ppm_xml, $conf, $reps, $inst, $cmd, $extra);
  668.     };
  669.     return () if $@;
  670.     for my $ppm2_pkg (keys %$inst) {
  671.     next unless ref $inst->{$ppm2_pkg} eq 'HASH';
  672.     my $pkg_file = "$conf_dir/$ppm2_pkg.pkg";
  673.     my $ppd_file = "$conf_dir/$ppm2_pkg.ppd";
  674.     next if -f $pkg_file and -f $ppd_file;
  675.  
  676.     # At this point, we have _either_ a package installed with PPM2, or a
  677.     # package deleted with PPM3. Check whether the .packlist file is
  678.     # installed to be sure.
  679.     next unless abs_packlist($inst->{$ppm2_pkg}{INSTPACKLIST});
  680.  
  681.     local (*PKG, *PPD);
  682.     open (PKG, "> $pkg_file")
  683.         or do { $ERR = "can't write to $pkg_file: $!"; next };
  684.     print PKG "$_: $inst->{$ppm2_pkg}{$_}\n" for qw(
  685.         INSTDATE
  686.         INSTPACKLIST
  687.         INSTROOT
  688.         LOCATION
  689.     );
  690.     close PKG;
  691.     open PPD, "> $ppd_file"
  692.         or do { $ERR = "can't write to $ppd_file: $!"; next };
  693.     print PPD $inst->{$ppm2_pkg}{ppd};
  694.     close PPD;
  695.     }
  696.     ($conf, $reps, $inst, $cmd, $extra);
  697. }
  698.  
  699. # PPM2 compatibility: export the ppm.xml file based on the PPM3 information.
  700. # To ensure that we don't forget about changes to ppm.xml which happened
  701. # during the lifetime of this ppm3, we force a reload of ppm2 (just in case).
  702. sub save_ppm2 {
  703.     my ($conf, $reps, $inst, $cmd, $extra) = import_ppm2();
  704.     load_pkgs();
  705.  
  706.     # If the file wasn't found, write out some default values:
  707.     $conf = {
  708.     tempdir => $ENV{TEMP} || $ENV{TMP} || ($^O eq 'MSWin32' ? 'C:\Temp' : '/tmp'),
  709.     downloadbytes => 16384,
  710.     } unless defined $conf;
  711.     $extra = {
  712.     CLEAN => 1,
  713.     CONFIRM => 1,
  714.     FORCEINSTALL => 0,
  715.     MORE => 24,
  716.     TRACE => 0,
  717.     TRACEFILE => 'PPM.LOG',
  718.     VERBOSE => 1,
  719.     } unless defined $extra;
  720.     $inst = {
  721.     root => config_get(undef, 'root'),
  722.     precious => [precious()],
  723.     } unless defined $inst;
  724.     $reps = {
  725.     'ActiveState Package Repository' => {
  726.         url => PPM::Compat::repository('ppm2'),
  727.     },
  728.     } unless defined $reps;
  729.  
  730.     # Can't rely on XML::Simple being installed, so I'll just print out the
  731.     # ppm.xml file by hand (ugh).
  732.     my $ppm_xml = "$Config{installsitelib}/ppm.xml";
  733.     local *PPMXML;
  734.     open PPMXML, "> $ppm_xml"
  735.     or do { $ERR = "can't write $ppm_xml: $!"; return 0 };
  736.     my $OSVALUE = config_get(undef, "OSVALUE");
  737.     my $OSVERSION = config_get(undef, "OSVERSION");
  738.     my @opts;
  739.     my @REPS;
  740.     {
  741.     local $^W; # no uninitialized warnings, please
  742.     push @opts, qq{BUILDDIR="$conf->{tempdir}"};
  743.     push @opts, qq{REBUILDHTML="$conf->{rebuildhtml}"};
  744.     push @opts, qq{CLEAN="$extra->{CLEAN}"};
  745.     push @opts, qq{CONFIRM="$extra->{CONFIRM}"};
  746.     push @opts, qq{DOWNLOADSTATUS="$conf->{downloadbytes}"};
  747.     push @opts, qq{FORCEINSTALL="$extra->{FORCEINSTALL}"};
  748.     push @opts, qq{IGNORECASE="$cmd->{'case-sensitivity'}"};
  749.     push @opts, qq{MORE="$extra->{MORE}"};
  750.     push @opts, qq{ROOT="$inst->{root}"};
  751.     push @opts, qq{TRACE="$extra->{TRACE}"};
  752.     push @opts, qq{TRACEFILE="$extra->{TRACEFILE}"};
  753.     push @opts, qq{VERBOSE="$extra->{VERBOSE}"};
  754.  
  755.     for my $rep (keys %$reps) {
  756.         my ($smry, $loc);
  757.         if ($reps->{$rep}{url} eq PPM::Compat::repository('ppm3')) {
  758.         $reps->{$rep}{url} = PPM::Compat::repository('ppm2');
  759.         }
  760.         $loc = $reps->{$rep}{url};
  761.         # if it is a ppm2 style repository, it supports "fetch_summary"
  762.         $smry = $loc =~ m[\?urn:/PPMServer\z] ? "fetch_summary" : "";
  763.         my @extra;
  764.         defined $reps->{$rep}{username}
  765.         and push @extra, qq{USERNAME="$reps->{$rep}{username}"};
  766.         defined $reps->{$rep}{password}
  767.         and push @extra, qq{PASSWORD="$reps->{$rep}{password}"};
  768.         push @REPS, <<REP;
  769.     <REPOSITORY LOCATION="$loc" NAME="$rep" SUMMARYFILE="$smry" @extra />
  770. REP
  771.     }
  772.     }
  773.     my $ppmprecious = join ';', @{$inst->{precious} || []};
  774.     print PPMXML <<HEADER;
  775. <PPMCONFIG>
  776.     <PPMVER>2,2,0,0</PPMVER>
  777.     <PLATFORM CPU="x86" OSVALUE="$OSVALUE" OSVERSION="$OSVERSION" />
  778.     <OPTIONS @opts />
  779. @REPS
  780.     <PPMPRECIOUS>$ppmprecious</PPMPRECIOUS>
  781. HEADER
  782.  
  783.     # Print out the <PACKAGE>s
  784.     for my $pkg (sort keys %INST) {
  785.     next if $pkg eq 'PPM-Agent-Perl';
  786.     next if $pkg eq 'PPM-Shell';
  787.     my $p = $INST{$pkg}{pkg};
  788.     (my $ppd = $INST{$pkg}{ppd}->ppd) =~ s#^<\?xml.*?\?>##;
  789.     print PPMXML <<INSTPKG;
  790.     <PACKAGE NAME="$pkg">
  791.     <LOCATION>$p->{LOCATION}</LOCATION>
  792.     <INSTPACKLIST>$p->{INSTPACKLIST}</INSTPACKLIST>
  793.     <INSTROOT>$p->{INSTROOT}</INSTROOT>
  794.     <INSTDATE>$p->{INSTDATE}</INSTDATE>
  795.     <INSTPPD>
  796. $ppd
  797.     </INSTPPD>
  798.     </PACKAGE>
  799. INSTPKG
  800.     }
  801.     print PPMXML <<FOOTER;
  802. </PPMCONFIG>
  803. FOOTER
  804. }
  805.  
  806. BEGIN {
  807.     import_ppm2();
  808.     load_conf();
  809. }
  810. END {
  811.     save_ppm2();
  812. }
  813.  
  814. __END__
  815. :endofperl_ppminst
  816.