home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.6.1.638-MSWin32-x86.msi / _3584af9119a9d842a9167ac54c478a63 < prev    next >
Encoding:
Text File  |  2004-04-13  |  13.0 KB  |  463 lines
  1. package PPM::Repository;
  2.  
  3. use strict;
  4. use Data::Dumper;
  5. require PPM::PPD;
  6. require LWP::UserAgent;
  7. use PPM::Archive;
  8. use PPM::Result qw(Ok Warning Error List);
  9. use File::Path qw(rmtree);
  10. use vars qw($VERSION);
  11.  
  12. $VERSION = '3.06';
  13.  
  14. sub new {
  15.     my $this = shift;
  16.     my $class = ref($this) || $this;
  17.     my $self = bless {}, $class;
  18.     $self->{location} = shift;
  19.     $self->{name} = shift;
  20.     $self->{username} = shift;
  21.     $self->{password} = shift;
  22.  
  23.     # All Repositories need a UserAgent to download PPMs, so we might as well
  24.     # initialize it now:
  25.     $self->new_ua;
  26.  
  27.     my $error;
  28.     ($self->{type}, $error) = $self->select_type($self->{location});
  29.     if ($self->{type} eq 'LOCAL') {
  30.     require PPM::Repository::Local;
  31.     bless $self, 'PPM::Repository::Local';
  32.     }
  33.     elsif ($self->{type} eq 'WWW') {
  34.     require PPM::Repository::WWW;
  35.     bless $self, 'PPM::Repository::WWW';
  36.     }
  37.     elsif ($self->{type} eq 'PPMSERVER') {
  38.     require PPM::Repository::PPMServer;
  39.     bless $self, 'PPM::Repository::PPMServer';
  40.     }
  41.     elsif ($self->{type} eq 'PPM3SERVER') {
  42.     require PPM::Repository::PPM3Server;
  43.     bless $self, 'PPM::Repository::PPM3Server';
  44.     }
  45.     elsif ($self->{type} eq 'UNSUPPORTED') {
  46.     my $err = PPM::Repository::Result->new($error, $self->{location});
  47.     return (undef, $err->msg_raw);
  48.     }
  49.     $self->init(@_)
  50.     or return (undef, $self->{errmsg});
  51.     return $self;
  52. }
  53.  
  54. sub select_type {
  55.     my $o = shift;
  56.     my $loc = shift;
  57.  
  58.     # Some kind of URI:
  59.     if ($loc =~ m[^[^:]{2,}://]i) {
  60.  
  61.     # Set the base URL for resolving relative links. For SOAP repositories
  62.     # this is incorrect, but unfortunately the servers do not expose a
  63.     # url_base() method. This is used for WWW repositories, though.
  64.     $loc = "$loc/" unless $loc =~ m#/$#;
  65.     $o->{url_base} = URI->new($loc);
  66.  
  67.     # A SOAP url, by convention
  68.     if ($loc =~ m[^(http://.*)\?(.*)]i) {
  69.         eval {
  70.         require SOAP::Lite;
  71.         SOAP::Lite->VERSION(0.51);
  72.         };
  73.         return ('UNSUPPORTED', 
  74.             "SOAP-Lite 0.51 is required to support SOAP servers")
  75.           if $@;
  76.         my ($proxy, $uri) = ($1, $2);
  77.         my $client = $o->{client} = SOAP::Lite->uri($uri)->proxy($proxy);
  78.  
  79.         # Query the server about its supported version. If it
  80.         # fails, select the "old" ppmserver. If it succeeds, select the
  81.         # "new" ppmserver.
  82.  
  83.         my ($type, $msg, $proto) = eval {
  84.         my $soap_result = $client->ppm_protocol;
  85.         my $r = $soap_result->result;
  86.         if (defined $r) {
  87.             my $v = (split /\s+/, $r)[-1];
  88.             return "PPM3SERVER",$client,$v if defined $v and $v >= 300;
  89.             return "PPMSERVER" ,$client,$v if defined $v and $v >= 200;
  90.             return "UNSUPPORTED", "Unknown PPM Server protocol '$r'";
  91.         }
  92.         # There's just ONE guy who managed to create a PPM2 server out
  93.         # there, and he doesn't support the ppm_protocol message.
  94.         return "UNSUPPORTED", <<END;
  95. This SOAP server does not expose a PPM3-compatible interface.  Specifically,
  96. it does not implement the ppm_protocol() method.  Please inform the server's
  97. administrator of the problem.
  98. END
  99.         };
  100.         $o->{proto}  = $proto;
  101.  
  102.         return "UNSUPPORTED", "$@" if $@;
  103.         return $type, $msg;
  104.     }
  105.     else {
  106.         $o->{url} = $loc;
  107.         return "WWW";
  108.     }
  109.     }
  110.  
  111.     # The default is to assume it's a local repository
  112.     else {
  113.     return "LOCAL";
  114.     }
  115. }
  116.  
  117. # Create and initialize an LWP::UserAgent object
  118. sub new_ua {
  119.     my $o = shift;
  120.     return $o->{ua} if $o->{ua};
  121.     $o->{ua} = LWP::UserAgent->new;
  122.     $o->{ua}->agent("ppm/$VERSION");
  123.     $o->init_ua;
  124.     $o->{ua};
  125. }
  126.  
  127. sub init_ua {
  128.     my $o = shift;
  129.     my $ua = shift || $o->{ua};
  130.     $o->{ua}->env_proxy;
  131.     # Special configuration should go here:
  132. }
  133.  
  134. # Create a HTTP::Request object, and authenticate it
  135. sub new_request {
  136.     my $o = shift;
  137.     my $req = HTTP::Request->new(@_);
  138.     my $user = $o->username;
  139.     my $pass = $o->password;
  140.     if (defined $user and defined $pass) {
  141.     $req->authorization_basic($user, $pass);
  142.     }
  143.     if (defined $ENV{HTTP_proxy_user} and defined $ENV{HTTP_proxy_pass}) {
  144.     $req->proxy_authorization_basic($ENV{HTTP_proxy_user}, $ENV{HTTP_proxy_pass});
  145.     }
  146.     # Special headers (HTTP 1.1, keepalive) should go here:
  147.     $req;
  148. }
  149.  
  150. sub search {
  151.     my $o = shift;
  152.     my $target = shift;
  153.     my $query = shift;
  154.     die "Error: base method PPM::Repository::search() called";
  155. }
  156.  
  157. sub describe {
  158.     my $o = shift;
  159.     my $target = shift;
  160.     my $pkg = shift;
  161.     die "Error: base method PPM::Repository::describe() called";
  162. }
  163.  
  164. sub getppd {
  165.     my $o = shift;
  166.     my $target = shift;
  167.     my $pkg = shift;
  168.     die "Error: base method PPM::Repository::getppd() called";
  169. }
  170.  
  171. # absolutize(): the codebase is potentially relative to the location of the
  172. # PPD, which in turn lives at the base of the repository itself,
  173. # $o->{location}.
  174. sub absolutize {
  175.     my $o = shift;
  176.     my $codebase_rel = shift;
  177.     return URI->new_abs($codebase_rel, $o->{url_base})->as_string;
  178. }
  179.  
  180. # This function is provided so that the three unintelligent subclasses (Local,
  181. # WWW, and PPMServer) know how to find packages when they're asked to find
  182. # modules. This naive function assumes that the package containing a module is
  183. # just the module name with '::' converted to '-'.
  184. sub mod_to_pkg {
  185.     my $o = shift;
  186.     my $module = shift;
  187.     $module =~ s/::/-/g;
  188.     $module;
  189. }
  190.  
  191. # This guarantees to return a "complete" PPM::PPD object based on the actual
  192. # PPD text downloaded from the server.
  193. sub getppd_obj {
  194.     my $o = shift;
  195.     my $target = shift;
  196.     my $pkg = shift;
  197.     $o->describe($target, $pkg);
  198. }
  199.  
  200. sub getppm {
  201.     my $o = shift;
  202.     my $target = shift;
  203.     my $pkg = shift;
  204.     my $tmp = shift;
  205.     my $status_cb = shift;
  206.     my $cb_bytes = shift;
  207.  
  208.     # Calculate the target's name:
  209.     my $tname = $target->name;
  210.  
  211.     # We can't rely on $o->describe() returning a fully-featured PPD object,
  212.     # because the PPM3Server only returns exactly what we need to display for
  213.     # searching and describing. The getppd_obj() method is guaranteed to
  214.     # return a full PPD object, with a codebase.
  215.     my $ppd = $o->getppd_obj($target, $pkg);
  216.     return $ppd unless $ppd->ok;
  217.     $ppd = $ppd->result;
  218.     my $ver = $ppd->version;
  219.     my $impl = $ppd->find_impl($target);
  220.     return $impl unless $impl->ok;
  221.     my $codebase = $impl->result->codebase;
  222.  
  223.     # Make sure the codebase is an absolute URL:
  224.     $codebase = $o->absolutize($codebase, $pkg);
  225.  
  226.     # Create a temporary directory and chdir there:
  227.     (my $filename = $codebase) =~ s|.*/||;
  228.     (my $pkgname = $filename)  =~ s|\..*||;
  229.     my $tmpdir = join '/', $tmp, "$pkgname-$$-".time;
  230.     mkdir $tmpdir or
  231.       return Error("can't create temporary directory '$tmpdir': $!");
  232.  
  233.     use Cwd qw(cwd);
  234.     my $cwd = cwd();
  235.  
  236.     # Neat trick: create a result that, when it goes out of scope, deletes the
  237.     # temporary directory and cleans up on the remote end. If there's an error
  238.     # before we return it, we auto-clean everything up. If we do return it,
  239.     # then it is destroyed after being used by the calling sub.
  240.     my $success_retval = Ok($tmpdir);
  241.     $success_retval->on_destruct(sub {
  242.     chdir($cwd);
  243.     rmtree($tmpdir) if $tmpdir;
  244.     $target->pkgfini($pkg);
  245.     });
  246.     # Notify the backend that we're going to start processing the files now.
  247.     {
  248.     my $ok = $target->pkginit($pkg);
  249.     return $ok unless $ok->ok;
  250.     }
  251.  
  252.     chdir $tmpdir or
  253.       return Error("can't chdir to $tmpdir: $!");
  254.  
  255.     # Download the tarball:
  256.     my ($bytes, $total, $s_time);
  257.     my $cb = sub {
  258.     my ($data, $res, $prot) = @_;
  259.     $total ||= $res->content_length;
  260.     print FILE $data;
  261.     $bytes += length($data);
  262.  
  263.     # Notify the user through the status callback:
  264.     $status_cb->($pkg, $ver, $tname, 'DOWNLOAD', 
  265.              $bytes, $total, $s_time - time);
  266.     };
  267.     my $ua = $o->{ua};
  268.     my $req = $o->new_request('GET', $codebase);
  269.     open(FILE, '>', $filename) or
  270.       return Error("can't write $filename: $!");
  271.     binmode(FILE) or
  272.       return Error("can't set $filename binary: $!");
  273.     $status_cb->($pkg, $ver, $tname, 'PRE-INSTALL', 0, 0, 0);
  274.     $s_time = time;
  275.     my $res = $ua->request($req, $cb, $cb_bytes);
  276.     unless ($res->is_success) {
  277.     close(FILE);
  278.     return Error("error downloading '$codebase': " . $res->status_line);
  279.     }
  280.     close(FILE) or
  281.       return Error("can't close $filename: $!");
  282.  
  283.     $status_cb->($pkg, $ver, $tname, 'PRE-EXPAND', $total, $total, 0);
  284.     my $ok = eval {
  285.     my $archive = PPM::Archive->new($filename);
  286.     my @files = $archive->list_files;
  287.     my $files = scalar @files;
  288.     my $n = 1;
  289.     for (@files) {
  290.         $status_cb->($pkg, $ver, $tname, 'EXPAND', $n, $files, $_);
  291.         $n++;
  292.         $archive->extract($_);
  293.         next unless -f $_;
  294.         my $ok = $target->transmit($pkg, $_);
  295.         return $ok unless $ok->ok;
  296.     }
  297.     Ok();
  298.     };
  299.     if ($@) {
  300.     return Error("$@"); # stringify it
  301.     }
  302.     return $ok unless $ok->ok;
  303.  
  304.     # Remove the tarball:
  305.     unlink $filename;
  306.  
  307.     # transmit() the install and uninstall scripts to the $target. If it knows
  308.     # how to use them, it will. Otherwise, it won't. YAY!
  309.     for my $thing (qw(install uninstall)) {
  310.     my $method = "${thing}_script";
  311.     my $script = $impl->result->$method;
  312.     next unless $script;
  313.  
  314.     if (my $href = $script->href) {
  315.         $href = $o->absolutize($href, $pkg);
  316.         my $req = $o->new_request('GET', $href);
  317.         my $res = $ua->request($req, $method);
  318.         $res->is_success or return Error(
  319.         "error downloading $thing script '$href': " .
  320.         $res->status_line
  321.         );
  322.     }
  323.     if (-f $method) {
  324.         $target->transmit($pkg, $method);
  325.     }
  326.     }
  327.  
  328.     chdir $cwd;
  329.     return $success_retval;
  330. }
  331.  
  332. sub init { 1 }
  333.  
  334. sub uptodate {
  335.     my $o = shift;
  336.     my $target = shift;
  337.     my $pkg = shift;
  338.     my $version = shift;
  339.     my $ppd = $o->describe($target, $pkg);
  340.     return $ppd unless $ppd->ok;
  341.     List($ppd->result->uptodate($version), $ppd->result->version);
  342. }
  343.  
  344. # Run multiple requests in one call, and return the list of results. This may
  345. # be overridden by sub-repositories if the server supports it. This default
  346. # version just calls each method.
  347. sub batch {
  348.     my $o = shift;
  349.     my $target = shift;
  350.     my @batch;
  351.     for my $task (@_) {
  352.     my ($meth, @args) = @$task;
  353.     push @batch, $o->$meth($target, @args);
  354.     }
  355.     List(@batch);
  356. }
  357.  
  358. sub uptodate2 {
  359.     my ($o, $targ, $pkg, $instver) = @_;
  360.  
  361.     # Check whether it's up to date:
  362.     my $ppd = $o->describe($targ, $pkg);
  363.     return $ppd unless $ppd->ok;
  364.     List($ppd->result->uptodate($instver), $ppd->result);
  365. }
  366.  
  367. sub location {
  368.     my $o = shift;
  369.     $o->{location};
  370. }
  371.  
  372. sub name {
  373.     my $o = shift;
  374.     return $o->{name};
  375. }
  376.  
  377. sub username {
  378.     my $o = shift;
  379.     return $o->{username};
  380. }
  381.  
  382. sub password {
  383.     my $o = shift;
  384.     return $o->{password};
  385. }
  386.  
  387. sub type {
  388.     my $o = shift;
  389.     $o->{type};
  390. }
  391.  
  392. sub protocol {
  393.     my $o = shift;
  394.     $o->{proto};
  395. }
  396.  
  397. sub parse_summary {
  398.     my $o = shift;
  399.     my $doc = shift;
  400.     my $cache_key = shift;
  401.     my $complete = shift;
  402.     $complete = 1 unless defined $complete;
  403.     return Ok($o->{cache}{$cache_key})
  404.       if defined $cache_key and exists $o->{cache}{$cache_key};
  405.     $doc =~ s/<\?xml[^>]+\?>//;
  406.     return Error("could not parse package summary")
  407.       unless $doc =~ /^\s*<REPOSITORYSUMMARY>/;
  408.     $doc =~ s|</?REPOSITORYSUMMARY>||g;
  409.     my %ppds =  map { $_->name, $_ }
  410.         map { @$_{qw(is_complete id)} = ($complete, $_->name); $_ }
  411.         map { $_ .= '</SOFTPKG>'; PPM::PPD->new($_, $o) }
  412.         grep { /\S/ }
  413.         split('</SOFTPKG>', $doc);
  414.     $o->{cache}{$cache_key} = \%ppds
  415.       if defined $cache_key;
  416.     return Ok(\%ppds);
  417. }
  418.  
  419. #=============================================================================
  420. # Profile stuff must be overridden in the PPM3 Server
  421. #=============================================================================
  422. sub profile_list    {
  423.     my $rep = shift;
  424.     my $name = $rep->name;
  425.     my $type = $rep->type_printable;
  426.     Error("Profiles are not supported on the repository '$name'. It is of type '$type', and only 'PPMServer 3.0' or better support profiles.");
  427. }
  428. sub profile_add     { goto &profile_list }
  429. sub profile_del     { goto &profile_list }
  430. sub profile_save    { goto &profile_list }
  431. sub profile_info    { goto &profile_list }
  432. sub profile_target_rename { goto &profile_list }
  433.  
  434. # Profile tracking
  435. sub installed { }
  436. sub upgraded  { }
  437. sub removed   { }
  438.  
  439. package PPM::Repository::Result;
  440. use Data::Dumper;
  441. use PPM::Config;
  442.  
  443. sub new {
  444.     my $p = shift;
  445.     my $msg = shift;
  446.     my $loc = shift;
  447.     my $code = shift || 1;;
  448.     my $site = q{R:\inetpub\wwwroot\www2.ActiveState.com};
  449.  
  450.     # If there's an error about the server being down:
  451.     if ($msg =~ m{\Q$site\E} or $msg =~ m{syntax error}) {
  452.     $msg = "The server '$loc' is not accepting SOAP connections. Please try again later.";
  453.     }
  454.     elsif ($msg =~ /obtaining a license/i) {
  455.     my $file = PPM::Config::get_license_file();
  456.     my $found = -f $file ? "is present" : "not found";
  457.     $msg = join ' ', $msg, "License file '$file' $found.";
  458.     }
  459.     return PPM::Result->new('', $code, $msg);
  460. }
  461.  
  462. 1;
  463.