PageRenderTime 179ms CodeModel.GetById 3ms app.highlight 162ms RepoModel.GetById 1ms app.codeStats 0ms

/IronPython_Main/Runtime/Tests/LinqDlrTests/testenv/perl/site/lib/PPM.pm

#
Perl | 2093 lines | 1673 code | 232 blank | 188 comment | 291 complexity | dbc4590115411b0e1201518335b435ca MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1package PPM;
   2require 5.004;
   3require Exporter;
   4
   5@ISA = qw(Exporter);
   6@EXPORT = qw(PPMdat PPMERR InstalledPackageProperties ListOfRepositories
   7    RemoveRepository AddRepository GetPPMOptions SetPPMOptions InstallPackage
   8    RemovePackage VerifyPackage UpgradePackage RepositoryPackages
   9    RepositoryPackageProperties QueryInstalledPackages
  10    RepositorySummary ServerSearch PPMShell);
  11
  12use LWP::UserAgent;
  13use LWP::Simple;
  14
  15use File::Basename;
  16use File::Copy;
  17use File::Path;
  18use ExtUtils::Install;
  19use Cwd;
  20use Config;
  21use PPM::RelocPerl;
  22use SOAP::Lite;
  23
  24use PPM::XML::PPD;
  25use PPM::XML::PPMConfig;
  26use XML::Parser;
  27use Archive::Tar;
  28
  29use strict;
  30
  31my $useDocTools;  # Generate HTML documentation after installing a package
  32
  33BEGIN {
  34    if (eval "require ActivePerl::DocTools") {
  35        import ActivePerl::DocTools;
  36        $useDocTools++;
  37    }
  38}
  39
  40#set Debug to 1 to debug PPMdat file reading
  41#             2 to debug parsing PPDs
  42#
  43# values may be or'ed together.
  44#
  45my $Debug = 0;
  46
  47my ($PPMERR, $PPM_ver, $CPU, $OS_VALUE, $OS_VERSION, $LANGUAGE);
  48
  49# options from data file.
  50my %options;
  51
  52my $TraceStarted = 0;
  53
  54# true if we're running from ppm, as opposed to VPM, etc.
  55my $PPMShell;
  56
  57my %repositories;
  58my %cached_ppd_list;
  59
  60# Keys for this hash are package names.  It is filled in by a successful
  61# call to read_config().  Each package is a hash with the following keys:
  62# LOCATION, INST_DATE, INST_ROOT, INST_PACKLIST and INST_PPD.
  63my %installed_packages = ();
  64
  65# Keys for this hash are CODEBASE, INSTALL_HREF, INSTALL_EXEC,
  66# INSTALL_SCRIPT, NAME, VERSION, TITLE, ABSTRACT, LICENSE, AUTHOR,
  67# UNINSTALL_HREF, UNINSTALL_EXEC, UNINSTALL_SCRIPT, PERLCORE_VER and DEPEND.
  68# It is filled in after a successful call to parsePPD().
  69my %current_package = ();
  70my @current_package_stack;
  71
  72# this may get overridden by the config file.
  73my @required_packages = qw(PPM SOAP-Lite libnet Archive-Tar Compress-Zlib
  74    libwww-perl XML-Parser);
  75
  76# Packages that can't be upgraded on Win9x
  77my @Win9x_denied = qw(xml-parser compress-zlib);
  78my %Win9x_denied;
  79@Win9x_denied{@Win9x_denied} = ();
  80
  81# ppm.xml location is in the environment variable 'PPM_DAT', else it is in
  82# [Perl]/site/lib, else it is in the same place as this script.
  83my ($basename, $path) = fileparse($0);
  84
  85if (defined $ENV{'PPM_DAT'} && -f $ENV{'PPM_DAT'})
  86{
  87    $PPM::PPMdat = $ENV{'PPM_DAT'};
  88}
  89elsif (-f "$Config{'installsitelib'}/ppm.xml")
  90{
  91    $PPM::PPMdat = "$Config{'installsitelib'}/ppm.xml";
  92}
  93elsif (-f "$Config{'installprivlib'}/ppm.xml")
  94{
  95    $PPM::PPMdat = "$Config{'installprivlib'}/ppm.xml";
  96}
  97elsif (-f $path . "/ppm.xml")
  98{
  99    $PPM::PPMdat = $path . $PPM::PPMdat;
 100}
 101else
 102{
 103    &Trace("Failed to load PPM_DAT file") if $options{'TRACE'};
 104    print "Failed to load PPM_DAT file\n";
 105    return -1;
 106}
 107
 108&Trace("Using config file: $PPM::PPMdat") if $options{'TRACE'};
 109
 110my $init = 0;
 111chmod(0644, $PPM::PPMdat);
 112
 113#
 114# Exported subs
 115#
 116
 117sub InstalledPackageProperties
 118{
 119    my %ret_hash;
 120    read_config();
 121    foreach (keys %installed_packages) {
 122        parsePPD(%{ $installed_packages{$_}{'INST_PPD'} } );
 123        $ret_hash{$_}{'NAME'} = $_;
 124        $ret_hash{$_}{'DATE'} = $installed_packages{$_}{'INST_DATE'};
 125        $ret_hash{$_}{'TITLE'} = $current_package{'TITLE'};
 126        $ret_hash{$_}{'AUTHOR'} = $current_package{'AUTHOR'};
 127        $ret_hash{$_}{'VERSION'} = $current_package{'VERSION'};
 128        $ret_hash{$_}{'ABSTRACT'} = $current_package{'ABSTRACT'};
 129        $ret_hash{$_}{'PERLCORE_VER'} = $current_package{'PERLCORE_VER'};
 130        foreach my $dep (keys %{$current_package{'DEPEND'}}) {
 131            push @{$ret_hash{$_}{'DEPEND'}}, $dep;
 132        }
 133    }
 134    return %ret_hash;
 135}
 136
 137sub ListOfRepositories
 138{
 139    my %reps;
 140    read_config();
 141    foreach (keys %repositories) {
 142        $reps{$_} = $repositories{$_}{'LOCATION'};
 143    }
 144    return %reps;
 145}
 146
 147sub RemoveRepository
 148{
 149    my %argv = @_;
 150    my $repository = $argv{'repository'};
 151    my $save = $argv{'save'};
 152    read_config();
 153    foreach (keys %repositories) {
 154        if ($_ =~ /^\Q$repository\E$/) {
 155            &Trace("Removed repository $repositories{$repository}") 
 156                if $options{'TRACE'};
 157            delete $repositories{$repository};
 158            last;
 159        }
 160    }
 161    save_options() if $save;
 162}
 163
 164sub AddRepository
 165{
 166    my %argv = @_;
 167    my $repository = $argv{'repository'};
 168    my $save = $argv{'save'};
 169    my $location = $argv{'location'};
 170    my $username = $argv{'username'};
 171    my $password = $argv{'password'};
 172    read_config();
 173    $repositories{$repository}{'LOCATION'} = $location;
 174    $repositories{$repository}{'USERNAME'} = $username if defined $username;
 175    $repositories{$repository}{'PASSWORD'} = $password if defined $password;
 176    &Trace("Added repository $location") if $options{'TRACE'};
 177    save_options() if $save;
 178}
 179
 180sub GetPPMOptions
 181{
 182    read_config();
 183    return %options;
 184}
 185
 186sub SetPPMOptions
 187{
 188    my %argv = @_;
 189    %options = %{$argv{'options'}};
 190    save_options() if $argv{'save'};
 191}
 192
 193sub UpgradePackage
 194{
 195    my %argv = @_;
 196    my $package = $argv{'package'};
 197    my $location = $argv{'location'};
 198    return VerifyPackage("package" => $package, "location" => $location,
 199        "upgrade" => 1);
 200}
 201
 202# Returns 1 on success, 0 and sets $PPMERR on failure.
 203sub InstallPackage
 204{
 205    my %argv = @_;
 206    my $package = $argv{'package'};
 207    my $location = $argv{'location'};
 208    my $root = $argv{'root'} || $options{'ROOT'} || undef;
 209    my ($PPDfile, %PPD);
 210
 211    read_config();
 212
 213    if (!defined($package) && -d "blib" && -f "Makefile") {
 214        unless (open MAKEFILE, "< Makefile") {
 215            $PPM::PPMERR = "Couldn't open Makefile for reading: $!";
 216            return 0;
 217        }
 218        while (<MAKEFILE>) {
 219            if (/^DISTNAME\s*=\s*(\S+)/) {
 220                $package = $1;
 221                $PPDfile = "$1.ppd";
 222                last;
 223            }
 224        }
 225        close MAKEFILE;
 226        unless (defined $PPDfile) {
 227            $PPM::PPMERR = "Couldn't determine local package name";
 228            return 0;
 229        }
 230        system("$Config{make} ppd");
 231	# XXX should set $PPM::PPMERR?
 232        return 0 unless (%PPD = getPPDfile('package' => $PPDfile));
 233        parsePPD(%PPD);
 234        $options{'CLEAN'} = 0;
 235        goto InstallBlib;
 236    }
 237
 238    unless (%PPD = getPPDfile('package' => $package, 
 239            'location' => $location, 'PPDfile' => \$PPDfile)) {
 240        &Trace("Could not locate a PPD file for package $package")
 241            if $options{'TRACE'};
 242        $PPM::PPMERR = "Could not locate a PPD file for package $package";
 243        return 0;
 244    }
 245    if ($Config{'osname'} eq 'MSWin32' &&
 246        !&Win32::IsWinNT && exists $Win9x_denied{lc($package)}) {
 247        $PPM::PPMERR = "Package '$package' cannot be installed with PPM on Win9x--see http://www.ActiveState.com/ppm for details";
 248        return 0;
 249    }
 250
 251    parsePPD(%PPD);
 252    if (!$current_package{'CODEBASE'} && !$current_package{'INSTALL_HREF'}) {
 253        &Trace("Read a PPD for '$package', but it is not intended for this build of Perl ($Config{archname})")
 254            if $options{'TRACE'};
 255        $PPM::PPMERR = "Read a PPD for '$package', but it is not intended for this build of Perl ($Config{archname})";
 256        return 0;
 257    }
 258
 259    if (defined $current_package{'DEPEND'}) {
 260        push(@current_package_stack, [%current_package]);
 261        foreach my $dep (keys %{$current_package{'DEPEND'}}) {
 262            # Has PPM already installed it?
 263            unless ($installed_packages{$dep}) {
 264                # Has *anybody* installed it, or is it part of core Perl?
 265                my $p = $dep;
 266                $p =~ s@-@/@g;
 267                my $found = grep -f, map "$_/$p.pm", @INC;
 268                unless ($found) {
 269                    &Trace("Installing dependency '$dep'...")
 270                        if $options{'TRACE'};
 271                    unless (!InstallPackage("package" => $dep,
 272                        "location" => $location)) {
 273                            &Trace("Error installing dependency: $PPM::PPMERR")
 274                                if $options{'TRACE'};
 275                            $PPM::PPMERR = "Error installing dependency: $PPM::PPMERR\n";
 276                        return 0 unless ($options{'FORCE_INSTALL'});
 277                    }
 278                }
 279            }
 280            # make sure minimum version is installed, if necessary
 281            elsif (defined $current_package{'DEPEND'}{$dep}) {
 282                my @comp = split (',', $current_package{'DEPEND'}{$dep});
 283                # parsePPD fills in %current_package
 284                push(@current_package_stack, [%current_package]);
 285                parsePPD(%{$installed_packages{$dep}{'INST_PPD'}});
 286                my @inst = split (',', $current_package{'VERSION'});
 287                foreach(0..3) {
 288                    if ($comp[$_] > $inst[$_]) {
 289                        VerifyPackage("package" => $dep, "upgrade" => 1);
 290                        last;
 291                    }
 292                    last if ($comp[$_] < $inst[$_]);
 293                }
 294                %current_package = @{pop @current_package_stack};
 295            }
 296        }
 297        %current_package = @{pop @current_package_stack};
 298    }
 299    my ($basename, $path) = fileparse($PPDfile);
 300    # strip the trailing path separator
 301    my $chr = substr($path, -1, 1);
 302    chop $path if ($chr eq '/' || $chr eq '\\');
 303    if ($path =~ /^file:\/\/.*\|/i) {
 304        # $path is a local directory, let's avoid LWP by changing
 305        # it to a pathname.
 306        $path =~ s@^file://@@i;
 307        $path =~ s@^localhost/@@i;
 308        $path =~ s@\|@:@;
 309    }
 310
 311    # get the code and put it in build_dir
 312    my $install_dir = "$options{'BUILDDIR'}/$current_package{'NAME'}-$$";
 313    File::Path::rmtree($install_dir,0,0);
 314    unless (-d $install_dir || File::Path::mkpath($install_dir, 0, 0755)) {
 315        &Trace("Could not create $install_dir: $!") if $options{'TRACE'};
 316        $PPM::PPMERR = "Could not create $install_dir: $!";
 317        return 0;
 318    }
 319    $basename = fileparse($current_package{'CODEBASE'});
 320    # CODEBASE is a URL
 321    if ($current_package{'CODEBASE'} =~ m@^...*://@i) {
 322        return 0 unless read_href('href' => "$current_package{'CODEBASE'}",
 323            'target' => "$install_dir/$basename", 'request' => "GET",
 324            'progress' => 1);
 325    }
 326    # CODEBASE is a full pathname
 327    elsif (-f $current_package{'CODEBASE'}) {
 328        &Trace("Copying $current_package{'CODEBASE'} to $install_dir/$basename")
 329            if $options{'TRACE'} > 1;
 330        copy($current_package{'CODEBASE'}, "$install_dir/$basename");
 331    }
 332    # CODEBASE is relative to the directory location of the PPD
 333    elsif (-f "$path/$current_package{'CODEBASE'}") {
 334        &Trace("Copying $path/$current_package{'CODEBASE'} to $install_dir/$basename") if $options{'TRACE'} > 1;
 335        copy("$path/$current_package{'CODEBASE'}", "$install_dir/$basename");
 336    }
 337    # CODEBASE is relative to the URL location of the PPD
 338    else {
 339        return 0 unless read_href('target' => "$install_dir/$basename",
 340            'href' => "$path/$current_package{'CODEBASE'}",
 341            'request' => 'GET', 'progress' => 1);
 342    }
 343
 344    my $cwd = getcwd();
 345    $cwd .= "/" if $cwd =~ /[a-z]:$/i;
 346    chdir($install_dir);
 347
 348    my $tar;
 349    if ($basename =~ /\.gz$/i) {
 350        $tar = Archive::Tar->new($basename,1);
 351    }
 352    else {
 353        $tar = Archive::Tar->new($basename,0);
 354    }
 355    $tar->extract($tar->list_files);
 356    $basename =~ /(.*).tar/i;
 357    chdir($1);
 358    RelocPerl('.') if ($Config{'osname'} ne 'MSWin32');
 359
 360  InstallBlib:
 361    my $inst_archlib = $Config{installsitearch};
 362    my $inst_root = $Config{prefix};
 363    my $packlist = MM->catfile("$Config{installsitearch}/auto",
 364        split(/-/, $current_package{'NAME'}), ".packlist");
 365
 366    # copied from ExtUtils::Install
 367    my $INST_LIB = MM->catdir(MM->curdir,"blib","lib");
 368    my $INST_ARCHLIB = MM->catdir(MM->curdir,"blib","arch");
 369    my $INST_BIN = MM->catdir(MM->curdir,'blib','bin');
 370    my $INST_SCRIPT = MM->catdir(MM->curdir,'blib','script');
 371    my $INST_MAN1DIR = MM->catdir(MM->curdir,'blib','man1');
 372    my $INST_MAN3DIR = MM->catdir(MM->curdir,'blib','man3');
 373    my $INST_HTMLDIR = MM->catdir(MM->curdir,'blib','html');
 374    my $INST_HTMLHELPDIR = MM->catdir(MM->curdir,'blib','htmlhelp');
 375
 376    my $inst_script = $Config{installscript};
 377    my $inst_man1dir = $Config{installman1dir};
 378    my $inst_man3dir = $Config{installman3dir};
 379    my $inst_bin = $Config{installbin};
 380    my $inst_htmldir = $Config{installhtmldir};
 381    my $inst_htmlhelpdir = $Config{installhtmlhelpdir};
 382    my $inst_lib = $Config{installsitelib};
 383
 384    if (defined $root && $root !~ /^\Q$inst_root\E$/i) {
 385        $packlist =~ s/\Q$inst_root/$root\E/i;
 386        $inst_lib =~ s/\Q$inst_root/$root\E/i;
 387        $inst_archlib =~ s/\Q$inst_root/$root\E/i;
 388        $inst_bin =~ s/\Q$inst_root/$root\E/i;
 389        $inst_script =~ s/\Q$inst_root/$root\E/i;
 390        $inst_man1dir =~ s/\Q$inst_root/$root\E/i;
 391        $inst_man3dir =~ s/\Q$inst_root/$root\E/i;
 392        $inst_root = $root;
 393    }
 394    
 395    while (1) {
 396        my $cwd = getcwd();
 397        $cwd .= "/" if $cwd =~ /[a-z]:$/i;
 398        &Trace("Calling ExtUtils::Install::install") if $options{'TRACE'} > 1;
 399        eval {
 400            ExtUtils::Install::install({
 401            "read" => $packlist, "write" => $packlist,
 402            $INST_LIB => $inst_lib, $INST_ARCHLIB => $inst_archlib,
 403            $INST_BIN => $inst_bin, $INST_SCRIPT => $inst_script,
 404            $INST_MAN1DIR => $inst_man1dir, $INST_MAN3DIR => $inst_man3dir,
 405            $INST_HTMLDIR => $inst_htmldir,
 406            $INST_HTMLHELPDIR => $inst_htmlhelpdir},0,0,0);
 407        };
 408        # install might have croaked in another directory
 409        chdir($cwd);
 410        # Can't remove some DLLs, but we can rename them and try again.
 411        if ($@ && $@ =~ /Cannot forceunlink (\S+)/) {
 412            &Trace("$@...attempting rename") if $options{'TRACE'};
 413            my $oldname = $1;
 414            $oldname =~ s/:$//;
 415            my $newname = $oldname . "." . time();
 416            unless (rename($oldname, $newname)) {
 417                &Trace("$!") if $options{'TRACE'};
 418                $PPM::PPMERR = "$!";
 419                return 0;
 420            }
 421        }
 422        # Some other error
 423        elsif($@) {
 424            &Trace("$@") if $options{'TRACE'};
 425            $PPM::PPMERR = $@;
 426            return 0;
 427        }
 428        else { last; }
 429    }
 430
 431    #rebuild the html TOC
 432    Trace("Calling ActivePerl::DocTools::WriteTOC()") if $options{'TRACE'} > 1;
 433    ActivePerl::DocTools::WriteTOC() if $useDocTools;
 434
 435    if (defined $current_package{'INSTALL_SCRIPT'}) {
 436        run_script("script" => $current_package{'INSTALL_SCRIPT'},
 437                   "scriptHREF" => $current_package{'INSTALL_HREF'},
 438                   "exec" => $current_package{'INSTALL_EXEC'},
 439                   "inst_root" => $inst_root, "inst_archlib" => $inst_archlib);
 440    }
 441
 442    chdir($cwd);
 443
 444# ask to store this location as default for this package?
 445    PPMdat_add_package($path, $packlist, $inst_root);
 446    # if 'install.ppm' exists, don't remove; system()
 447    # has probably not finished with it yet.
 448    if ($options{'CLEAN'} && !-f "$install_dir/install.ppm") {
 449        File::Path::rmtree($install_dir,0,0);
 450    }
 451    &Trace("Package $package successfully installed") if $options{'TRACE'};
 452    reread_config();
 453
 454    return 1;
 455}
 456
 457# Returns a hash with key $location, and elements of arrays of package names.
 458# Uses '%repositories' if $location is not specified.
 459sub RepositoryPackages
 460{
 461    my %argv = @_;
 462    my $location = $argv{'location'};
 463    my %ppds;
 464    if (defined $location) {
 465        @{$ppds{$location}} = list_available("location" => $location);
 466	unless (@{$ppds{$location}}) {
 467	    print "Error connecting to '$location'.\n";
 468	}
 469    }
 470    else {
 471        read_config();  # need repositories
 472        foreach (keys %repositories) {
 473            $location = $repositories{$_}{'LOCATION'};
 474            @{$ppds{$location}} = list_available("location" => $location);
 475        }
 476    }
 477    return %ppds;
 478}
 479
 480sub RepositoryPackageProperties
 481{
 482    my %argv = @_;
 483    my $location = $argv{'location'};
 484    my $package = $argv{'package'};
 485    my %PPD;
 486    read_config();
 487    unless (%PPD = getPPDfile('package' => $package, 'location' => $location)) {
 488        &Trace("RepositoryPackageProperties: Could not locate a PPD file for package $package") if $options{'TRACE'};
 489        $PPM::PPMERR = "Could not locate a PPD file for package $package";
 490        return;
 491    }
 492    parsePPD(%PPD);
 493
 494    my %ret_hash = map { $_ => $current_package{$_} } 
 495        qw(NAME TITLE AUTHOR VERSION ABSTRACT PERLCORE_VER);
 496    foreach my $dep (keys %{$current_package{'DEPEND'}}) {
 497        push @{$ret_hash{'DEPEND'}}, $dep;
 498    }
 499
 500    return %ret_hash;
 501}
 502
 503# Returns 1 on success, 0 and sets $PPMERR on failure.
 504sub RemovePackage
 505{
 506    my %argv = @_;
 507    my $package = $argv{'package'};
 508    my $force = $argv{'force'};
 509    my %PPD;
 510
 511    read_config();
 512    unless ($installed_packages{$package}) {
 513        my $pattern = $package;
 514        undef $package;
 515        # Do another lookup, ignoring case
 516        foreach (keys %installed_packages) {
 517            if (/^$pattern$/i) {
 518                $package = $_;
 519                last;
 520            }
 521        }
 522        unless ($package) {
 523            &Trace("Package '$pattern' has not been installed by PPM")
 524                if $options{'TRACE'};
 525            $PPM::PPMERR = "Package '$pattern' has not been installed by PPM";
 526            return 0;
 527        }
 528    }
 529
 530    # Don't let them remove PPM itself, libnet, Archive-Tar, etc.
 531    # but we can force removal if we're upgrading
 532    unless ($force) {
 533        foreach (@required_packages) {
 534            if ($_ eq $package) {
 535                &Trace("Package '$package' is required by PPM and cannot be removed") if $options{'TRACE'};
 536                $PPM::PPMERR = "Package '$package' is required by PPM and cannot be removed";
 537                return 0;
 538            }
 539        }
 540    }
 541
 542    my $install_dir = "$options{'BUILDDIR'}/$package";
 543
 544    %PPD = %{ $installed_packages{$package}{'INST_PPD'} };
 545    parsePPD(%PPD);
 546    my $cwd = getcwd();
 547    $cwd .= "/" if $cwd =~ /[a-z]:$/i;
 548    if (defined $current_package{'UNINSTALL_SCRIPT'}) {
 549        if (!chdir($install_dir)) {
 550            &Trace("Could not chdir() to $install_dir: $!") if $options{'TRACE'};
 551            $PPM::PPMERR = "Could not chdir() to $install_dir: $!";
 552            return 0;
 553        }
 554        run_script("script" => $current_package{'UNINSTALL_SCRIPT'},
 555                   "scriptHREF" => $current_package{'UNINSTALL_HREF'},
 556                   "exec" => $current_package{'UNINSTALL_EXEC'});
 557        chdir($cwd);
 558    }
 559    else {
 560        if (-f $installed_packages{$package}{'INST_PACKLIST'}) {
 561            &Trace("Calling ExtUtils::Install::uninstall")
 562                if $options{'TRACE'} > 1;
 563            eval {
 564                ExtUtils::Install::uninstall("$installed_packages{$package}{'INST_PACKLIST'}", 0, 0);
 565            };
 566            warn $@ if $@;
 567        }
 568    }
 569
 570    #rebuild the html TOC
 571    Trace("Calling ActivePerl::DocTools::WriteTOC()") if $options{'TRACE'} > 1;
 572    ActivePerl::DocTools::WriteTOC() if $useDocTools;
 573
 574    File::Path::rmtree($install_dir,0,0);
 575    PPMdat_remove_package($package);
 576    &Trace("Package $package removed") if $options{'TRACE'};
 577    reread_config();
 578    return 1;
 579}
 580
 581# returns "0" if package is up-to-date; "1" if an upgrade is available;
 582# undef and sets $PPMERR on error; and the new VERSION string if a package
 583# was upgraded.
 584sub VerifyPackage
 585{
 586    my %argv = @_;
 587    my $package = $argv{'package'};
 588    my $location = $argv{'location'};
 589    my $upgrade = $argv{'upgrade'};
 590    my $force = $argv{'force'};
 591    my ($installedPPDfile, $comparePPDfile, %installedPPD, %comparePPD);
 592
 593    read_config();
 594
 595    unless ($installed_packages{$package}) {
 596        my $pattern = $package;
 597        undef $package;
 598        # Do another lookup, ignoring case
 599        foreach (keys %installed_packages) {
 600            if (/^$pattern$/i) {
 601                $package = $_;
 602                last;
 603            }
 604        }
 605        unless ($package) {
 606            &Trace("Package '$pattern' has not been installed by PPM") if $options{'TRACE'};
 607            $PPM::PPMERR = "Package '$pattern' has not been installed by PPM";
 608            return undef;
 609        }
 610    }
 611
 612    %installedPPD = %{ $installed_packages{$package}{'INST_PPD'} };
 613
 614    unless (%comparePPD = getPPDfile('package' => $package, 
 615            'location' => $location)) {
 616        &Trace("VerifyPackage: Could not locate a PPD file for $package")
 617            if $options{'TRACE'};
 618        $PPM::PPMERR = "Could not locate a PPD file for $package";
 619        return;
 620    }
 621
 622    parsePPD(%installedPPD);
 623    my @installed_version = split (',', $current_package{'VERSION'});
 624    my $inst_root = $installed_packages{$package}{'INST_ROOT'};
 625
 626    parsePPD(%comparePPD);
 627    unless ($current_package{'CODEBASE'} || $current_package{'INSTALL_HREF'}) {
 628        &Trace("Read a PPD for '$package', but it is not intended for this build of Perl ($Config{archname})")
 629            if $options{'TRACE'};
 630        $PPM::PPMERR = "Read a PPD for '$package', but it is not intended for this build of Perl ($Config{archname})";
 631        return undef;
 632    }
 633    my @compare_version = split (',',  $current_package{'VERSION'});
 634    my $available;
 635    foreach(0..3) {
 636        next if $installed_version[$_] == $compare_version[$_];
 637        $available++ if $installed_version[$_] < $compare_version[$_];
 638        last;
 639    }
 640
 641    if ($available || $force) {
 642        &Trace("Upgrade to $package is available")
 643	    if $options{'TRACE'} > 1 and $available;
 644        if ($upgrade) {
 645            if ($Config{'osname'} eq 'MSWin32' &&
 646                !&Win32::IsWinNT && exists $Win9x_denied{lc($package)}) {
 647                $PPM::PPMERR = "Package '$package' cannot be upgraded with PPM on Win9x--see http://aspn.ActiveState.com/ASPN/Downloads/ActivePerl/PPM/ for details";
 648                return undef;
 649            }
 650
 651            # need to remember the $location, and $current_version,
 652	    # because once we remove the package, they're unavailable.
 653	    # XXX this should probably be fixed
 654            $location = $installed_packages{$package}{'LOCATION'} unless $location;
 655	    my $current_version = $current_package{'VERSION'};
 656	    unless (getPPDfile('package' => $package, 
 657                    'location' => $location)) {
 658		&Trace("VerifyPackage: Could not locate a PPD file for $package") if $options{'TRACE'};
 659		$PPM::PPMERR = "Could not locate a PPD file for $package";
 660		return undef;
 661	    }
 662            RemovePackage("package" => $package, "force" => 1);
 663            unless(InstallPackage("package" => $package,
 664				  "location" => $location,
 665				  "root" => $inst_root))
 666	    {
 667		# InstallPackage() sets $PPM::PPMERR if it fails
 668		return undef;
 669	    }
 670            return $current_version;
 671        }
 672        return 1;
 673    }
 674    # package is up to date
 675    return 0;
 676}
 677
 678# Changes where the packages are installed.
 679# Returns previous root on success, undef and sets $PPMERR on failure.
 680sub chroot
 681{
 682    my %argv = @_;
 683    my $location = $argv{'location'};
 684
 685    unless (-d $location) {
 686        &Trace("'$location' does not exist.") if $options{'TRACE'};
 687        $PPM::PPMERR = "'$location' does not exist.\n";
 688        return undef;
 689    }
 690
 691    my $previous_root = $options{'ROOT'} || $Config{'prefix'};
 692    $options{'ROOT'} = $location;
 693    return $previous_root;
 694}
 695
 696sub QueryInstalledPackages
 697{
 698    my %argv = @_;
 699    my $ignorecase = $options{'IGNORECASE'} || $argv{'ignorecase'};
 700    my $searchtag = uc $argv{'searchtag'} || undef;
 701    my ($searchRE, $package, %ret_hash);
 702    if (defined $argv{'searchRE'}) {
 703        $searchRE = $argv{'searchRE'};
 704        $searchRE = "(?i)$searchRE" if $ignorecase;
 705        eval { $searchRE =~ /$searchRE/ };
 706        if ($@) {
 707            &Trace("'$searchRE': invalid regular expression.") if $options{'TRACE'};
 708            $PPM::PPMERR = "'$searchRE': invalid regular expression.";
 709            return ();
 710        }
 711    }
 712
 713    read_config();
 714    foreach $package (keys %installed_packages) {
 715        my $results = $package;
 716        if (defined $searchtag) {
 717            my %Package = %{ $installed_packages{$package} };
 718            parsePPD( %{ $Package{'INST_PPD'} } );
 719            $results = $current_package{$searchtag};
 720        }
 721
 722        $ret_hash{$package} = $results
 723            if (!defined $searchRE || ($results =~ /$searchRE/));
 724    }
 725
 726    return %ret_hash;
 727}
 728
 729# Returns a summary of available packages for all repositories.
 730# Returned hash has the following structure:
 731#
 732#    $hash{repository}{package_name}{NAME}
 733#    $hash{repository}{package_name}{VERSION}
 734#    etc.
 735#
 736sub RepositorySummary {
 737    my %argv = @_;
 738    my $location = $argv{'location'};
 739    my (%summary, %locations);
 740
 741    # If we weren't given the location of a repository to query the summary
 742    # for, check all of the repositories that we know about.
 743    unless ($location) {
 744        read_config();  # need repositories
 745        foreach (keys %repositories) {
 746            $locations{$repositories{$_}{'LOCATION'}} =
 747                $repositories{$_}{'SUMMARYFILE'};
 748        }
 749    }
 750    # Otherwise, we were given a repository to query, figure out where we can
 751    # find the summary file for that repository.
 752    else {
 753        foreach (keys %repositories) {
 754            if ($location =~ /\Q$repositories{$_}{'LOCATION'}\E/i) {
 755                $locations{$repositories{$_}{'LOCATION'}} =
 756                    $repositories{$_}{'SUMMARYFILE'};
 757                last;
 758            }
 759        }
 760    }
 761
 762    # Check all of the summary file locations that we were able to find.
 763    foreach $location (keys %locations) {
 764        my $summaryfile = $locations{$location};
 765        unless ($summaryfile) {
 766            &Trace("RepositorySummary: No summary available from $location.")
 767                if $options{'TRACE'};
 768            $PPM::PPMERR = "No summary available from $location.\n";
 769            next;
 770        }
 771        my $data;
 772        if ($location =~ m@^...*://@i) {
 773            next unless ($data = read_href("request" => 'GET',
 774                "href" => "$location/$summaryfile"));
 775        } else {
 776            local $/;
 777            next if (!open (DATAFILE, "$location/$summaryfile"));
 778            $data = <DATAFILE>;
 779            close(DATAFILE);
 780        }
 781        $summary{$location} = parse_summary($data);
 782    }
 783
 784    return %summary;
 785}
 786
 787# Returns the same structure as RepositorySummary() above.
 788sub ServerSearch
 789{
 790    my %argv = @_;
 791    my $location = $argv{'location'};
 792    my $searchRE = $argv{'searchRE'};
 793    my $searchtag = $argv{'searchtag'};
 794    my $data;
 795    my %summary;
 796
 797    return unless $location =~ m#^(http://.*)\?(urn:.*)#i;
 798    my ($proxy, $uri) = ($1, $2);
 799    my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
 800    eval { $data = $client -> 
 801        search_ppds($Config{'archname'}, $searchRE, $searchtag) -> result; };
 802    if ($@) {
 803        &Trace("Error searching repository '$proxy': $@") 
 804            if $options{'TRACE'};
 805        $PPM::PPMERR = "Error searching repository '$proxy': $@\n";
 806        return;
 807    }
 808
 809    $summary{$location} = parse_summary($data);
 810    return %summary;
 811}
 812
 813#
 814# Internal subs
 815#
 816
 817sub parse_summary
 818{
 819    my $data = shift;
 820    my (%summary, @parsed);
 821
 822    # take care of '&'
 823    $data =~ s/&(?!\w+;)/&amp;/go;
 824
 825    my $parser = new XML::Parser( Style => 'Objects', 
 826        Pkg => 'PPM::XML::RepositorySummary' );
 827    eval { @parsed = @{ $parser->parse( $data ) } };
 828    if ($@) {
 829        &Trace("parse_summary: content of summary file is not valid") 
 830            if $options{'TRACE'};
 831        $PPM::PPMERR = 
 832            "parse_summary: content of summary file is not valid: $!\n";
 833        return;
 834    }
 835
 836
 837    my $packages = ${$parsed[0]}{Kids};
 838
 839    foreach my $package (@{$packages}) {
 840        my $elem_type = ref $package;
 841        $elem_type =~ s/.*:://;
 842        next if ($elem_type eq 'Characters');
 843
 844        if ($elem_type eq 'SOFTPKG') {
 845            my %ret_hash;
 846            parsePPD(%{$package});
 847            %ret_hash = map { $_ => $current_package{$_} } 
 848                qw(NAME TITLE AUTHOR VERSION ABSTRACT PERLCORE_VER);
 849            foreach my $dep (keys %{$current_package{'DEPEND'}}) {
 850                push @{$ret_hash{'DEPEND'}}, $dep;
 851            }
 852            $summary{$current_package{'NAME'}} = \%ret_hash;
 853        }
 854    }
 855    return \%summary;
 856}
 857
 858sub save_options
 859{
 860    read_config();
 861    my %PPMConfig;
 862    # Read in the existing PPM configuration file
 863    return unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
 864        'parsertype' => 'PPM::XML::PPMConfig'));
 865
 866    # Remove all of the declarations for REPOSITORY and PPMPRECIOUS;
 867    # we'll output these from the lists we've got in memory instead.
 868    foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
 869        my $elem = $PPMConfig{Kids}[$idx];
 870        my $elem_type = ref $elem;
 871        if ($elem_type =~ /::REPOSITORY$|::PPMPRECIOUS$/o) {
 872            splice( @{$PPMConfig{Kids}}, $idx, 1 );
 873            redo;   # Restart again so we don't miss any
 874        }
 875    }
 876
 877    # Traverse the info we read in and replace the values in it with the new
 878    # config options that we've got.
 879    foreach my $elem (@{ $PPMConfig{Kids} }) {
 880        my $elem_type = ref $elem;
 881        $elem_type =~ s/.*:://;
 882        next if ($elem_type ne 'OPTIONS');
 883        %{$elem} = map { $_ => $options{$_} } keys %options;
 884        # This bit of ugliness is necessary for historical (VPM) reasons
 885        delete $elem->{FORCE_INSTALL};
 886        $elem->{FORCEINSTALL} = $options{'FORCE_INSTALL'};
 887    }
 888
 889    # Find out where the package listings start and insert our PPMPRECIOUS and
 890    # updated list of REPOSITORYs.
 891    foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
 892        my $elem = $PPMConfig{Kids}[$idx];
 893        my $elem_type = ref $elem;
 894        $elem_type =~ s/.*:://;
 895        next unless (($elem_type eq 'PACKAGE') or
 896                     ($idx == $#{$PPMConfig{Kids}}));
 897
 898        # Insert our PPMPRECIOUS
 899        my $chardata = new PPM::XML::PPMConfig::Characters;
 900        $chardata->{Text} = join( ';', @required_packages );
 901        my $precious = new PPM::XML::PPMConfig::PPMPRECIOUS;
 902        push( @{$precious->{Kids}}, $chardata );
 903        splice( @{$PPMConfig{Kids}}, $idx, 0, $precious );
 904
 905        # Insert the list of repositories we've got
 906        my $rep_name;
 907        foreach $rep_name (keys %repositories) {
 908            my $repository = new PPM::XML::PPMConfig::REPOSITORY;
 909            %{$repository} = 
 910                map { $_ => $repositories{$rep_name}{$_} } 
 911                    keys %{$repositories{$rep_name}};
 912            $repository->{'NAME'} = $rep_name;
 913            splice( @{$PPMConfig{Kids}}, $idx, 0, $repository );
 914        }
 915        last;
 916    }
 917    # Take the data structure we've got and bless it into a PPMCONFIG object so
 918    # that we can output it.
 919    my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
 920
 921    # Open the output file and output the PPM config file
 922    unless (open( DAT, ">$PPM::PPMdat" )) {
 923        &Trace("open of $PPM::PPMdat failed: $!") if $options{'TRACE'};
 924        $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
 925        return 1;
 926    }
 927    my $oldout = select DAT;
 928    $cfg->output();
 929    select $oldout;
 930    close( DAT );
 931    &Trace("Wrote config file") if $options{'TRACE'} > 1;
 932}
 933
 934# Gets a listing of all of the packages available in the repository.  If an
 935# argument of 'location' is provided in %argv, it is used as the repository to
 936# query.  This method returns to the caller a complete list of all of the
 937# available packages at the repository in a list context, returning 'undef' if
 938# any errors occurred.
 939sub list_available
 940{
 941    my %argv = @_;
 942    my $location = $argv{'location'};
 943    my @ppds;
 944
 945    if ($location =~ /^file:\/\/.*\|/i) {
 946        # $location is a local directory, let's avoid LWP by changing
 947        # it to a pathname.
 948        $location =~ s@^file://@@i;
 949        $location =~ s@^localhost/@@i;
 950        $location =~ s@\|@:@;
 951    }
 952
 953    # URL in UNC notation
 954    if ($location =~ /^file:\/\/\/\//i) {
 955        $location =~ s@^file://@@i;
 956    }
 957
 958    # directory or UNC
 959    if (-d $location || $location =~ /^\\\\/ || $location =~ /^\/\//) {
 960        opendir(PPDDIR, $location) or return undef;
 961        my ($file);
 962        @ppds = grep { /\.ppd$/i && -f "$location/$_" } readdir(PPDDIR);
 963        foreach $file (@ppds) {
 964            $file =~ s/\.ppd//i;
 965        }
 966    }
 967    elsif ($location =~ m@^...*://@i) {
 968        if ($cached_ppd_list{$location}) {
 969            return @{$cached_ppd_list{$location}};
 970        }
 971
 972        # If we're accessing a SOAP server, do things differently than we would
 973        # for FTP, HTTP, etc.
 974        if ($location =~ m#^(http://.*)\?(.*)#i) {
 975            my ($proxy, $uri) = ($1, $2);
 976            my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
 977            eval { @ppds = $client->packages()->paramsout };
 978            if ($@) {
 979                &Trace("Package list from '$proxy' failed: $@") 
 980                    if $options{'TRACE'};
 981                $PPM::PPMERR = 
 982                    "Package list from repository '$proxy' failed: $@\n";
 983                return;
 984            }
 985        }
 986        else {
 987            return unless (my $doc = read_href("href" => $location,
 988                "request" => 'GET'));
 989
 990            if ($doc =~ /^<head><title>/) {
 991                # read an IIS format directory listing
 992                @ppds = grep { /\.ppd/i } split('<br>', $doc);
 993                foreach my $file (@ppds) {
 994                    $file =~ s/\.ppd<.*$//is;
 995                    $file =~ s@.*>@@is;
 996                }
 997            }
 998            elsif ($doc =~ /<BODY BGCOLOR=FFFFFF>\n\n<form name=VPMform/s) {
 999                # read output of default.prk over an HTTP connection
1000                @ppds = grep { /^<!--Key:.*-->$/ } split('\n', $doc);
1001                foreach my $file (@ppds) {
1002                    if ($file =~ /^<!--Key:(.*)-->$/) {
1003                        $file = $1;
1004                    }
1005                }
1006            }
1007            else {
1008                # read an Apache format directory listing
1009                @ppds = grep { /\.ppd/i } split('\n', $doc);
1010                foreach my $file (@ppds) {
1011                    $file =~ s/^.*>(.*?)\.ppd<.*$/$1/i;
1012                }
1013            }
1014        }
1015
1016        # All done, take the list of PPDs that we've queried and cache it for
1017        # later re-use, then return it to the caller.
1018        @{$cached_ppd_list{$location}} = sort @ppds;
1019        return @{$cached_ppd_list{$location}};
1020    }
1021    return sort @ppds;
1022}
1023
1024my ($response, $bytes_transferred);
1025
1026sub read_href
1027{
1028    my %argv = @_;
1029    my $href = $argv{'href'};
1030    my $request = $argv{'request'};
1031    my $target = $argv{'target'};
1032    my $progress = $argv{'progress'}; # display status of binary transfers
1033    my ($proxy_user, $proxy_pass);
1034    # If this is a SOAP URL, handle it differently than FTP/HTTP/file.
1035    if ($href =~ m#^(http://.*)\?(.*)#i) {
1036        my ($proxy, $uri) = ($1, $2);
1037        my $fcn;
1038        if ($uri =~ m#(.*:/.*)/(.+?)$#) {
1039            ($uri, $fcn) = ($1, $2);
1040        }
1041        my $client = SOAP::Lite -> uri($uri) -> proxy($proxy);
1042        if ($fcn eq 'fetch_summary') {
1043            my $summary = eval { $client->fetch_summary()->result; };
1044            if ($@) {
1045                &Trace("Error getting summary from repository '$proxy': $@") 
1046                    if $options{'TRACE'};
1047                $PPM::PPMERR = 
1048                    "Error getting summary from repository '$proxy': $@\n";
1049                return;
1050            }
1051            return $summary;
1052        }
1053        $fcn =~ s/\.ppd$//i;
1054        my $ppd = eval { $client->fetch_ppd($fcn)->result };
1055        if ($@) {
1056            &Trace("Error fetching '$fcn' from repository '$proxy': $@") 
1057                if $options{'TRACE'};
1058            $PPM::PPMERR = 
1059                "Error fetching '$fcn' from repository '$proxy': $@\n";
1060            return;
1061        }
1062        return $ppd;
1063        # todo: write to disk file if $target
1064    }
1065    # Otherwise it's a standard URL, go ahead and request it using LWP.
1066    my $ua = new LWP::UserAgent;
1067    $ua->agent($ENV{HTTP_proxy_agent} || ("$0/0.1 " . $ua->agent));
1068    if (defined $ENV{HTTP_proxy}) {
1069        $proxy_user = $ENV{HTTP_proxy_user};
1070        $proxy_pass = $ENV{HTTP_proxy_pass};
1071        &Trace("read_href: calling env_proxy: $ENV{'HTTP_proxy'}")
1072            if $options{'TRACE'} > 1;
1073        $ua->env_proxy;
1074    }
1075    my $req = new HTTP::Request $request => $href;
1076    if (defined $proxy_user && defined $proxy_pass) {
1077        &Trace("read_href: calling proxy_authorization_basic($proxy_user, $proxy_pass)") if $options{'TRACE'} > 1;
1078        $req->proxy_authorization_basic("$proxy_user", "$proxy_pass");
1079    }
1080
1081    # Do we need to do authorization?
1082    # This is a hack, but will have to do for now.
1083    foreach (keys %repositories) {
1084        if ($href =~ /^\Q$repositories{$_}{'LOCATION'}\E/i) {
1085            my $username = $repositories{$_}{'USERNAME'};
1086            my $password = $repositories{$_}{'PASSWORD'};
1087            if (defined $username && defined $password) {
1088                &Trace("read_href: calling proxy_authorization_basic($username, $password)") if $options{'TRACE'} > 1;
1089                $req->authorization_basic($username, $password);
1090                last;
1091            }
1092        }
1093    }
1094
1095    ($response, $bytes_transferred) = (undef, 0);
1096    if ($progress) {
1097        # display the 'progress indicator'
1098        $ua->request($req, \&lwp_callback, 
1099            ($options{'DOWNLOADSTATUS'} || 4096));
1100        print "\n" if ($PPM::PPMShell && $options{'DOWNLOADSTATUS'});
1101    }
1102    else {
1103        $response = $ua->request($req);
1104    }
1105    if ($response && $response->is_success) {
1106        if ($target) {
1107            unless (open(OUT, ">$target")) {
1108                &Trace("read_href: Couldn't open $target for writing")
1109                    if $options{'TRACE'};
1110                $PPM::PPMERR = "Couldn't open $target for writing\n";
1111                return;
1112            }
1113            binmode(OUT);
1114            print OUT $response->content;
1115            close(OUT);
1116        }
1117        return $response->content;
1118    }
1119    if ($response) {
1120        &Trace("read_href: Error reading $href: " . $response->code . " " . 
1121            $response->message) if $options{'TRACE'};
1122        $PPM::PPMERR = "Error reading $href: " . $response->code . " " . 
1123            $response->message . "\n";
1124    }
1125    else {
1126        &Trace("read_href: Error reading $href") if $options{'TRACE'};
1127        $PPM::PPMERR = "Error reading $href\n";
1128    }
1129    return;
1130}
1131
1132sub lwp_callback
1133{ 
1134    my ($data, $res, $protocol) = @_;
1135    $response = $res;
1136    $response->add_content($data);
1137    $bytes_transferred += length($data);
1138    print "Bytes transferred: $bytes_transferred\r" 
1139        if ($PPM::PPMShell && $options{'DOWNLOADSTATUS'});
1140}
1141
1142sub reread_config
1143{
1144    %current_package = ();
1145    %installed_packages = ();
1146    $init = 0;
1147    read_config();
1148}
1149
1150# returns 0 on success, 1 and sets $PPMERR on error.
1151sub PPMdat_add_package
1152{
1153    my ($location, $packlist, $inst_root) = @_;
1154    my $package = $current_package{'NAME'};
1155    my $time_str = localtime;
1156
1157    # If we already have this package installed, remove it from the PPM
1158    # Configuration file so we can put the new one in.
1159    if (defined $installed_packages{$package} ) {
1160        # remove the existing entry for this package.
1161        PPMdat_remove_package($package);
1162    }
1163
1164    # Build the new SOFTPKG data structure for this package we're adding.
1165    my $softpkg =
1166        new PPM::XML::PPMConfig::SOFTPKG( NAME    => $package,
1167                                     VERSION => $current_package{VERSION}
1168                                   );
1169
1170    if (defined $current_package{TITLE}) {
1171        my $chardata = new PPM::XML::PPMConfig::Characters( 
1172            Text => $current_package{TITLE} );
1173        my $newelem = new PPM::XML::PPMConfig::TITLE;
1174        push( @{$newelem->{Kids}}, $chardata );
1175        push( @{$softpkg->{Kids}}, $newelem );
1176    }
1177
1178    if (defined $current_package{ABSTRACT}) {
1179        my $chardata = new PPM::XML::PPMConfig::Characters(
1180            Text => $current_package{ABSTRACT});
1181        my $newelem = new PPM::XML::PPMConfig::ABSTRACT;
1182        push( @{$newelem->{Kids}}, $chardata );
1183        push( @{$softpkg->{Kids}}, $newelem );
1184    }
1185
1186    if (defined $current_package{AUTHOR}) {
1187        my $chardata = new PPM::XML::PPMConfig::Characters(
1188            Text => $current_package{AUTHOR} );
1189        my $newelem = new PPM::XML::PPMConfig::AUTHOR;
1190        push( @{$newelem->{Kids}}, $chardata );
1191        push( @{$softpkg->{Kids}}, $newelem );
1192    }
1193
1194    if (defined $current_package{LICENSE}) {
1195        my $chardata = new PPM::XML::PPMConfig::Characters(
1196            Text => $current_package{LICENSE});
1197        my $newelem = new PPM::XML::PPMConfig::LICENSE;
1198        push( @{$newelem->{Kids}}, $chardata );
1199        push( @{$softpkg->{Kids}}, $newelem );
1200    }
1201
1202    my $impl = new PPM::XML::PPMConfig::IMPLEMENTATION;
1203    push( @{$softpkg->{Kids}}, $impl );
1204
1205    if (defined $current_package{PERLCORE_VER}) {
1206        my $newelem = new PPM::XML::PPMConfig::PERLCORE(
1207            VERSION => $current_package{PERLCORE_VER} );
1208        push( @{$impl->{Kids}}, $newelem );
1209    }
1210
1211    foreach (keys %{$current_package{DEPEND}}) {
1212        my $newelem = new PPM::XML::PPMConfig::DEPENDENCY(
1213            NAME => $_, VERSION => $current_package{DEPEND}{$_} );
1214        push( @{$impl->{Kids}}, $newelem );
1215    }
1216
1217    my $codebase = new PPM::XML::PPMConfig::CODEBASE(
1218        HREF => $current_package{CODEBASE} );
1219    push( @{$impl->{Kids}}, $codebase );
1220
1221    my $inst = new PPM::XML::PPMConfig::INSTALL;
1222    push( @{$impl->{Kids}}, $inst );
1223    if (defined $current_package{INSTALL_EXEC})
1224        { $inst->{EXEC} = $current_package{INSTALL_EXEC}; }
1225    if (defined $current_package{INSTALL_HREF})
1226        { $inst->{HREF} = $current_package{INSTALL_HREF}; }
1227    if (defined $current_package{INSTALL_SCRIPT}) {
1228        my $chardata = new PPM::XML::PPMConfig::Characters(
1229            Text => $current_package{INSTALL_SCRIPT} );
1230        push( @{$inst->{Kids}}, $chardata );
1231    }
1232
1233    my $uninst = new PPM::XML::PPMConfig::UNINSTALL;
1234    push( @{$impl->{Kids}}, $uninst );
1235    if (defined $current_package{UNINSTALL_EXEC})
1236        { $uninst->{EXEC} = $current_package{UNINSTALL_EXEC}; }
1237    if (defined $current_package{UNINSTALL_HREF})
1238        { $uninst->{HREF} = $current_package{UNINSTALL_HREF}; }
1239    if (defined $current_package{UNINSTALL_SCRIPT}) {
1240        my $chardata = new PPM::XML::PPMConfig::Characters(
1241            Text => $current_package{UNINSTALL_SCRIPT} );
1242        push( @{$uninst->{Kids}}, $chardata );
1243    }
1244
1245    # Then, build the PACKAGE object and stick the SOFTPKG inside of it.
1246    my $pkg = new PPM::XML::PPMConfig::PACKAGE( NAME => $package );
1247
1248    if ($location) {
1249        my $chardata = new PPM::XML::PPMConfig::Characters( Text => $location );
1250        my $newelem = new PPM::XML::PPMConfig::LOCATION;
1251        push( @{$newelem->{Kids}}, $chardata );
1252        push( @{$pkg->{Kids}}, $newelem );
1253    }
1254
1255    if ($packlist) {
1256        my $chardata = new PPM::XML::PPMConfig::Characters( Text => $packlist );
1257        my $newelem = new PPM::XML::PPMConfig::INSTPACKLIST;
1258        push( @{$newelem->{Kids}}, $chardata );
1259        push( @{$pkg->{Kids}}, $newelem );
1260    }
1261
1262    if ($inst_root) {
1263        my $chardata = new PPM::XML::PPMConfig::Characters( Text => $inst_root );
1264        my $newelem = new PPM::XML::PPMConfig::INSTROOT;
1265        push( @{$newelem->{Kids}}, $chardata );
1266        push( @{$pkg->{Kids}}, $newelem );
1267    }
1268
1269    if ($time_str) {
1270        my $chardata = new PPM::XML::PPMConfig::Characters( Text => $time_str);
1271        my $newelem = new PPM::XML::PPMConfig::INSTDATE;
1272        push( @{$newelem->{Kids}}, $chardata );
1273        push( @{$pkg->{Kids}}, $newelem );
1274    }
1275
1276    my $instppd = new PPM::XML::PPMConfig::INSTPPD;
1277    push( @{$instppd->{Kids}}, $softpkg );
1278    push( @{$pkg->{Kids}}, $instppd );
1279
1280    # Now that we've got the structure built, read in the existing PPM
1281    # Configuration file, add this to it, and spit it back out.
1282    my %PPMConfig;
1283    return 1 unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
1284        'parsertype' => 'PPM::XML::PPMConfig'));
1285    push( @{$PPMConfig{Kids}}, $pkg );
1286    my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
1287
1288    unless (open( DAT, ">$PPM::PPMdat" )) {
1289        &Trace("open of $PPM::PPMdat failed: $!") if $options{'TRACE'};
1290        $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
1291        return 1;
1292    }
1293    my $oldout = select DAT;
1294    $cfg->output();
1295    select $oldout;
1296    close( DAT );
1297    &Trace("PPMdat_add_package: wrote $PPM::PPMdat") if $options{'TRACE'} > 1;
1298
1299    return 0;
1300}
1301
1302# returns 0 on success, 1 and sets $PPMERR on error.
1303sub PPMdat_remove_package
1304{
1305    my $package = shift;
1306
1307    # Read in the existing PPM configuration file
1308    my %PPMConfig;
1309    return 1 unless (%PPMConfig = getPPDfile('package' => $PPM::PPMdat,
1310        'parsertype' => 'PPM::XML::PPMConfig'));
1311
1312    # Try to find the package that we're supposed to be removing, and yank it
1313    # out of the list of installed packages.
1314    foreach my $idx (0 .. @{$PPMConfig{Kids}}) {
1315        my $elem = $PPMConfig{Kids}[$idx];
1316        my $elem_type = ref $elem;
1317        next if ($elem_type !~ /::PACKAGE$/o);
1318        next if ($elem->{NAME} ne $package);
1319        splice( @{$PPMConfig{Kids}}, $idx, 1 );
1320    }
1321
1322    # Take the data structure we've got and bless it into a PPMCONFIG object so
1323    # that we can output it again.
1324    my $cfg = bless \%PPMConfig, 'PPM::XML::PPMConfig::PPMCONFIG';
1325
1326    # Now that we've removed the package, save the configuration file back out.
1327    unless (open( DAT, ">$PPM::PPMdat" )) {
1328        $PPM::PPMERR = "open of $PPM::PPMdat failed: $!\n";
1329        return 1;
1330    }
1331    my $oldout = select DAT;
1332    $cfg->output();
1333    select $oldout;
1334    close( DAT );
1335    &Trace("PPMdat_remove_package: wrote $PPM::PPMdat")
1336        if $options{'TRACE'} > 1;
1337    return 0;
1338}
1339
1340# Run $script using system().  If $scriptHREF is specified, its contents are
1341# used as the script.  If $exec is specified, the script is saved to a
1342# temporary file and executed by $exec.
1343sub run_script
1344{
1345    my %argv = @_;
1346    my $script = $argv{'script'};
1347    my $scriptHREF = $argv{'scriptHREF'};
1348    my $exec = $argv{'exec'};
1349    my $inst_root = $argv{'inst_root'};
1350    my $inst_archlib = $argv{'inst_archlib'};
1351    my (@commands, $tmpname);
1352
1353    if ($scriptHREF) {
1354        if ($exec) {
1355            # store in a temp file.
1356            $tmpname = "$options{'BUILDDIR'}/PPM-" . time();
1357            LWP::Simple::getstore($scriptHREF, $tmpname);
1358        }
1359        else {
1360            my $doc = LWP::Simple::get $scriptHREF;
1361            if (!defined $doc) {
1362                &Trace("run_script: get $scriptHREF failed")
1363                    if $options{'TRACE'} > 1;
1364                return 0;
1365            }
1366            @commands = split("\n", $doc);
1367        }
1368    }
1369    else {
1370        if (-f $script) {
1371            $tmpname = $script;
1372        }
1373        else {
1374            # change any escaped chars
1375            $script =~ s/&lt;/</gi;
1376            $script =~ s/&gt;/>/gi;
1377
1378            @commands = split(';;', $script);
1379            if ($exec) {
1380                # store in a temp file.
1381                $tmpname = "$options{'BUILDDIR'}/PPM-" . time();
1382                open(TMP, ">$tmpname");
1383                foreach my $command (@commands) {
1384                    print TMP "$command\n";
1385                }
1386                close(TMP);
1387            }
1388        }
1389    }
1390    $ENV{'PPM_INSTROOT'} = $inst_root;
1391    $ENV{'PPM_INSTARCHLIB'} = $inst_archlib;
1392    if ($exec) {
1393        $exec = $^X if ($exec =~ /^PPM_PERL$/i);
1394        $exec = "start $exec" if $Config{'osname'} eq 'MSWin32';
1395        system("$exec $tmpname");
1396    }
1397    else {
1398        for my $command (@commands) {
1399            system($command);
1400        }
1401    }
1402}
1403
1404sub parsePPD
1405{
1406    my %PPD = @_;
1407    my $pkg;
1408
1409    %current_package = ();
1410
1411    # Get the package name and version from the attributes and stick it
1412    # into the 'current package' global var
1413    $current_package{NAME}    = $PPD{NAME};
1414    $current_package{VERSION} = $PPD{VERSION};
1415
1416    # Get all the information for this package and put it into the 'current
1417    # package' global var.
1418    my $got_implementation = 0;
1419    my $elem;
1420
1421    foreach $elem (@{$PPD

Large files files are truncated, but you can click here to view the full file