home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / site / lib / PPM.pm < prev    next >
Encoding:
Perl POD Document  |  2002-11-29  |  76.8 KB  |  2,133 lines
  1. package PPM;
  2. require 5.004;
  3. require Exporter;
  4.  
  5. @ISA = qw(Exporter);
  6. @EXPORT = qw(PPMdat PPMERR InstalledPackageProperties ListOfRepositories
  7.     RemoveRepository AddRepository GetPPMOptions SetPPMOptions InstallPackage
  8.     RemovePackage VerifyPackage UpgradePackage RepositoryPackages
  9.     RepositoryPackageProperties QueryInstalledPackages
  10.     RepositorySummary ServerSearch PPMShell);
  11.  
  12. use LWP::UserAgent;
  13. use LWP::Simple;
  14.  
  15. use File::Basename;
  16. use File::Copy;
  17. use File::Path;
  18. use File::Spec;
  19. use ExtUtils::Install;
  20. use Cwd;
  21. use Config;
  22. use PPM::RelocPerl;
  23. use SOAP::Lite;
  24.  
  25. use PPM::XML::PPD;
  26. use PPM::XML::PPMConfig;
  27. use XML::Parser;
  28. use Archive::Tar;
  29.  
  30. use strict;
  31.  
  32. my $useDocTools;  # Generate HTML documentation after installing a package
  33.  
  34. BEGIN {
  35.     if (eval "require ActivePerl::DocTools") {
  36.         import ActivePerl::DocTools;
  37.         $useDocTools++;
  38.     }
  39. }
  40.  
  41. #set Debug to 1 to debug PPMdat file reading
  42. #             2 to debug parsing PPDs
  43. #
  44. # values may be or'ed together.
  45. #
  46. my $Debug = 0;
  47.  
  48. my ($PPMERR, $PPM_ver, $CPU, $OS_VALUE, $OS_VERSION, $LANGUAGE);
  49.  
  50. # options from data file.
  51. my %options;
  52.  
  53. my $TraceStarted = 0;
  54.  
  55. # true if we're running from ppm, as opposed to VPM, etc.
  56. my $PPMShell;
  57.  
  58. my %repositories;
  59. my %cached_ppd_list;
  60.  
  61. # Keys for this hash are package names.  It is filled in by a successful
  62. # call to read_config().  Each package is a hash with the following keys:
  63. # LOCATION, INST_DATE, INST_ROOT, INST_PACKLIST and INST_PPD.
  64. my %installed_packages = ();
  65.  
  66. # Keys for this hash are CODEBASE, INSTALL_HREF, INSTALL_EXEC,
  67. # INSTALL_SCRIPT, NAME, VERSION, TITLE, ABSTRACT, LICENSE, AUTHOR,
  68. # UNINSTALL_HREF, UNINSTALL_EXEC, UNINSTALL_SCRIPT, PERLCORE_VER and DEPEND.
  69. # It is filled in after a successful call to parsePPD().
  70. my %current_package = ();
  71. my @current_package_stack;
  72.  
  73. # this may get overridden by the config file.
  74. my @required_packages = qw(PPM SOAP-Lite libnet Archive-Tar Compress-Zlib
  75.     libwww-perl XML-Parser);
  76.  
  77. # Packages that can't be upgraded on Win9x
  78. my @Win9x_denied = qw(xml-parser compress-zlib);
  79. my %Win9x_denied;
  80. @Win9x_denied{@Win9x_denied} = ();
  81.  
  82. # ppm.xml location is in the environment variable 'PPM_DAT', else it is in
  83. # [Perl]/site/lib, else it is in the same place as this script.
  84. my ($basename, $path) = fileparse($0);
  85.  
  86. if (defined $ENV{'PPM_DAT'} && -f $ENV{'PPM_DAT'})
  87. {
  88.     $PPM::PPMdat = $ENV{'PPM_DAT'};
  89. }
  90. elsif (-f "$Config{'installsitelib'}/ppm.xml")
  91. {
  92.     $PPM::PPMdat = "$Config{'installsitelib'}/ppm.xml";
  93. }
  94. elsif (-f "$Config{'installprivlib'}/ppm.xml")
  95. {
  96.     $PPM::PPMdat = "$Config{'installprivlib'}/ppm.xml";
  97. }
  98. elsif (-f $path . "/ppm.xml")
  99. {
  100.     $PPM::PPMdat = $path . $PPM::PPMdat;
  101. }
  102. else
  103. {
  104.     &Trace("Failed to load PPM_DAT file") if $options{'TRACE'};
  105.     print "Failed to load PPM_DAT file\n";
  106.     return -1;
  107. }
  108.  
  109. &Trace("Using config file: $PPM::PPMdat") if $options{'TRACE'};
  110.  
  111. my $init = 0;
  112. chmod(0644, $PPM::PPMdat);
  113.  
  114. my $varchname = $Config{archname};
  115. # Append "-5.8" to architecture name for Perl 5.8 and later
  116. if (length($^V) && ord(substr($^V,1)) >= 8) {
  117.     $varchname .= sprintf("-%d.%d", ord($^V), ord(substr($^V,1)));
  118. }
  119.  
  120. #
  121. # Exported subs
  122. #
  123.  
  124. sub InstalledPackageProperties
  125. {
  126.     my %ret_hash;
  127.     read_config();
  128.     foreach (keys %installed_packages) {
  129.         parsePPD(%{ $installed_packages{$_}{'INST_PPD'} } );
  130.         $ret_hash{$_}{'NAME'} = $_;
  131.         $ret_hash{$_}{'DATE'} = $installed_packages{$_}{'INST_DATE'};
  132.         $ret_hash{$_}{'TITLE'} = $current_package{'TITLE'};
  133.         $ret_hash{$_}{'AUTHOR'} = $current_package{'AUTHOR'};
  134.         $ret_hash{$_}{'VERSION'} = $current_package{'VERSION'};
  135.         $ret_hash{$_}{'ABSTRACT'} = $current_package{'ABSTRACT'};
  136.         $ret_hash{$_}{'PERLCORE_VER'} = $current_package{'PERLCORE_VER'};
  137.         foreach my $dep (keys %{$current_package{'DEPEND'}}) {
  138.             push @{$ret_hash{$_}{'DEPEND'}}, $dep;
  139.         }
  140.     }
  141.     return %ret_hash;
  142. }
  143.  
  144. sub ListOfRepositories
  145. {
  146.     my %reps;
  147.     read_config();
  148.     foreach (keys %repositories) {
  149.         $reps{$_} = $repositories{$_}{'LOCATION'};
  150.     }
  151.     return %reps;
  152. }
  153.  
  154. sub RemoveRepository
  155. {
  156.     my %argv = @_;
  157.     my $repository = $argv{'repository'};
  158.     my $save = $argv{'save'};
  159.     read_config();
  160.     foreach (keys %repositories) {
  161.         if ($_ =~ /^\Q$repository\E$/) {
  162.             &Trace("Removed repository $repositories{$repository}") 
  163.                 if $options{'TRACE'};
  164.             delete $repositories{$repository};
  165.             last;
  166.         }
  167.     }
  168.     save_options() if $save;
  169. }
  170.  
  171. sub AddRepository
  172. {
  173.     my %argv = @_;
  174.     my $repository = $argv{'repository'};
  175.     my $save = $argv{'save'};
  176.     my $location = $argv{'location'};
  177.     my $username = $argv{'username'};
  178.     my $password = $argv{'password'};
  179.     read_config();
  180.     $repositories{$repository}{'LOCATION'} = $location;
  181.     $repositories{$repository}{'USERNAME'} = $username if defined $username;
  182.     $repositories{$repository}{'PASSWORD'} = $password if defined $password;
  183.     &Trace("Added repository $location") if $options{'TRACE'};
  184.     save_options() if $save;
  185. }
  186.  
  187. sub GetPPMOptions
  188. {
  189.     read_config();
  190.     return %options;
  191. }
  192.  
  193. sub SetPPMOptions
  194. {
  195.     my %argv = @_;
  196.     %options = %{$argv{'options'}};
  197.     save_options() if $argv{'save'};
  198. }
  199.  
  200. sub UpgradePackage
  201. {
  202.     my %argv = @_;
  203.     my $package = $argv{'package'};
  204.     my $location = $argv{'location'};
  205.     return VerifyPackage("package" => $package, "location" => $location,
  206.         "upgrade" => 1);
  207. }
  208.  
  209. # Returns 1 on success, 0 and sets $PPMERR on failure.
  210. sub InstallPackage
  211. {
  212.     my %argv = @_;
  213.     my $package = $argv{'package'};
  214.     my $location = $argv{'location'};
  215.     my $root = $argv{'root'} || $options{'ROOT'} || undef;
  216.     my ($PPDfile, %PPD);
  217.  
  218.     read_config();
  219.  
  220.     if (!defined($package) && -d "blib" && -f "Makefile") {
  221.         unless (open MAKEFILE, "< Makefile") {
  222.             $PPM::PPMERR = "Couldn't open Makefile for reading: $!";
  223.             return 0;
  224.         }
  225.         while (<MAKEFILE>) {
  226.             if (/^DISTNAME\s*=\s*(\S+)/) {
  227.                 $package = $1;
  228.                 $PPDfile = "$1.ppd";
  229.                 last;
  230.             }
  231.         }
  232.         close MAKEFILE;
  233.         unless (defined $PPDfile) {
  234.             $PPM::PPMERR = "Couldn't determine local package name";
  235.             return 0;
  236.         }
  237.         system("$Config{make} ppd");
  238.     # XXX should set $PPM::PPMERR?
  239.         return 0 unless (%PPD = getPPDfile('package' => $PPDfile));
  240.         parsePPD(%PPD);
  241.         $options{'CLEAN'} = 0;
  242.         goto InstallBlib;
  243.     }
  244.  
  245.     unless (%PPD = getPPDfile('package' => $package, 
  246.             'location' => $location, 'PPDfile' => \$PPDfile)) {
  247.         &Trace("Could not locate a PPD file for package $package")
  248.             if $options{'TRACE'};
  249.         $PPM::PPMERR = "Could not locate a PPD file for package $package";
  250.         return 0;
  251.     }
  252.     if ($Config{'osname'} eq 'MSWin32' &&
  253.         !&Win32::IsWinNT && exists $Win9x_denied{lc($package)}) {
  254.         $PPM::PPMERR = "Package '$package' cannot be installed with PPM on Win9x--see http://www.ActiveState.com/ppm for details";
  255.         return 0;
  256.     }
  257.  
  258.     parsePPD(%PPD);
  259.     if (!$current_package{'CODEBASE'} && !$current_package{'INSTALL_HREF'}) {
  260.         &Trace("Read a PPD for '$package', but it is not intended for this build of Perl ($varchname)")
  261.             if $options{'TRACE'};
  262.         $PPM::PPMERR = "Read a PPD for '$package', but it is not intended for this build of Perl ($varchname)";
  263.         return 0;
  264.     }
  265.  
  266.     if (defined $current_package{'DEPEND'}) {
  267.         push(@current_package_stack, [%current_package]);
  268.         foreach my $dep (keys %{$current_package{'DEPEND'}}) {
  269.             # Has PPM already installed it?
  270.             unless ($installed_packages{$dep}) {
  271.                 # Has *anybody* installed it, or is it part of core Perl?
  272.                 my $p = $dep;
  273.                 $p =~ s@-@/@g;
  274.                 my $found = grep -f, map "$_/$p.pm", @INC;
  275.                 unless ($found) {
  276.                     &Trace("Installing dependency '$dep'...")
  277.                         if $options{'TRACE'};
  278.                     unless (!InstallPackage("package" => $dep,
  279.                         "location" => $location)) {
  280.                             &Trace("Error installing dependency: $PPM::PPMERR")
  281.                                 if $options{'TRACE'};
  282.                             $PPM::PPMERR = "Error installing dependency: $PPM::PPMERR\n";
  283.                         return 0 unless ($options{'FORCE_INSTALL'});
  284.                     }
  285.                 }
  286.             }
  287.             # make sure minimum version is installed, if necessary
  288.             elsif (defined $current_package{'DEPEND'}{$dep}) {
  289.                 my @comp = split (',', $current_package{'DEPEND'}{$dep});
  290.                 # parsePPD fills in %current_package
  291.                 push(@current_package_stack, [%current_package]);
  292.                 parsePPD(%{$installed_packages{$dep}{'INST_PPD'}});
  293.                 my @inst = split (',', $current_package{'VERSION'});
  294.                 foreach(0..3) {
  295.                     if ($comp[$_] > $inst[$_]) {
  296.                         VerifyPackage("package" => $dep, "upgrade" => 1);
  297.                         last;
  298.                     }
  299.                     last if ($comp[$_] < $inst[$_]);
  300.                 }
  301.                 %current_package = @{pop @current_package_stack};
  302.             }
  303.         }
  304.         %current_package = @{pop @current_package_stack};
  305.     }
  306.     my ($basename, $path) = fileparse($PPDfile);
  307.     # strip the trailing path separator
  308.     my $chr = substr($path, -1, 1);
  309.     chop $path if ($chr eq '/' || $chr eq '\\');
  310.     if ($path =~ /^file:\/\/.*\|/i) {
  311.         # $path is a local directory, let's avoid LWP by changing
  312.         # it to a pathname.
  313.         $path =~ s@^file://@@i;
  314.         $path =~ s@^localhost/@@i;
  315.         $path =~ s@\|@:@;
  316.     }
  317.  
  318.     # get the code and put it in build_dir
  319.     my $install_dir = "$options{'BUILDDIR'}/$current_package{'NAME'}-$$";
  320.     File::Path::rmtree($install_dir,0,0);
  321.     unless (-d $install_dir || File::Path::mkpath($install_dir, 0, 0755)) {
  322.         &Trace("Could not create $install_dir: $!") if $options{'TRACE'};
  323.         $PPM::PPMERR = "Could not create $install_dir: $!";
  324.         return 0;
  325.     }
  326.     $basename = fileparse($current_package{'CODEBASE'});
  327.     # CODEBASE is a URL
  328.     if ($current_package{'CODEBASE'} =~ m@^...*://@i) {
  329.         return 0 unless read_href('href' => "$current_package{'CODEBASE'}",
  330.             'target' => "$install_dir/$basename", 'request' => "GET",
  331.             'progress' => 1);
  332.     }
  333.     # CODEBASE is a full pathname
  334.     elsif (-f $current_package{'CODEBASE'}) {
  335.         &Trace("Copying $current_package{'CODEBASE'} to $install_dir/$basename")
  336.             if $options{'TRACE'} > 1;
  337.         copy($current_package{'CODEBASE'}, "$install_dir/$basename");
  338.     }
  339.     # CODEBASE is relative to the directory location of the PPD
  340.     elsif (-f "$path/$current_package{'CODEBASE'}") {
  341.         &Trace("Copying $path/$current_package{'CODEBASE'} to $install_dir/$basename") if $options{'TRACE'} > 1;
  342.         copy("$path/$current_package{'CODEBASE'}", "$install_dir/$basename");
  343.     }
  344.     # CODEBASE is relative to the URL location of the PPD
  345.     else {
  346.         return 0 unless read_href('target' => "$install_dir/$basename",
  347.             'href' => "$path/$current_package{'CODEBASE'}",
  348.             'request' => 'GET', 'progress' => 1);
  349.     }
  350.  
  351.     my $cwd = getcwd();
  352.     $cwd .= "/" if $cwd =~ /[a-z]:$/i;
  353.     chdir($install_dir);
  354.  
  355.     my $tar;
  356.     if ($basename =~ /\.gz$/i) {
  357.         $tar = Archive::Tar->new($basename,1);
  358.     }
  359.     else {
  360.         $tar = Archive::Tar->new($basename,0);
  361.     }
  362.     $tar->extract($tar->list_files);
  363.     die "Failed to expand tarball: $Archive::Tar::error"
  364.     if $Archive::Tar::error;
  365.     $basename =~ /(.*).tar/i and chdir($1);
  366.     RelocPerl('.') if ($Config{'osname'} ne 'MSWin32');
  367.  
  368.   InstallBlib:
  369.     my $inst_archlib = $Config{installsitearch};
  370.     my $inst_root = $Config{prefix};
  371.     my $packlist = File::Spec->catfile("$Config{installsitearch}/auto",
  372.         split(/-/, $current_package{'NAME'}), ".packlist");
  373.  
  374.     # copied from ExtUtils::Install
  375.     my $INST_LIB = File::Spec->catdir(File::Spec->curdir,"blib","lib");
  376.     my $INST_ARCHLIB = File::Spec->catdir(File::Spec->curdir,"blib","arch");
  377.     my $INST_BIN = File::Spec->catdir(File::Spec->curdir,'blib','bin');
  378.     my $INST_SCRIPT = File::Spec->catdir(File::Spec->curdir,'blib','script');
  379.     my $INST_MAN1DIR = File::Spec->catdir(File::Spec->curdir,'blib','man1');
  380.     my $INST_MAN3DIR = File::Spec->catdir(File::Spec->curdir,'blib','man3');
  381.     my $INST_HTMLDIR = File::Spec->catdir(File::Spec->curdir,'blib','html');
  382.     my $INST_HTMLHELPDIR = File::Spec->catdir(File::Spec->curdir,'blib','htmlhelp');
  383.  
  384.     my $inst_script = $Config{installscript};
  385.     my $inst_man1dir = $Config{installman1dir};
  386.     my $inst_man3dir = $Config{installman3dir};
  387.     my $inst_bin = $Config{installbin};
  388.     my $inst_htmldir = $Config{installhtmldir};
  389.     my $inst_htmlhelpdir = $Config{installhtmlhelpdir};
  390.     my $inst_lib = $Config{installsitelib};
  391.  
  392.     if (defined $root && $root !~ /^\Q$inst_root\E$/i) {
  393.         $packlist =~ s/\Q$inst_root/$root\E/i;
  394.         $inst_lib =~ s/\Q$inst_root/$root\E/i;
  395.         $inst_archlib =~ s/\Q$inst_root/$root\E/i;
  396.         $inst_bin =~ s/\Q$inst_root/$root\E/i;
  397.         $inst_script =~ s/\Q$inst_root/$root\E/i;
  398.         $inst_man1dir =~ s/\Q$inst_root/$root\E/i;
  399.         $inst_man3dir =~ s/\Q$inst_root/$root\E/i;
  400.         $inst_root = $root;
  401.     }
  402.     
  403.     while (1) {
  404.         my $cwd = getcwd();
  405.         $cwd .= "/" if $cwd =~ /[a-z]:$/i;
  406.         &Trace("Calling ExtUtils::Install::install") if $options{'TRACE'} > 1;
  407.         eval {
  408.             ExtUtils::Install::install({
  409.             "read" => $packlist, "write" => $packlist,
  410.             $INST_LIB => $inst_lib, $INST_ARCHLIB => $inst_archlib,
  411.             $INST_BIN => $inst_bin, $INST_SCRIPT => $inst_script,
  412.             $INST_MAN1DIR => $inst_man1dir, $INST_MAN3DIR => $inst_man3dir,
  413.             $INST_HTMLDIR => $inst_htmldir,
  414.             $INST_HTMLHELPDIR => $inst_htmlhelpdir},0,0,0);
  415.         };
  416.         # install might have croaked in another directory
  417.         chdir($cwd);
  418.         # Can't remove some DLLs, but we can rename them and try again.
  419.         if ($@ && $@ =~ /Cannot forceunlink (\S+)/) {
  420.             &Trace("$@...attempting rename") if $options{'TRACE'};
  421.             my $oldname = $1;
  422.             $oldname =~ s/:$//;
  423.             my $newname = $oldname . "." . time();
  424.             unless (rename($oldname, $newname)) {
  425.                 &Trace("$!") if $options{'TRACE'};
  426.                 $PPM::PPMERR = "$!";
  427.                 return 0;
  428.             }
  429.         }
  430.         # Some other error
  431.         elsif($@) {
  432.             &Trace("$@") if $options{'TRACE'};
  433.             $PPM::PPMERR = $@;
  434.             return 0;
  435.         }
  436.         else { last; }
  437.     }
  438.  
  439.     #rebuild the html TOC
  440.     
  441.     Trace("Calling ActivePerl::DocTools::UpdateHTML()") if $options{'TRACE'} > 1;
  442.     ActivePerl::DocTools::UpdateHTML() if $useDocTools;
  443.     Trace("Calling ActivePerl::DocTools::WriteTOC()") if $options{'TRACE'} > 1;
  444.     ActivePerl::DocTools::WriteTOC() if $useDocTools;
  445.  
  446.     if (defined $current_package{'INSTALL_SCRIPT'}) {
  447.     unless (run_script("script" => $current_package{'INSTALL_SCRIPT'},
  448.                    "scriptHREF" => $current_package{'INSTALL_HREF'},
  449.                    "exec" => $current_package{'INSTALL_EXEC'},
  450.                    "inst_root" => $inst_root, "inst_archlib" => $inst_archlib))
  451.     {
  452.             $PPM::PPMERR = "PPM install script failed, status $?";
  453.         return 0;
  454.     }
  455.     }
  456.  
  457.     chdir($cwd);
  458.  
  459. # ask to store this location as default for this package?
  460.     PPMdat_add_package($path, $packlist, $inst_root);
  461.     # if 'install.ppm' exists, don't remove; system()
  462.     # has probably not finished with it yet.
  463.     if ($options{'CLEAN'} && !-f "$install_dir/install.ppm") {
  464.         File::Path::rmtree($install_dir,0,0);
  465.     }
  466.     &Trace("Package $package successfully installed") if $options{'TRACE'};
  467.     reread_config();
  468.  
  469.     return 1;
  470. }
  471.  
  472. # Returns a hash with key $location, and elements of arrays of package names.
  473. # Uses '%repositories' if $location is not specified.
  474. sub RepositoryPackages
  475. {
  476.     my %argv = @_;
  477.     my $location = $argv{'location'};
  478.     my %ppds;
  479.     if (defined $location) {
  480.         @{$ppds{$location}} = list_available("location" => $location);
  481.     unless (@{$ppds{$location}}) {
  482.         print "Error connecting to '$location'.\n";
  483.     }
  484.     }
  485.     else {
  486.         read_config();  # need repositories
  487.         foreach (keys %repositories) {
  488.             $location = $repositories{$_}{'LOCATION'};
  489.             @{$ppds{$location}} = list_available("location" => $location);
  490.         }
  491.     }
  492.     return %ppds;
  493. }
  494.  
  495. sub RepositoryPackageProperties
  496. {
  497.     my %argv = @_;
  498.     my $location = $argv{'location'};
  499.     my $package = $argv{'package'};
  500.     my %PPD;
  501.     read_config();
  502.     unless (%PPD = getPPDfile('package' => $package, 'location' => $location)) {
  503.         &Trace("RepositoryPackageProperties: Could not locate a PPD file for package $package") if $options{'TRACE'};
  504.         $PPM::PPMERR = "Could not locate a PPD file for package $package";
  505.         return;
  506.     }
  507.     parsePPD(%PPD);
  508.  
  509.     my %ret_hash = map { $_ => $current_package{$_} } 
  510.         qw(NAME TITLE AUTHOR VERSION ABSTRACT PERLCORE_VER);
  511.     foreach my $dep (keys %{$current_package{'DEPEND'}}) {
  512.         push @{$ret_hash{'DEPEND'}}, $dep;
  513.     }
  514.  
  515.     return %ret_hash;
  516. }
  517.  
  518. # Returns 1 on success, 0 and sets $PPMERR on failure.
  519. sub RemovePackage
  520. {
  521.     my %argv = @_;
  522.     my $package = $argv{'package'};
  523.     my $force = $argv{'force'};
  524.     my %PPD;
  525.  
  526.     read_config();
  527.     unless ($installed_packages{$package}) {
  528.         my $pattern = $package;
  529.         undef $package;
  530.         # Do another lookup, ignoring case
  531.         foreach (keys %installed_packages) {
  532.             if (/^$pattern$/i) {
  533.                 $package = $_;
  534.                 last;
  535.             }
  536.         }
  537.         unless ($package) {
  538.             &Trace("Package '$pattern' has not been installed by PPM")
  539.                 if $options{'TRACE'};
  540.             $PPM::PPMERR = "Package '$pattern' has not been installed by PPM";
  541.             return 0;
  542.         }
  543.     }
  544.  
  545.     # Don't let them remove PPM itself, libnet, Archive-Tar, etc.
  546.     # but we can force removal if we're upgrading
  547.     unless ($force) {
  548.         foreach (@required_packages) {
  549.             if ($_ eq $package) {
  550.                 &Trace("Package '$package' is required by PPM and cannot be removed") if $options{'TRACE'};
  551.                 $PPM::PPMERR = "Package '$package' is required by PPM and cannot be removed";
  552.                 return 0;
  553.             }
  554.         }
  555.     }
  556.  
  557.     my $install_dir = "$options{'BUILDDIR'}/$package";
  558.  
  559.     %PPD = %{ $installed_packages{$package}{'INST_PPD'} };
  560.     parsePPD(%PPD);
  561.     my $cwd = getcwd();
  562.     $cwd .= "/" if $cwd =~ /[a-z]:$/i;
  563.     if (defined $current_package{'UNINSTALL_SCRIPT'}) {
  564.         if (!chdir($install_dir)) {
  565.             &Trace("Could not chdir() to $install_dir: $!") if $options{'TRACE'};
  566.             $PPM::PPMERR = "Could not chdir() to $install_dir: $!";
  567.             return 0;
  568.         }
  569.     unless (run_script("script" => $current_package{'UNINSTALL_SCRIPT'},
  570.                    "scriptHREF" => $current_package{'UNINSTALL_HREF'},
  571.                    "exec" => $current_package{'UNINSTALL_EXEC'}))
  572.     {
  573.             $PPM::PPMERR = "PPM uninstall script failed, status $?";
  574.         return 0;
  575.     }
  576.         chdir($cwd);
  577.     }
  578.     else {
  579.         if (-f $installed_packages{$package}{'INST_PACKLIST'}) {
  580.             &Trace("Calling ExtUtils::Install::uninstall")
  581.                 if $options{'TRACE'} > 1;
  582.             eval {
  583.                 ExtUtils::Install::uninstall("$installed_packages{$package}{'INST_PACKLIST'}", 0, 0);
  584.             };
  585.             warn $@ if $@;
  586.         }
  587.     }
  588.  
  589.     #rebuild the html TOC
  590.     Trace("Calling ActivePerl::DocTools::WriteTOC()") if $options{'TRACE'} > 1;
  591.     ActivePerl::DocTools::WriteTOC() if $useDocTools;
  592.  
  593.     File::Path::rmtree($install_dir,0,0);
  594.     PPMdat_remove_package($package);
  595.     &Trace("Package $package removed") if $options{'TRACE'};
  596.     reread_config();
  597.     return 1;
  598. }
  599.  
  600. # returns "0" if package is up-to-date; "1" if an upgrade is available;
  601. # undef and sets $PPMERR on error; and the new VERSION string if a package
  602. # was upgraded.
  603. sub VerifyPackage
  604. {
  605.     my %argv = @_;
  606.     my $package = $argv{'package'};
  607.     my $location = $argv{'location'};
  608.     my $upgrade = $argv{'upgrade'};
  609.     my $force = $argv{'force'};
  610.     my ($installedPPDfile, $comparePPDfile, %installedPPD, %comparePPD);
  611.  
  612.     read_config();
  613.  
  614.     unless ($installed_packages{$package}) {
  615.         my $pattern = $package;
  616.         undef $package;
  617.         # Do another lookup, ignoring case
  618.         foreach (keys %installed_packages) {
  619.             if (/^$pattern$/i) {
  620.                 $package = $_;
  621.                 last;
  622.             }
  623.         }
  624.         unless ($package) {
  625.             &Trace("Package '$pattern' has not been installed by PPM") if $options{'TRACE'};
  626.             $PPM::PPMERR = "Package '$pattern' has not been installed by PPM";
  627.             return undef;
  628.         }
  629.     }
  630.  
  631.     %installedPPD = %{ $installed_packages{$package}{'INST_PPD'} };
  632.  
  633.     unless (%comparePPD = getPPDfile('package' => $package, 
  634.             'location' => $location)) {
  635.         &Trace("VerifyPackage: Could not locate a PPD file for $package")
  636.             if $options{'TRACE'};
  637.         $PPM::PPMERR = "Could not locate a PPD file for $package";
  638.         return;
  639.     }
  640.  
  641.     parsePPD(%installedPPD);
  642.     my @installed_version = split (',', $current_package{'VERSION'});
  643.     my $inst_root = $installed_packages{$package}{'INST_ROOT'};
  644.  
  645.     parsePPD(%comparePPD);
  646.     unless ($current_package{'CODEBASE'} || $current_package{'INSTALL_HREF'}) {
  647.         &Trace("Read a PPD for '$package', but it is not intended for this build of Perl ($varchname)")
  648.             if $options{'TRACE'};
  649.         $PPM::PPMERR = "Read a PPD for '$package', but it is not intended for this build of Perl ($varchname)";
  650.         return undef;
  651.     }
  652.     my @compare_version = split (',',  $current_package{'VERSION'});
  653.     my $available;
  654.     foreach(0..3) {
  655.         next if $installed_version[$_] == $compare_version[$_];
  656.         $available++ if $installed_version[$_] < $compare_version[$_];
  657.         last;
  658.     }
  659.  
  660.     if ($available || $force) {
  661.         &Trace("Upgrade to $package is available")
  662.         if $options{'TRACE'} > 1 and $available;
  663.         if ($upgrade) {
  664.             if ($Config{'osname'} eq 'MSWin32' &&
  665.                 !&Win32::IsWinNT && exists $Win9x_denied{lc($package)}) {
  666.                 $PPM::PPMERR = "Package '$package' cannot be upgraded with PPM on Win9x--see http://aspn.ActiveState.com/ASPN/Downloads/ActivePerl/PPM/ for details";
  667.                 return undef;
  668.             }
  669.  
  670.             # need to remember the $location, and $current_version,
  671.         # because once we remove the package, they're unavailable.
  672.         # XXX this should probably be fixed
  673.             $location = $installed_packages{$package}{'LOCATION'} unless $location;
  674.         my $current_version = $current_package{'VERSION'};
  675.         unless (getPPDfile('package' => $package, 
  676.                     'location' => $location)) {
  677.         &Trace("VerifyPackage: Could not locate a PPD file for $package") if $options{'TRACE'};
  678.         $PPM::PPMERR = "Could not locate a PPD file for $package";
  679.         return undef;
  680.         }
  681.             RemovePackage("package" => $package, "force" => 1);
  682.             unless(InstallPackage("package" => $package,
  683.                   "location" => $location,
  684.                   "root" => $inst_root))
  685.         {
  686.         # InstallPackage() sets $PPM::PPMERR if it fails
  687.         return undef;
  688.         }
  689.             return $current_version;
  690.         }
  691.         return 1;
  692.     }
  693.     # package is up to date
  694.     return 0;
  695. }
  696.  
  697. # Changes where the packages are installed.
  698. # Returns previous root on success, undef and sets $PPMERR on failure.
  699. sub chroot
  700. {
  701.     my %argv = @_;
  702.     my $location = $argv{'location'};
  703.  
  704.     unless (-d $location) {
  705.         &Trace("'$location' does not exist.") if $options{'TRACE'};
  706.         $PPM::PPMERR = "'$location' does not exist.\n";
  707.         return undef;
  708.     }
  709.  
  710.     my $previous_root = $options{'ROOT'} || $Config{'prefix'};
  711.     $options{'ROOT'} = $location;
  712.     return $previous_root;
  713. }
  714.  
  715. sub QueryInstalledPackages
  716. {
  717.     my %argv = @_;
  718.     my $ignorecase = $options{'IGNORECASE'} || $argv{'ignorecase'};
  719.     my $searchtag = uc $argv{'searchtag'} || undef;
  720.     my ($searchRE, $package, %ret_hash);
  721.     if (defined $argv{'searchRE'}) {
  722.         $searchRE = $argv{'searchRE'};
  723.         $searchRE = "(?i)$searchRE" if $ignorecase;
  724.         eval { $searchRE =~ /$searchRE/ };
  725.         if ($@) {
  726.             &Trace("'$searchRE': invalid regular expression.") if $options{'TRACE'};
  727.             $PPM::PPMERR = "'$searchRE': invalid regular expression.";
  728.             return ();
  729.         }
  730.     }
  731.  
  732.     read_config();
  733.     foreach $package (keys %installed_packages) {
  734.         my $results = $package;
  735.         if (defined $searchtag) {
  736.             my %Package = %{ $installed_packages{$package} };
  737.             parsePPD( %{ $Package{'INST_PPD'} } );
  738.             $results = $current_package{$searchtag};
  739.         }
  740.  
  741.         $ret_hash{$package} = $results
  742.             if (!defined $searchRE || ($results =~ /$searchRE/));
  743.     }
  744.  
  745.     return %ret_hash;
  746. }
  747.  
  748. # Returns a summary of available packages for all repositories.
  749. # Returned hash has the following structure:
  750. #
  751. #    $hash{repository}{package_name}{NAME}
  752. #    $hash{repository}{package_name}{VERSION}
  753. #    etc.
  754. #
  755. sub RepositorySummary {
  756.     my %argv = @_;
  757.     my $location = $argv{'location'};
  758.     my (%summary, %locations);
  759.  
  760.     # If we weren't given the location of a repository to query the summary
  761.     # for, check all of the repositories that we know about.
  762.     unless ($location) {
  763.         read_config();  # need repositories
  764.         foreach (keys %repositories) {
  765.             $locations{$repositories{$_}{'LOCATION'}} =
  766.                 $repositories{$_}{'SUMMARYFILE'};
  767.         }
  768.     }
  769.     # Otherwise, we were given a repository to query, figure out where we can
  770.     # find the summary file for that repository.
  771.     else {
  772.         foreach (keys %repositories) {
  773.             if ($location =~ /\Q$repositories{$_}{'LOCATION'}\E/i) {
  774.                 $locations{$repositories{$_}{'LOCATION'}} =
  775.                     $repositories{$_}{'SUMMARYFILE'};
  776.                 last;
  777.             }
  778.         }
  779.     }
  780.  
  781.     # Check all of the summary file locations that we were able to find.
  782.     foreach $location (keys %locations) {
  783.         my $summaryfile = $locations{$location};
  784.         unless ($summaryfile) {
  785.             &Trace("RepositorySummary: No summary available from $location.")
  786.                 if $options{'TRACE'};
  787.             $PPM::PPMERR = "No summary available from $location.\n";
  788.             next;
  789.         }
  790.         my $data;
  791.         if ($location =~ m@^...*://@i) {
  792.             next unless ($data = read_href("request" => 'GET',
  793.                 "href" => "$location/$summaryfile"));
  794.         } else {
  795.             local $/;
  796.             next if (!open (DATAFILE, "$location/$summaryfile"));
  797.             $data = <DATAFILE>;
  798.             close(DATAFILE);
  799.         }
  800.         $summary{$location} = parse_summary($data);
  801.     }
  802.  
  803.     return %summary;
  804. }
  805.  
  806. # Returns the same structure as RepositorySummary() above.
  807. sub ServerSearch
  808. {
  809.     my %argv = @_;
  810.     my $location = $argv{'location'};
  811.     my $searchRE = $argv{'searchRE'};
  812.     my $searchtag = $argv{'searchtag'};
  813.     my $data;
  814.     my %summary;
  815.  
  816.     return unless $location =~ m#^(http://.*)\?(urn:.*)#i;
  817.     my ($proxy, $uri) = ($1, $2);
  818.     my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
  819.     eval { $data = $client -> 
  820.         search_ppds($varchname, $searchRE, $searchtag) -> result; };
  821.     if ($@) {
  822.         &Trace("Error searching repository '$proxy': $@") 
  823.             if $options{'TRACE'};
  824.         $PPM::PPMERR = "Error searching repository '$proxy': $@\n";
  825.         return;
  826.     }
  827.  
  828.     $summary{$location} = parse_summary($data);
  829.     return %summary;
  830. }
  831.  
  832. #
  833. # Internal subs
  834. #
  835.  
  836. sub parse_summary
  837. {
  838.     my $data = shift;
  839.     my (%summary, @parsed);
  840.  
  841.     # take care of '&'
  842.     $data =~ s/&(?!\w+;)/&/go;
  843.  
  844.     my $parser = new XML::Parser( Style => 'Objects', 
  845.         Pkg => 'PPM::XML::RepositorySummary' );
  846.     eval { @parsed = @{ $parser->parse( $data ) } };
  847.     if ($@) {
  848.         &Trace("parse_summary: content of summary file is not valid") 
  849.             if $options{'TRACE'};
  850.         $PPM::PPMERR = 
  851.             "parse_summary: content of summary file is not valid: $!\n";
  852.         return;
  853.     }
  854.  
  855.  
  856.     my $packages = ${$parsed[0]}{Kids};
  857.  
  858.     foreach my $package (@{$packages}) {
  859.         my $elem_type = ref $package;
  860.         $elem_type =~ s/.*:://;
  861.         next if ($elem_type eq 'Characters');
  862.  
  863.         if ($elem_type eq 'SOFTPKG') {
  864.             my %ret_hash;
  865.             parsePPD(%{$package});
  866.             %ret_hash = map { $_ => $current_package{$_} } 
  867.                 qw(NAME TITLE AUTHOR VERSION ABSTRACT PERLCORE_VER);
  868.             foreach my $dep (keys %{$current_package{'DEPEND'}}) {
  869.                 push @{$ret_hash{'DEPEND'}}, $dep;
  870.             }
  871.             $summary{$current_package{'NAME'}} = \%ret_hash;
  872.         }
  873.     }
  874.     return \%summary;
  875. }
  876.  
  877. sub save_options
  878. {
  879.     read_config();
  880.     my %PPMConfig;
  881.     # Read in the existing PPM configuration file
  882.     return unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
  883.         'parsertype' => 'PPM::XML::PPMConfig'));
  884.  
  885.     # Remove all of the declarations for REPOSITORY and PPMPRECIOUS;
  886.     # we'll output these from the lists we've got in memory instead.
  887.     foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
  888.         my $elem = $PPMConfig{Kids}[$idx];
  889.         my $elem_type = ref $elem;
  890.         if ($elem_type =~ /::REPOSITORY$|::PPMPRECIOUS$/o) {
  891.             splice( @{$PPMConfig{Kids}}, $idx, 1 );
  892.             redo;   # Restart again so we don't miss any
  893.         }
  894.     }
  895.  
  896.     # Traverse the info we read in and replace the values in it with the new
  897.     # config options that we've got.
  898.     foreach my $elem (@{ $PPMConfig{Kids} }) {
  899.         my $elem_type = ref $elem;
  900.         $elem_type =~ s/.*:://;
  901.         next if ($elem_type ne 'OPTIONS');
  902.         %{$elem} = map { $_ => $options{$_} } keys %options;
  903.         # This bit of ugliness is necessary for historical (VPM) reasons
  904.         delete $elem->{FORCE_INSTALL};
  905.         $elem->{FORCEINSTALL} = $options{'FORCE_INSTALL'};
  906.     }
  907.  
  908.     # Find out where the package listings start and insert our PPMPRECIOUS and
  909.     # updated list of REPOSITORYs.
  910.     foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
  911.         my $elem = $PPMConfig{Kids}[$idx];
  912.         my $elem_type = ref $elem;
  913.         $elem_type =~ s/.*:://;
  914.         next unless (($elem_type eq 'PACKAGE') or
  915.                      ($idx == $#{$PPMConfig{Kids}}));
  916.  
  917.         # Insert our PPMPRECIOUS
  918.         my $chardata = new PPM::XML::PPMConfig::Characters;
  919.         $chardata->{Text} = join( ';', @required_packages );
  920.         my $precious = new PPM::XML::PPMConfig::PPMPRECIOUS;
  921.         push( @{$precious->{Kids}}, $chardata );
  922.         splice( @{$PPMConfig{Kids}}, $idx, 0, $precious );
  923.  
  924.         # Insert the list of repositories we've got
  925.         my $rep_name;
  926.         foreach $rep_name (keys %repositories) {
  927.             my $repository = new PPM::XML::PPMConfig::REPOSITORY;
  928.             %{$repository} = 
  929.                 map { $_ => $repositories{$rep_name}{$_} } 
  930.                     keys %{$repositories{$rep_name}};
  931.             $repository->{'NAME'} = $rep_name;
  932.             splice( @{$PPMConfig{Kids}}, $idx, 0, $repository );
  933.         }
  934.         last;
  935.     }
  936.     # Take the data structure we've got and bless it into a PPMCONFIG object so
  937.     # that we can output it.
  938.     my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
  939.  
  940.     # Open the output file and output the PPM config file
  941.     unless (open( DAT, ">$PPM::PPMdat" )) {
  942.         &Trace("open of $PPM::PPMdat failed: $!") if $options{'TRACE'};
  943.         $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
  944.         return 1;
  945.     }
  946.     my $oldout = select DAT;
  947.     $cfg->output();
  948.     select $oldout;
  949.     close( DAT );
  950.     &Trace("Wrote config file") if $options{'TRACE'} > 1;
  951. }
  952.  
  953. # Gets a listing of all of the packages available in the repository.  If an
  954. # argument of 'location' is provided in %argv, it is used as the repository to
  955. # query.  This method returns to the caller a complete list of all of the
  956. # available packages at the repository in a list context, returning 'undef' if
  957. # any errors occurred.
  958. sub list_available
  959. {
  960.     my %argv = @_;
  961.     my $location = $argv{'location'};
  962.     my @ppds;
  963.  
  964.     if ($location =~ /^file:\/\/.*\|/i) {
  965.         # $location is a local directory, let's avoid LWP by changing
  966.         # it to a pathname.
  967.         $location =~ s@^file://@@i;
  968.         $location =~ s@^localhost/@@i;
  969.         $location =~ s@\|@:@;
  970.     }
  971.  
  972.     # URL in UNC notation
  973.     if ($location =~ /^file:\/\/\/\//i) {
  974.         $location =~ s@^file://@@i;
  975.     }
  976.  
  977.     # directory or UNC
  978.     if (-d $location || $location =~ /^\\\\/ || $location =~ /^\/\//) {
  979.         opendir(PPDDIR, $location) or return undef;
  980.         my ($file);
  981.         @ppds = grep { /\.ppd$/i && -f "$location/$_" } readdir(PPDDIR);
  982.         foreach $file (@ppds) {
  983.             $file =~ s/\.ppd//i;
  984.         }
  985.     }
  986.     elsif ($location =~ m@^...*://@i) {
  987.         if ($cached_ppd_list{$location}) {
  988.             return @{$cached_ppd_list{$location}};
  989.         }
  990.  
  991.         # If we're accessing a SOAP server, do things differently than we would
  992.         # for FTP, HTTP, etc.
  993.         if ($location =~ m#^(http://.*)\?(.*)#i) {
  994.             my ($proxy, $uri) = ($1, $2);
  995.             my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
  996.             eval { @ppds = $client->packages()->paramsout };
  997.             if ($@) {
  998.                 &Trace("Package list from '$proxy' failed: $@") 
  999.                     if $options{'TRACE'};
  1000.                 $PPM::PPMERR = 
  1001.                     "Package list from repository '$proxy' failed: $@\n";
  1002.                 return;
  1003.             }
  1004.         }
  1005.         else {
  1006.             return unless (my $doc = read_href("href" => $location,
  1007.                 "request" => 'GET'));
  1008.  
  1009.             if ($doc =~ /^<head><title>/) {
  1010.                 # read an IIS format directory listing
  1011.                 @ppds = grep { /\.ppd/i } split('<br>', $doc);
  1012.                 foreach my $file (@ppds) {
  1013.                     $file =~ s/\.ppd<.*$//is;
  1014.                     $file =~ s@.*>@@is;
  1015.                 }
  1016.             }
  1017.             elsif ($doc =~ /<BODY BGCOLOR=FFFFFF>\n\n<form name=VPMform/s) {
  1018.                 # read output of default.prk over an HTTP connection
  1019.                 @ppds = grep { /^<!--Key:.*-->$/ } split('\n', $doc);
  1020.                 foreach my $file (@ppds) {
  1021.                     if ($file =~ /^<!--Key:(.*)-->$/) {
  1022.                         $file = $1;
  1023.                     }
  1024.                 }
  1025.             }
  1026.             else {
  1027.                 # read an Apache format directory listing
  1028.                 @ppds = grep { /\.ppd/i } split('\n', $doc);
  1029.                 foreach my $file (@ppds) {
  1030.                     $file =~ s/^.*>(.*?)\.ppd<.*$/$1/i;
  1031.                 }
  1032.             }
  1033.         }
  1034.  
  1035.         # All done, take the list of PPDs that we've queried and cache it for
  1036.         # later re-use, then return it to the caller.
  1037.         @{$cached_ppd_list{$location}} = sort @ppds;
  1038.         return @{$cached_ppd_list{$location}};
  1039.     }
  1040.     return sort @ppds;
  1041. }
  1042.  
  1043. my ($response, $bytes_transferred);
  1044.  
  1045. sub read_href
  1046. {
  1047.     my %argv = @_;
  1048.     my $href = $argv{'href'};
  1049.     my $request = $argv{'request'};
  1050.     my $target = $argv{'target'};
  1051.     my $progress = $argv{'progress'}; # display status of binary transfers
  1052.     my ($proxy_user, $proxy_pass);
  1053.     # If this is a SOAP URL, handle it differently than FTP/HTTP/file.
  1054.     if ($href =~ m#^(http://.*)\?(.*)#i) {
  1055.         my ($proxy, $uri) = ($1, $2);
  1056.         my $fcn;
  1057.         if ($uri =~ m#(.*:/.*)/(.+?)$#) {
  1058.             ($uri, $fcn) = ($1, $2);
  1059.         }
  1060.         my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
  1061.         if ($fcn eq 'fetch_summary') {
  1062.             my $summary = eval { $client->fetch_summary()->result; };
  1063.             if ($@) {
  1064.                 &Trace("Error getting summary from repository '$proxy': $@") 
  1065.                     if $options{'TRACE'};
  1066.                 $PPM::PPMERR = 
  1067.                     "Error getting summary from repository '$proxy': $@\n";
  1068.                 return;
  1069.             }
  1070.             return $summary;
  1071.         }
  1072.         $fcn =~ s/\.ppd$//i;
  1073.         my $ppd = eval { $client->fetch_ppd($fcn)->result };
  1074.         if ($@) {
  1075.             &Trace("Error fetching '$fcn' from repository '$proxy': $@") 
  1076.                 if $options{'TRACE'};
  1077.             $PPM::PPMERR = 
  1078.                 "Error fetching '$fcn' from repository '$proxy': $@\n";
  1079.             return;
  1080.         }
  1081.         return $ppd;
  1082.         # todo: write to disk file if $target
  1083.     }
  1084.     # Otherwise it's a standard URL, go ahead and request it using LWP.
  1085.     my $ua = new LWP::UserAgent;
  1086.     $ua->agent($ENV{HTTP_proxy_agent} || ("$0/0.1 " . $ua->agent));
  1087.     if (defined $ENV{HTTP_proxy}) {
  1088.         $proxy_user = $ENV{HTTP_proxy_user};
  1089.         $proxy_pass = $ENV{HTTP_proxy_pass};
  1090.         &Trace("read_href: calling env_proxy: $ENV{'HTTP_proxy'}")
  1091.             if $options{'TRACE'} > 1;
  1092.         $ua->env_proxy;
  1093.     }
  1094.     my $req = new HTTP::Request $request => $href;
  1095.     if (defined $proxy_user && defined $proxy_pass) {
  1096.         &Trace("read_href: calling proxy_authorization_basic($proxy_user, $proxy_pass)") if $options{'TRACE'} > 1;
  1097.         $req->proxy_authorization_basic("$proxy_user", "$proxy_pass");
  1098.     }
  1099.  
  1100.     # Do we need to do authorization?
  1101.     # This is a hack, but will have to do for now.
  1102.     foreach (keys %repositories) {
  1103.         if ($href =~ /^\Q$repositories{$_}{'LOCATION'}\E/i) {
  1104.             my $username = $repositories{$_}{'USERNAME'};
  1105.             my $password = $repositories{$_}{'PASSWORD'};
  1106.             if (defined $username && defined $password) {
  1107.                 &Trace("read_href: calling proxy_authorization_basic($username, $password)") if $options{'TRACE'} > 1;
  1108.                 $req->authorization_basic($username, $password);
  1109.                 last;
  1110.             }
  1111.         }
  1112.     }
  1113.  
  1114.     ($response, $bytes_transferred) = (undef, 0);
  1115.     if ($progress && -t STDOUT) {
  1116.         # display the 'progress indicator'
  1117.     print "Downloading " . $req->uri . " ...\n";
  1118.         $ua->request($req, \&lwp_callback, 
  1119.             ($options{'DOWNLOADSTATUS'} || 4096));
  1120.     if ($PPM::PPMShell && $options{'DOWNLOADSTATUS'}) {
  1121.         # remove "Bytes transfered:"-message;
  1122.         print " " x 35;
  1123.         print "\r";
  1124.     }
  1125.     }
  1126.     else {
  1127.         $response = $ua->request($req);
  1128.     }
  1129.     if ($response && $response->is_success) {
  1130.         if ($target) {
  1131.             unless (open(OUT, ">$target")) {
  1132.                 &Trace("read_href: Couldn't open $target for writing")
  1133.                     if $options{'TRACE'};
  1134.                 $PPM::PPMERR = "Couldn't open $target for writing\n";
  1135.                 return;
  1136.             }
  1137.             binmode(OUT);
  1138.             print OUT $response->content;
  1139.             close(OUT);
  1140.         }
  1141.         return $response->content;
  1142.     }
  1143.     if ($response) {
  1144.         &Trace("read_href: Error reading $href: " . $response->code . " " . 
  1145.             $response->message) if $options{'TRACE'};
  1146.         $PPM::PPMERR = "Error reading $href: " . $response->code . " " . 
  1147.             $response->message . "\n";
  1148.     }
  1149.     else {
  1150.         &Trace("read_href: Error reading $href") if $options{'TRACE'};
  1151.         $PPM::PPMERR = "Error reading $href\n";
  1152.     }
  1153.     return;
  1154. }
  1155.  
  1156. sub lwp_callback
  1157. { 
  1158.     my ($data, $res, $protocol) = @_;
  1159.     $response = $res;
  1160.     $response->add_content($data);
  1161.     $bytes_transferred += length($data);
  1162.     print "Bytes transferred: $bytes_transferred\r" 
  1163.         if ($PPM::PPMShell && $options{'DOWNLOADSTATUS'});
  1164. }
  1165.  
  1166. sub reread_config
  1167. {
  1168.     %current_package = ();
  1169.     %installed_packages = ();
  1170.     $init = 0;
  1171.     read_config();
  1172. }
  1173.  
  1174. # returns 0 on success, 1 and sets $PPMERR on error.
  1175. sub PPMdat_add_package
  1176. {
  1177.     my ($location, $packlist, $inst_root) = @_;
  1178.     my $package = $current_package{'NAME'};
  1179.     my $time_str = localtime;
  1180.  
  1181.     # If we already have this package installed, remove it from the PPM
  1182.     # Configuration file so we can put the new one in.
  1183.     if (defined $installed_packages{$package} ) {
  1184.         # remove the existing entry for this package.
  1185.         PPMdat_remove_package($package);
  1186.     }
  1187.  
  1188.     # Build the new SOFTPKG data structure for this package we're adding.
  1189.     my $softpkg =
  1190.         new PPM::XML::PPMConfig::SOFTPKG( NAME    => $package,
  1191.                                      VERSION => $current_package{VERSION}
  1192.                                    );
  1193.  
  1194.     if (defined $current_package{TITLE}) {
  1195.         my $chardata = new PPM::XML::PPMConfig::Characters( 
  1196.             Text => $current_package{TITLE} );
  1197.         my $newelem = new PPM::XML::PPMConfig::TITLE;
  1198.         push( @{$newelem->{Kids}}, $chardata );
  1199.         push( @{$softpkg->{Kids}}, $newelem );
  1200.     }
  1201.  
  1202.     if (defined $current_package{ABSTRACT}) {
  1203.         my $chardata = new PPM::XML::PPMConfig::Characters(
  1204.             Text => $current_package{ABSTRACT});
  1205.         my $newelem = new PPM::XML::PPMConfig::ABSTRACT;
  1206.         push( @{$newelem->{Kids}}, $chardata );
  1207.         push( @{$softpkg->{Kids}}, $newelem );
  1208.     }
  1209.  
  1210.     if (defined $current_package{AUTHOR}) {
  1211.         my $chardata = new PPM::XML::PPMConfig::Characters(
  1212.             Text => $current_package{AUTHOR} );
  1213.         my $newelem = new PPM::XML::PPMConfig::AUTHOR;
  1214.         push( @{$newelem->{Kids}}, $chardata );
  1215.         push( @{$softpkg->{Kids}}, $newelem );
  1216.     }
  1217.  
  1218.     if (defined $current_package{LICENSE}) {
  1219.         my $chardata = new PPM::XML::PPMConfig::Characters(
  1220.             Text => $current_package{LICENSE});
  1221.         my $newelem = new PPM::XML::PPMConfig::LICENSE;
  1222.         push( @{$newelem->{Kids}}, $chardata );
  1223.         push( @{$softpkg->{Kids}}, $newelem );
  1224.     }
  1225.  
  1226.     my $impl = new PPM::XML::PPMConfig::IMPLEMENTATION;
  1227.     push( @{$softpkg->{Kids}}, $impl );
  1228.  
  1229.     if (defined $current_package{PERLCORE_VER}) {
  1230.         my $newelem = new PPM::XML::PPMConfig::PERLCORE(
  1231.             VERSION => $current_package{PERLCORE_VER} );
  1232.         push( @{$impl->{Kids}}, $newelem );
  1233.     }
  1234.  
  1235.     foreach (keys %{$current_package{DEPEND}}) {
  1236.         my $newelem = new PPM::XML::PPMConfig::DEPENDENCY(
  1237.             NAME => $_, VERSION => $current_package{DEPEND}{$_} );
  1238.         push( @{$impl->{Kids}}, $newelem );
  1239.     }
  1240.  
  1241.     my $codebase = new PPM::XML::PPMConfig::CODEBASE(
  1242.         HREF => $current_package{CODEBASE} );
  1243.     push( @{$impl->{Kids}}, $codebase );
  1244.  
  1245.     my $inst = new PPM::XML::PPMConfig::INSTALL;
  1246.     push( @{$impl->{Kids}}, $inst );
  1247.     if (defined $current_package{INSTALL_EXEC})
  1248.         { $inst->{EXEC} = $current_package{INSTALL_EXEC}; }
  1249.     if (defined $current_package{INSTALL_HREF})
  1250.         { $inst->{HREF} = $current_package{INSTALL_HREF}; }
  1251.     if (defined $current_package{INSTALL_SCRIPT}) {
  1252.         my $chardata = new PPM::XML::PPMConfig::Characters(
  1253.             Text => $current_package{INSTALL_SCRIPT} );
  1254.         push( @{$inst->{Kids}}, $chardata );
  1255.     }
  1256.  
  1257.     my $uninst = new PPM::XML::PPMConfig::UNINSTALL;
  1258.     push( @{$impl->{Kids}}, $uninst );
  1259.     if (defined $current_package{UNINSTALL_EXEC})
  1260.         { $uninst->{EXEC} = $current_package{UNINSTALL_EXEC}; }
  1261.     if (defined $current_package{UNINSTALL_HREF})
  1262.         { $uninst->{HREF} = $current_package{UNINSTALL_HREF}; }
  1263.     if (defined $current_package{UNINSTALL_SCRIPT}) {
  1264.         my $chardata = new PPM::XML::PPMConfig::Characters(
  1265.             Text => $current_package{UNINSTALL_SCRIPT} );
  1266.         push( @{$uninst->{Kids}}, $chardata );
  1267.     }
  1268.  
  1269.     # Then, build the PACKAGE object and stick the SOFTPKG inside of it.
  1270.     my $pkg = new PPM::XML::PPMConfig::PACKAGE( NAME => $package );
  1271.  
  1272.     if ($location) {
  1273.         my $chardata = new PPM::XML::PPMConfig::Characters( Text => $location );
  1274.         my $newelem = new PPM::XML::PPMConfig::LOCATION;
  1275.         push( @{$newelem->{Kids}}, $chardata );
  1276.         push( @{$pkg->{Kids}}, $newelem );
  1277.     }
  1278.  
  1279.     if ($packlist) {
  1280.         my $chardata = new PPM::XML::PPMConfig::Characters( Text => $packlist );
  1281.         my $newelem = new PPM::XML::PPMConfig::INSTPACKLIST;
  1282.         push( @{$newelem->{Kids}}, $chardata );
  1283.         push( @{$pkg->{Kids}}, $newelem );
  1284.     }
  1285.  
  1286.     if ($inst_root) {
  1287.         my $chardata = new PPM::XML::PPMConfig::Characters( Text => $inst_root );
  1288.         my $newelem = new PPM::XML::PPMConfig::INSTROOT;
  1289.         push( @{$newelem->{Kids}}, $chardata );
  1290.         push( @{$pkg->{Kids}}, $newelem );
  1291.     }
  1292.  
  1293.     if ($time_str) {
  1294.         my $chardata = new PPM::XML::PPMConfig::Characters( Text => $time_str);
  1295.         my $newelem = new PPM::XML::PPMConfig::INSTDATE;
  1296.         push( @{$newelem->{Kids}}, $chardata );
  1297.         push( @{$pkg->{Kids}}, $newelem );
  1298.     }
  1299.  
  1300.     my $instppd = new PPM::XML::PPMConfig::INSTPPD;
  1301.     push( @{$instppd->{Kids}}, $softpkg );
  1302.     push( @{$pkg->{Kids}}, $instppd );
  1303.  
  1304.     # Now that we've got the structure built, read in the existing PPM
  1305.     # Configuration file, add this to it, and spit it back out.
  1306.     my %PPMConfig;
  1307.     return 1 unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
  1308.         'parsertype' => 'PPM::XML::PPMConfig'));
  1309.     push( @{$PPMConfig{Kids}}, $pkg );
  1310.     my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
  1311.  
  1312.     unless (open( DAT, ">$PPM::PPMdat" )) {
  1313.         &Trace("open of $PPM::PPMdat failed: $!") if $options{'TRACE'};
  1314.         $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
  1315.         return 1;
  1316.     }
  1317.     my $oldout = select DAT;
  1318.     $cfg->output();
  1319.     select $oldout;
  1320.     close( DAT );
  1321.     &Trace("PPMdat_add_package: wrote $PPM::PPMdat") if $options{'TRACE'} > 1;
  1322.  
  1323.     return 0;
  1324. }
  1325.  
  1326. # returns 0 on success, 1 and sets $PPMERR on error.
  1327. sub PPMdat_remove_package
  1328. {
  1329.     my $package = shift;
  1330.  
  1331.     # Read in the existing PPM configuration file
  1332.     my %PPMConfig;
  1333.     return 1 unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
  1334.         'parsertype' => 'PPM::XML::PPMConfig'));
  1335.  
  1336.     # Try to find the package that we're supposed to be removing, and yank it
  1337.     # out of the list of installed packages.
  1338.     foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
  1339.         my $elem = $PPMConfig{Kids}[$idx];
  1340.         my $elem_type = ref $elem;
  1341.         next if ($elem_type !~ /::PACKAGE$/o);
  1342.         next if ($elem->{NAME} ne $package);
  1343.         splice( @{$PPMConfig{Kids}}, $idx, 1 );
  1344.     }
  1345.  
  1346.     # Take the data structure we've got and bless it into a PPMCONFIG object so
  1347.     # that we can output it again.
  1348.     my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
  1349.  
  1350.     # Now that we've removed the package, save the configuration file back out.
  1351.     unless (open( DAT, ">$PPM::PPMdat" )) {
  1352.         $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
  1353.         return 1;
  1354.     }
  1355.     my $oldout = select DAT;
  1356.     $cfg->output();
  1357.     select $oldout;
  1358.     close( DAT );
  1359.     &Trace("PPMdat_remove_package: wrote $PPM::PPMdat")
  1360.         if $options{'TRACE'} > 1;
  1361.     return 0;
  1362. }
  1363.  
  1364. # Run $script using system().  If $scriptHREF is specified, its contents are
  1365. # used as the script.  If $exec is specified, the script is saved to a
  1366. # temporary file and executed by $exec.
  1367. sub run_script
  1368. {
  1369.     my %argv = @_;
  1370.     my $script = $argv{'script'};
  1371.     my $scriptHREF = $argv{'scriptHREF'};
  1372.     my $exec = $argv{'exec'};
  1373.     my $inst_root = $argv{'inst_root'};
  1374.     my $inst_archlib = $argv{'inst_archlib'};
  1375.     my (@commands, $tmpname);
  1376.  
  1377.     if ($scriptHREF) {
  1378.         if ($exec) {
  1379.             # store in a temp file.
  1380.             $tmpname = "$options{'BUILDDIR'}/PPM-" . time();
  1381.             LWP::Simple::getstore($scriptHREF, $tmpname);
  1382.         }
  1383.         else {
  1384.             my $doc = LWP::Simple::get $scriptHREF;
  1385.             if (!defined $doc) {
  1386.                 &Trace("run_script: get $scriptHREF failed")
  1387.                     if $options{'TRACE'} > 1;
  1388.                 return 0;
  1389.             }
  1390.             @commands = split("\n", $doc);
  1391.         }
  1392.     }
  1393.     else {
  1394.         if (-f $script) {
  1395.             $tmpname = $script;
  1396.         }
  1397.         else {
  1398.             # change any escaped chars
  1399.             $script =~ s/</</gi;
  1400.             $script =~ s/>/>/gi;
  1401.  
  1402.             @commands = split(';;', $script);
  1403.             if ($exec) {
  1404.                 # store in a temp file.
  1405.                 $tmpname = "$options{'BUILDDIR'}/PPM-" . time();
  1406.                 open(TMP, ">$tmpname");
  1407.                 foreach my $command (@commands) {
  1408.                     print TMP "$command\n";
  1409.                 }
  1410.                 close(TMP);
  1411.             }
  1412.         }
  1413.     }
  1414.     $ENV{'PPM_INSTROOT'} = $inst_root;
  1415.     $ENV{'PPM_INSTARCHLIB'} = $inst_archlib;
  1416.     if ($exec) {
  1417.         if ($exec =~ /^PPM_PERL$/i) {
  1418.         $exec = $^X;
  1419.         unless ($exec =~ m,/,) {
  1420.         $exec = "$Config{binexp}/$exec"
  1421.             if -x "$Config{binexp}/$exec";
  1422.         }
  1423.     }
  1424.         $exec = "start $exec" if $Config{'osname'} eq 'MSWin32';
  1425.         if (system("$exec $tmpname") != 0) {
  1426.         &Trace("system($exec $tmpname) failed")
  1427.         if $options{'TRACE'} > 1;
  1428.         return 0;
  1429.     }
  1430.     }
  1431.     else {
  1432.         for my $command (@commands) {
  1433.             if (system($command) != 0) {
  1434.         &Trace("system($command) failed")
  1435.             if $options{'TRACE'} > 1;
  1436.         return 0;
  1437.         }
  1438.         }
  1439.     }
  1440.     return 1;
  1441. }
  1442.  
  1443. sub parsePPD
  1444. {
  1445.     my %PPD = @_;
  1446.     my $pkg;
  1447.  
  1448.     %current_package = ();
  1449.  
  1450.     # Get the package name and version from the attributes and stick it
  1451.     # into the 'current package' global var
  1452.     $current_package{NAME}    = $PPD{NAME};
  1453.     $current_package{VERSION} = $PPD{VERSION};
  1454.  
  1455.     # Get all the information for this package and put it into the 'current
  1456.     # package' global var.
  1457.     my $got_implementation = 0;
  1458.     my $elem;
  1459.  
  1460.     foreach $elem (@{$PPD{Kids}}) {
  1461.         my $elem_type = ref $elem;
  1462.         $elem_type =~ s/.*:://;
  1463.         next if ($elem_type eq 'Characters');
  1464.  
  1465.         if ($elem_type eq 'TITLE') {
  1466.             # Get the package title out of our _only_ char data child
  1467.             $current_package{TITLE} = $elem->{Kids}[0]{Text};
  1468.         }
  1469.         elsif ($elem_type eq 'LICENSE') {
  1470.             # Get the HREF for the license out of our attribute
  1471.             $current_package{LICENSE} = $elem->{HREF};
  1472.         }
  1473.         elsif ($elem_type eq 'ABSTRACT') {
  1474.             # Get the package abstract out of our _only_ char data child
  1475.             $current_package{ABSTRACT} = $elem->{Kids}[0]{Text};
  1476.         }
  1477.         elsif ($elem_type eq 'AUTHOR') {
  1478.             # Get the authors name out of our _only_ char data child
  1479.             $current_package{AUTHOR} = $elem->{Kids}[0]{Text};
  1480.         }
  1481.         elsif ($elem_type eq 'IMPLEMENTATION') {
  1482.             # If we don't have a valid implementation yet, check if this is
  1483.             # it.
  1484.             next if ($got_implementation);
  1485.             $got_implementation = implementation( @{ $elem->{Kids} } );
  1486.         }
  1487.         else {
  1488.             &Trace("Unknown element '$elem_type' found inside SOFTPKG") if $options{'TRACE'};
  1489.             die "Unknown element '$elem_type' found inside SOFTPKG.";
  1490.         }
  1491.     } # End of "for each child element inside the PPD"
  1492.  
  1493.     if ($options{'TRACE'} > 3 and (%current_package) ) {
  1494.         &Trace("Read a PPD:");
  1495.         foreach my $elem (keys %current_package) {
  1496.             &Trace("\t$elem:\t$current_package{$elem}");
  1497.         }
  1498.     }
  1499.  
  1500.     if (($Debug & 2) and (%current_package)) {
  1501.         print "Read a PPD...\n";
  1502.         foreach my $elem (keys %current_package)
  1503.             { print "\t$elem:\t$current_package{$elem}\n"; }
  1504.     }
  1505. }
  1506.  
  1507. # Tests the passed IMPLEMENTATION for suitability on the current platform.
  1508. # Fills in the CODEBASE, INSTALL_HREF, INSTALL_EXEC, INSTALL_SCRIPT,
  1509. # UNINSTALL_HREF, UNINSTALL_EXEC, UNINSTALL_SCRIPT and DEPEND keys of
  1510. # %current_package.  Returns 1 on success, 0 otherwise.
  1511. sub implementation
  1512. {
  1513.     my @impl = @_;
  1514.  
  1515.     # Declare the tmp vars we're going to use to hold onto things.
  1516.     my ($ImplProcessor, $ImplOS, $ImplOSVersion, $ImplLanguage, $ImplCodebase);
  1517.     my ($ImplInstallHREF, $ImplInstallEXEC, $ImplInstallScript);
  1518.     my ($ImplUninstallHREF, $ImplUninstallEXEC, $ImplUninstallScript);
  1519.     my ($ImplArch, $ImplPerlCoreVer, %ImplDepend);
  1520.  
  1521.     my $elem;
  1522.     foreach $elem (@impl) {
  1523.         my $elem_type = ref $elem;
  1524.         $elem_type =~ s/.*:://;
  1525.         next if ($elem_type eq 'Characters');
  1526.  
  1527.         if ($elem_type eq 'CODEBASE') {
  1528.             # Get the reference to the codebase out of our attributes.
  1529.             $ImplCodebase = $elem->{HREF};
  1530.         }
  1531.         elsif ($elem_type eq 'DEPENDENCY') {
  1532.             # Get the name of any dependencies we have out of our attributes.
  1533.             # Dependencies in old PPDs might not have version info.
  1534.             $ImplDepend{$elem->{NAME}} = (defined $elem->{VERSION} && $elem->{VERSION} ne "") ? $elem->{VERSION} : "0,0,0,0";
  1535.         }
  1536.         elsif ($elem_type eq 'LANGUAGE') {
  1537.             # Get the language out of our attributes (if we don't already have
  1538.             # the right one).
  1539.             if ($ImplLanguage && ($ImplLanguage ne $LANGUAGE))
  1540.                 { $ImplLanguage = $elem->{VALUE}; }
  1541.         }
  1542.         elsif ($elem_type eq 'ARCHITECTURE') {
  1543.             $ImplArch = $elem->{VALUE};
  1544.         }
  1545.         elsif ($elem_type eq 'OS') {
  1546.             # Get the OS value out of our attribute.
  1547.             $ImplOS = $elem->{VALUE};
  1548.         }
  1549.         elsif ($elem_type eq 'OSVERSION') {
  1550.             # Get the OS version value out of our attribute
  1551.             $ImplOSVersion = $elem->{VALUE};
  1552.         }
  1553.         elsif ($elem_type eq 'PERLCORE') {
  1554.             # Get the compiled Perl core value out of our attributes
  1555.             $ImplPerlCoreVer = $elem->{VERSION};
  1556.         }
  1557.         elsif ($elem_type eq 'PROCESSOR') {
  1558.             # Get the processor value out of our attribute
  1559.             $ImplProcessor = $elem->{VALUE};
  1560.         }
  1561.         elsif ($elem_type eq 'INSTALL') {
  1562.             # Get anything which might have been an attribute
  1563.             $ImplInstallHREF = $elem->{HREF};
  1564.             $ImplInstallEXEC = $elem->{EXEC};
  1565.             # Get any raw Perl script out of here (if we've got any)
  1566.             if ( (exists $elem->{Kids}) and (exists $elem->{Kids}[0]{Text}) )
  1567.                 { $ImplInstallScript = $elem->{Kids}[0]{Text}; }
  1568.         }
  1569.         elsif ($elem_type eq 'UNINSTALL') {
  1570.             # Get anything which might have been an attribute
  1571.             $ImplUninstallHREF = $elem->{HREF};
  1572.             $ImplUninstallEXEC = $elem->{EXEC};
  1573.             # Get any raw Perl script out of here (if we've got any)
  1574.             if ( (exists $elem->{Kids}) and (exists $elem->{Kids}[0]{Text}) )
  1575.                 { $ImplUninstallScript = $elem->{Kids}[0]{Text}; }
  1576.         }
  1577.         else {
  1578.             die "Unknown element '$elem_type' found inside of IMPLEMENTATION.";
  1579.         }
  1580.     } # end of 'for every element inside IMPLEMENTATION'
  1581.  
  1582.     # Check to see if we've found a valid IMPLEMENTATION for the target
  1583.     # machine.
  1584.     return 0 if ((defined $ImplArch) and ($ImplArch ne $varchname));
  1585.     return 0 if ((defined $ImplProcessor) and ($ImplProcessor ne $CPU));
  1586.     return 0 if ((defined $ImplLanguage) and ($ImplLanguage ne $LANGUAGE));
  1587.     return 0 if ((defined $ImplOS) and ($ImplOS ne $OS_VALUE));
  1588.     return 0 if ((defined $ImplOSVersion) and ($ImplOSVersion ne $OS_VERSION));
  1589.  
  1590.     # Got a valid IMPLEMENTATION, stuff all the values we just read in into the
  1591.     # 'current package' global var.
  1592.     $current_package{PERLCORE_VER} = $ImplPerlCoreVer
  1593.         if (defined $ImplPerlCoreVer);
  1594.     $current_package{CODEBASE} = $ImplCodebase
  1595.         if (defined $ImplCodebase);
  1596.     $current_package{INSTALL_HREF} = $ImplInstallHREF
  1597.         if (defined $ImplInstallHREF);
  1598.     $current_package{INSTALL_EXEC} = $ImplInstallEXEC
  1599.         if (defined $ImplInstallEXEC);
  1600.     $current_package{INSTALL_SCRIPT} = $ImplInstallScript
  1601.         if (defined $ImplInstallScript);
  1602.     $current_package{UNINSTALL_HREF} = $ImplUninstallHREF
  1603.         if (defined $ImplUninstallHREF);
  1604.     $current_package{UNINSTALL_EXEC} = $ImplUninstallEXEC
  1605.         if (defined $ImplUninstallEXEC);
  1606.     $current_package{UNINSTALL_SCRIPT} = $ImplUninstallScript
  1607.         if (defined $ImplUninstallScript);
  1608.     %{$current_package{DEPEND}} = %ImplDepend
  1609.         if (%ImplDepend);
  1610.  
  1611.     return 1;
  1612. }
  1613.  
  1614. sub getPPDfile
  1615. {
  1616.     my %argv = @_;
  1617.     my $package = $argv{'package'};
  1618.     my $parsertype = $argv{'parsertype'} || 'PPM::XML::PPD';
  1619.     my $location = $argv{'location'};
  1620.     my $PPDfile = $argv{'PPDfile'};
  1621.     my (%PPD, $contents);
  1622.  
  1623.     if (defined($location)) {
  1624.         if ($location =~ /[^\/]$/) { $location .= "/"; }
  1625.         $package = $location . $package . ".ppd";
  1626.     }
  1627.  
  1628.     if ($package =~ /^file:\/\/.*\|/i) {
  1629.         # $package is a local directory, let's avoid LWP by changing
  1630.         # it to a pathname.
  1631.         $package =~ s@^file://@@i;
  1632.         $package =~ s@^localhost/@@i;
  1633.         $package =~ s@\|@:@;
  1634.     }
  1635.  
  1636.     # full path to a file?
  1637.     if (-f $package) {
  1638.         local $/;
  1639.         unless (open (DATAFILE, $package)) {
  1640.             &Trace("getPPDfile: open of $package failed") if $options{'TRACE'};
  1641.             $PPM::PPMERR = "open of $package failed: $!\n";
  1642.             return;
  1643.         }
  1644.         $contents = <DATAFILE>;
  1645.         close(DATAFILE);
  1646.         $$PPDfile = $package;
  1647.     }
  1648.     # URL?
  1649.     elsif ($package =~ m@^...*://@i) {
  1650.         return unless ($contents = read_href("href" => $package, 
  1651.             "request" => 'GET'));
  1652.         $$PPDfile = $package;
  1653.     }
  1654.     # does the package have a <LOCATION> in $PPM::PPMdat?
  1655.     elsif ($installed_packages{$package}) {
  1656.         $location = $installed_packages{$package}{'LOCATION'};
  1657.         if ($location =~ /[^\/]$/) { $location .= "/"; }
  1658.         $$PPDfile = $location . $package . ".ppd";
  1659.         return %PPD if (%PPD = getPPDfile('package' => $$PPDfile, 
  1660.             'parsertype' => $parsertype));
  1661.         undef $$PPDfile;
  1662.     }
  1663.  
  1664.     # None of the above, search the repositories.
  1665.     unless ($PPDfile && $$PPDfile) {
  1666.         foreach (keys %repositories) {
  1667.             my $location = $repositories{$_}{'LOCATION'};
  1668.             if ($location =~ /[^\/]$/) { $location .= "/"; }
  1669.             $$PPDfile = $location . $package . ".ppd";
  1670.             return %PPD if (%PPD = getPPDfile('package' => $$PPDfile, 
  1671.                 'parsertype' => $parsertype, 'PPDfile' => \$$PPDfile));
  1672.             undef $$PPDfile;
  1673.         }
  1674.     # XXX should set $PPM::PPMERR?
  1675.         return unless $$PPDfile;
  1676.     }
  1677.  
  1678.     # take care of '&'
  1679.     $contents =~ s/&(?!\w+;)/&/go;
  1680.  
  1681.     my $parser = new XML::Parser( Style => 'Objects', Pkg => $parsertype );
  1682.     my @parsed;
  1683.     eval { @parsed = @{ $parser->parse( $contents ) } };
  1684.     if ($@) {
  1685.         &Trace("getPPDfile: content of $$PPDfile is not valid") if $options{'TRACE'};
  1686.         $PPM::PPMERR = "content of $$PPDfile is not valid: $!\n";
  1687.         return;
  1688.     }
  1689.  
  1690.     return if (!$parsed[0]->rvalidate( \&PPM::parse_err ));
  1691.  
  1692.     return %{$parsed[0]};
  1693. }
  1694.  
  1695. # Spits out the error from parsing, and sets our global error message
  1696. # accordingly.
  1697. sub parse_err
  1698. {
  1699.     &Trace("parse_err: @_") if $options{'TRACE'};
  1700.     warn @_;
  1701.     $PPM::PPMERR = 'Errors found while parsing document.';
  1702. }
  1703.  
  1704. # reads and parses the PPM data file $PPM::PPMdat.  Stores config information in
  1705. # $PPM_ver, $build_dir, %repositories, $CPU, $OS_VALUE, and $OS_VERSION.
  1706. # Stores information about individual packages in the hash %installed_packages.
  1707. sub read_config
  1708. {
  1709.     return if $init++;
  1710.  
  1711.     my %PPMConfig;
  1712.     return unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
  1713.         'parsertype' => 'PPM::XML::PPMConfig'));
  1714.  
  1715.     foreach my $elem (@{$PPMConfig{Kids}}) {
  1716.         my $subelem = ref $elem;
  1717.         $subelem =~ s/.*:://;
  1718.         next if ($subelem eq 'Characters');
  1719.  
  1720.         if ($subelem eq 'PPMVER') {
  1721.             # Get the value out of our _only_ character data element.
  1722.             $PPM_ver = $elem->{Kids}[0]{Text};
  1723.         }
  1724.         elsif ($subelem eq 'PPMPRECIOUS') {
  1725.             # Get the value out of our _only_ character data element.
  1726.             @required_packages = split( ';', $elem->{Kids}[0]{Text} );
  1727.         }
  1728.         elsif ($subelem eq 'PLATFORM') {
  1729.             # Get values out of our attributes
  1730.             $CPU        = $elem->{CPU};
  1731.             $OS_VALUE   = $elem->{OSVALUE};
  1732.             $OS_VERSION = $elem->{OSVERSION};
  1733.             $LANGUAGE   = $elem->{LANGUAGE};
  1734.         }
  1735.         elsif ($subelem eq 'REPOSITORY') {
  1736.             # Get a repository out of the element attributes
  1737.             my ($name);
  1738.             $name = $elem->{NAME};
  1739.             $repositories{ $name }{'LOCATION'} = $elem->{LOCATION};
  1740.             $repositories{ $name }{'USERNAME'} = $elem->{USERNAME};
  1741.             $repositories{ $name }{'PASSWORD'} = $elem->{PASSWORD};
  1742.             $repositories{ $name }{'SUMMARYFILE'} = $elem->{SUMMARYFILE};
  1743.         }
  1744.         elsif ($subelem eq 'OPTIONS') {
  1745.             # Get our options out of the element attributes
  1746.             #
  1747.             # Previous versions of the ppm.xml had "Yes/No" values
  1748.             # for some of these options.  Change these to "1/0" if we
  1749.             # encounter them.
  1750.             $options{'IGNORECASE'} =
  1751.                 ($elem->{IGNORECASE} && $elem->{IGNORECASE} ne 'No');
  1752.             $options{'CLEAN'} = ($elem->{CLEAN} && $elem->{CLEAN} ne 'No');
  1753.             $options{'CONFIRM'} =
  1754.                 ($elem->{CONFIRM} && $elem->{CONFIRM} ne 'No');
  1755.             $options{'DOWNLOADSTATUS'} = 
  1756.                 defined $elem->{DOWNLOADSTATUS} ? $elem->{DOWNLOADSTATUS} : "0";
  1757.             $options{'FORCE_INSTALL'} =
  1758.                 ($elem->{FORCEINSTALL} && $elem->{FORCEINSTALL} ne 'No');
  1759.             $options{'ROOT'} = $elem->{ROOT};
  1760.             $options{'MORE'} = $elem->{MORE};
  1761.             $options{'TRACE'} = defined $elem->{TRACE} ? $elem->{TRACE} : "0";
  1762.             $options{'TRACEFILE'} =
  1763.                 defined $elem->{TRACEFILE} ? $elem->{TRACEFILE} : "PPM.LOG";
  1764.             $options{'VERBOSE'} =
  1765.                 defined $elem->{VERBOSE} ? $elem->{VERBOSE} : "1";
  1766.  
  1767.             $options{'BUILDDIR'} = $elem->{BUILDDIR} || File::Spec->tmpdir();
  1768.             # Strip trailing separator
  1769.             my $chr = substr( $options{'BUILDDIR'}, -1, 1 );
  1770.             chop $options{'BUILDDIR'} if ($chr eq '/' || $chr eq '\\');
  1771.             if ($options{'TRACE'} && !$TraceStarted) {
  1772.                 $options{'TRACEFILE'} = "PPM.log" if (!defined $options{'TRACEFILE'});
  1773.                 open(PPMTRACE, ">>$options{'TRACEFILE'}");
  1774.                 my $oldfh = select(PPMTRACE);
  1775.                 $| = 1;
  1776.                 select($oldfh);
  1777.                 &Trace("starting up...");
  1778.                 $TraceStarted = 1;
  1779.             }
  1780.         }
  1781.         elsif ($subelem eq 'PACKAGE') {
  1782.             # Get our package name out of our attributes
  1783.             my $pkg = $elem->{NAME};
  1784.  
  1785.             # Gather the information on this package from the child elements.
  1786.             my ($loc, $instdate, $root, $packlist, $ppd);
  1787.             foreach my $child (@{$elem->{Kids}}) {
  1788.                 my $child_type = ref $child;
  1789.                 $child_type =~ s/.*:://;
  1790.                 next if ($child_type eq 'Characters');
  1791.  
  1792.                 if ($child_type eq 'LOCATION')
  1793.                     { $loc = $child->{Kids}[0]{Text}; }
  1794.                 elsif ($child_type eq 'INSTDATE')
  1795.                     { $instdate = $child->{Kids}[0]{Text}; }
  1796.                 elsif ($child_type eq 'INSTROOT')
  1797.                     { $root = $child->{Kids}[0]{Text}; }
  1798.                 elsif ($child_type eq 'INSTPACKLIST')
  1799.                     { $packlist = $child->{Kids}[0]{Text}; }
  1800.                 elsif ($child_type eq 'INSTPPD')
  1801.                 {
  1802.                     # Find the SOFTPKG inside here and hang onto it
  1803.                     my $tmp;
  1804.                     foreach $tmp (@{$child->{Kids}})
  1805.                     {
  1806.                         if ((ref $tmp) =~ /::SOFTPKG$/o)
  1807.                             { $ppd = $tmp; }
  1808.                     }
  1809.                 }
  1810.                 else
  1811.                 {
  1812.                     die "Unknown element inside of $pkg PACKAGE; $child";
  1813.                 }
  1814.             }
  1815.  
  1816.             my %package_details = ( LOCATION      => $loc,
  1817.                                     INST_DATE     => $instdate,
  1818.                                     INST_ROOT     => $root,
  1819.                                     INST_PACKLIST => $packlist,
  1820.                                     INST_PPD      => $ppd);
  1821.             $installed_packages{$pkg} = \%package_details;
  1822.         }
  1823.         else
  1824.         {
  1825.             die "Unknown element found in PPD_DAT file; $subelem";
  1826.         }
  1827.     }
  1828.     if ($Debug & 1) {
  1829.         print "This is ppm, version $PPM_ver.\nRepository locations:\n";
  1830.         foreach (keys %repositories) {
  1831.             print "\t$_: $repositories{$_}{'LOCATION'}\n"
  1832.         }
  1833.         print "Platform is $OS_VALUE version $OS_VERSION on a $CPU CPU.\n";
  1834.         print "Packages will be built in $options{'BUILDDIR'}\n";
  1835.         print "Commands will " . ($options{'CONFIRM'} ? "" : "not ") .
  1836.             "be confirmed.\n";
  1837.         print "Temporary files will " . ($options{'CLEAN'} ? "" : "not ") .
  1838.             "be deleted.\n";
  1839.         print "Installations will " . ($options{'FORCE_INSTALL'} ? "" : "not ")
  1840.             . "continue if a dependency cannot be installed.\n";
  1841.         print "Screens will " . ($options{'MORE'} > 0 ?
  1842.             "pause after each $options{'MORE'} lines.\n" :
  1843.                 "not pause after the screen is full.\n");
  1844.         print "Tracing info will " . ($options{'TRACE'} > 0 ?
  1845.             "be written to $options{'TRACEFILE'}.\n" : "not be written.\n");
  1846.         print "Case-" . ($options{'IGNORECASE'} ? "in" : "") .
  1847.             "sensitive searches will be performed.\n";
  1848.  
  1849.         foreach my $pkg (keys %installed_packages) {
  1850.             print "\nFound installed package $pkg, " .
  1851.             "installed on $installed_packages{$pkg}{INST_DATE}\n" .
  1852.             "in directory root $installed_packages{$pkg}{INST_ROOT} " .
  1853.             "from $installed_packages{$pkg}{'LOCATION'}.\n\n";
  1854.         }
  1855.     }
  1856. }
  1857.  
  1858. sub Trace
  1859. {
  1860.     print PPMTRACE "$0: @_ at ",  scalar localtime(), "\n";
  1861. }
  1862.  
  1863. 1;
  1864.  
  1865. __END__
  1866.  
  1867. =head1 NAME
  1868.  
  1869. ppm - PPM (Perl Package Management)
  1870.  
  1871. =head1 SYNOPSIS
  1872.  
  1873.  use PPM;
  1874.  
  1875.  PPM::InstallPackage("package" => $package, "location" => $location, "root" => $root);
  1876.  PPM::RemovePackage("package" => $package, "force" => $force);
  1877.  PPM::VerifyPackage("package" => $package, "location" => $location, "upgrade" => $upgrade);
  1878.  PPM::QueryInstalledPackages("searchRE" => $searchRE, "searchtag" => $searchtag, "ignorecase" => $ignorecase);
  1879.  PPM::InstalledPackageProperties();
  1880.  
  1881.  PPM::ListOfRepositories();
  1882.  PPM::RemoveRepository("repository" => $repository, "save" => $save);
  1883.  PPM::AddRepository("repository" => $repository, "location" => $location, "save" => $save);
  1884.  PPM::RepositoryPackages("location" => $location);
  1885.  PPM::RepositoryPackageProperties("package" => $package, "location" => $location);
  1886.  PPM::RepositorySummary("location" => $location);
  1887.  
  1888.  PPM::GetPPMOptions();
  1889.  PPM::SetPPMOptions("options" => %options, "save" => $save);
  1890.  
  1891. =head1 DESCRIPTION
  1892.  
  1893. PPM is a group of functions intended to simplify the tasks of locating,
  1894. installing, upgrading and removing software 'packages'.  It can determine
  1895. if the most recent version of a software package is installed on a system,
  1896. and can install or upgrade that package from a local or remote host.
  1897.  
  1898. PPM uses files containing a modified form of the Open Software Distribution
  1899. (OSD) specification for information about software packages.
  1900. These description files, which are written in Extensible Markup
  1901. Language (XML) code, are referred to as 'PPD' files.  Information about
  1902. OSD can be found at the W3C web site (at the time of this writing,
  1903. http://www.w3.org/TR/NOTE-OSD.html).  The modifications to OSD used by PPM
  1904. are documented in PPM::ppd.
  1905.  
  1906. PPD files for packages are generated from POD files using the pod2ppd
  1907. command.
  1908.  
  1909. =head1 USAGE
  1910.  
  1911. =over 4
  1912.  
  1913. =item  PPM::InstallPackage("package" => $package, "location" => $location, "root" => $root);
  1914.  
  1915. Installs the specified package onto the local system.  'package' may
  1916. be a simple package name ('foo'), a pathname (P:\PACKAGES\FOO.PPD) or
  1917. a URL (HTTP://www.ActiveState.com/packages/foo.ppd).  In the case of a
  1918. simple package name, the function will look for the package's PPD file
  1919. at 'location', if provided; otherwise, it will use information stored
  1920. in the PPM data file (see 'Files' section below) to locate the PPD file
  1921. for the requested package.  The package's files will be installed under
  1922. the directory specified in 'root'; if not specified the default value
  1923. of 'root' will be used.
  1924.  
  1925. The function uses the values stored in the PPM data file to determine the
  1926. local operating system, operating system version and CPU type.  If the PPD
  1927. for this package contains implementations for different platforms, these
  1928. values will be used to determine which one is installed.
  1929.  
  1930. InstallPackage() updates the PPM data file with information about the package
  1931. installation. It stores a copy of the PPD used for installation, as well
  1932. as the location from which this PPD was obtained.  This location will
  1933. become the default PPD location for this package.
  1934.  
  1935. During an installation, the following actions are performed:
  1936.  
  1937.     - the PPD file for the package is read
  1938.     - a directory for this package is created in the directory specified in
  1939.       <BUILDDIR> in the PPM data file.
  1940.     - the file specified with the <CODEBASE> tag in the PPD file is
  1941.       retrieved/copied into the directory created above.
  1942.     - the package is unarchived in the directory created for this package
  1943.     - individual files from the archive are installed in the appropriate
  1944.       directories of the local Perl installation.
  1945.     - perllocal.pod is updated with the install information.
  1946.     - if provided, the <INSTALL> script from the PPD is executed in the
  1947.       directory created above.
  1948.     - information about the installation is stored in the PPM data file.
  1949.  
  1950. =item PPM::RemovePackage("package" => $package, "force" => $force)
  1951.  
  1952. Removes the specified package from the system.  Reads the package's PPD
  1953. (stored during installation) for removal details.  If 'force' is
  1954. specified, even a package required by PPM will be removed (useful
  1955. when installing an upgrade).
  1956.  
  1957. =item PPM::VerifyPackage("package" => $package, "location" => $location, "upgrade" => $upgrade)
  1958.  
  1959. Reads a PPD file for 'package', and compares the currently installed
  1960. version of 'package' to the version available according to the PPD.
  1961. The PPD file is expected to be on a local directory or remote site
  1962. specified either in the PPM data file or in the 'location' argument.
  1963. The 'location' argument may be a directory location or a URL.
  1964. The 'upgrade' argument forces an upgrade if the installed package is
  1965. not up-to-date.
  1966.  
  1967. The PPD file for each package will initially be searched for at
  1968. 'location', and if not found will then be searched for using the
  1969. locations specified in the PPM data file.
  1970.  
  1971. =item  PPM::QueryInstalledPackages("searchRE" => $searchRE, "searchtag" => $searchtag, "ignorecase" => $ignorecase);
  1972.  
  1973. Returns a hash containing information about all installed packages.
  1974. By default, a list of all installed packages is returned.  If a regular
  1975. expression 'searchRE' is specified, only packages matching it are
  1976. returned.  If 'searchtag' is specified, the pattern match is applied
  1977. to the appropriate tag (e.g., ABSTRACT).
  1978.  
  1979. The data comes from the PPM data file, which contains installation
  1980. information about each installed package.
  1981.  
  1982. =item PPM::InstalledPackageProperties();
  1983.  
  1984. Returns a hash with package names as keys, and package properties as
  1985. attributes.
  1986.  
  1987. =item PPM::RepositoryPackages("location" => $location);
  1988.  
  1989. Returns a hash, with 'location' being the key, and arrays of all packages
  1990. with package description (PPD) files available at 'location' as its
  1991. elements.  'location' may be either a remote address or a directory path.
  1992. If 'location' is not specified, the default location as specified in
  1993. the PPM data file will be used.
  1994.  
  1995. =item PPM::ListOfRepositories();
  1996.  
  1997. Returns a hash containing the name of the repository and its location.
  1998. These repositories will be searched if an explicit location is not
  1999. provided in any function needing to locate a PPD.
  2000.  
  2001. =item PPM::RemoveRepository("repository" => $repository, "save" => $save);
  2002.  
  2003. Removes the repository named 'repository' from the list of available
  2004. repositories.  If 'save' is not specified, the change is for the current
  2005. session only.
  2006.  
  2007. =item PPM::AddRepository("repository" => $repository, "location" => $location, "save" => $save);
  2008.  
  2009. Adds the repository named 'repository' to the list of available repositories.
  2010. If 'save' is not specified, the change is for the current session only.
  2011.  
  2012. =item PPM::RepositoryPackageProperties("package" => $package, "location" => $location);
  2013.  
  2014. Reads the PPD file for 'package', from 'location' or the default repository,
  2015. and returns a hash with keys being the various tags from the PPD (e.g.
  2016. 'ABSTRACT', 'AUTHOR', etc.).
  2017.  
  2018. =item PPM::RepositorySummary("location" => $location);
  2019.  
  2020. Attempts to retrieve the summary file associated with the specified repository,
  2021. or from all repositories if 'location' is not specified.  The return value
  2022. is a hash with the key being the repository, and the data being another
  2023. hash of package name keys, and package detail data.
  2024.  
  2025. =item PPM::GetPPMOptions();
  2026.  
  2027. Returns a hash containing values for all PPM internal options ('IGNORECASE',
  2028. 'CLEAN', 'CONFIRM', 'ROOT', 'BUILDDIR', 'DOWNLOADSTATUS').
  2029.  
  2030. =item PPM::SetPPMOptions("options" => %options, "save" => $save);
  2031.  
  2032. Sets internal PPM options as specified in the 'options' hash, which is
  2033. expected to be the hash previously returned by a call to GetPPMOptions().
  2034.  
  2035. =back
  2036.  
  2037. =head1 EXAMPLES
  2038.  
  2039. =over 4
  2040.  
  2041. =item PPM::AddRepository("repository" => 'ActiveState', "location" => "http://www.ActiveState.com/packages", "save" => 1);
  2042.  
  2043. Adds a repository to the list of available repositories, and saves it in
  2044. the PPM options file.
  2045.  
  2046. =item PPM::InstallPackage("package" => 'http://www.ActiveState.com/packages/foo.ppd');
  2047.  
  2048. Installs the software package 'foo' based on the information in the PPD
  2049. obtained from the specified URL.
  2050.  
  2051. =item PPM::VerifyPackage("package" => 'foo', "upgrade" => true)
  2052.  
  2053. Compares the currently installed version of the software package 'foo' to
  2054. the one available according to the PPD obtained from the package-specific
  2055. location provided in the PPM data file, and upgrades to a newer
  2056. version if available.  If a location for this specific package is not
  2057. given in PPM data file, a default location is searched.
  2058.  
  2059. =item PPM::VerifyPackage("package" => 'foo', "location" => 'P:\PACKAGES', "upgrade" => true);
  2060.  
  2061. Compares the currently installed version of the software package 'foo'
  2062. to the one available according to the PPD obtained from the specified
  2063. directory, and upgrades to a newer version if available.
  2064.  
  2065. =item PPM::VerifyPackage("package" => 'PerlDB');
  2066.  
  2067. Verifies that package 'PerlDB' is up to date, using package locations specified
  2068. in the PPM data file.
  2069.  
  2070. =item PPM::RepositoryPackages("location" => http://www.ActiveState.com/packages);
  2071.  
  2072. Returns a hash keyed on 'location', with its elements being an array of
  2073. packages with PPD files available at the specified location.
  2074.  
  2075. =item %opts = PPM::GetPPMOptions();
  2076.  
  2077. =item $options{'CONFIRM'} = '0';
  2078.  
  2079. =item PPM::SetPPMOptions("options" => \%opts, "save" => 1);
  2080.  
  2081. Sets and saves the value of the option 'CONFIRM' to '0'.
  2082.  
  2083. =back
  2084.  
  2085. =head1 ENVIRONMENT VARIABLES
  2086.  
  2087. =over 4
  2088.  
  2089. =item HTTP_proxy
  2090.  
  2091. If the environment variable 'HTTP_proxy' is set, then it will
  2092. be used as the address of a proxy for accessing the Internet.
  2093. If the environment variables 'HTTP_proxy_user' and 'HTTP_proxy_pass'
  2094. are set, they will be used as the login and password for the
  2095. proxy server.  If a proxy requires a certain User-Agent value
  2096. (e.g. "Mozilla/5.0"), this can be set using the 'HTTP_proxy_agent'
  2097. environment variable.
  2098.  
  2099. =back
  2100.  
  2101. =head1 FILES
  2102.  
  2103. =over 4
  2104.  
  2105. =item package.ppd
  2106.  
  2107. A description of a software package, in Perl Package Distribution (PPD)
  2108. format.  More information on this file format can be found in L<PPM::XML::PPD>.
  2109. PPM stores a copy of the PPD it uses to install or upgrade any software
  2110. package.
  2111.  
  2112. =item ppm.xml - PPM data file.
  2113.  
  2114. The XML format file in which PPM stores configuration and package
  2115. installation information.  This file is created when PPM is installed,
  2116. and under normal circumstances should never require modification other
  2117. than by PPM itself.  For more information on this file, refer to
  2118. L<PPM::XML::PPMConfig>.
  2119.  
  2120. =back
  2121.  
  2122. =head1 AUTHOR
  2123.  
  2124. Murray Nesbitt
  2125.  
  2126. =head1 SEE ALSO
  2127.  
  2128. L<PPM::XML::PPMConfig>
  2129. .
  2130.  
  2131. =cut
  2132.  
  2133.