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