home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _3584af9119a9d842a9167ac54c478a63 < prev    next >
Encoding:
Text File  |  2004-06-01  |  13.1 KB  |  467 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.         if ($@) {
  103.         # Fix up "404 Not Found at c:/Perl806/site/lib/PPM/Repository.pm line 84"
  104.         $@ =~ s/ at \S+\.pm line.*//;
  105.         return "UNSUPPORTED", "$@";
  106.         }
  107.         return $type, $msg;
  108.     }
  109.     else {
  110.         $o->{url} = $loc;
  111.         return "WWW";
  112.     }
  113.     }
  114.  
  115.     # The default is to assume it's a local repository
  116.     else {
  117.     return "LOCAL";
  118.     }
  119. }
  120.  
  121. # Create and initialize an LWP::UserAgent object
  122. sub new_ua {
  123.     my $o = shift;
  124.     return $o->{ua} if $o->{ua};
  125.     $o->{ua} = LWP::UserAgent->new;
  126.     $o->{ua}->agent("ppm/$VERSION");
  127.     $o->init_ua;
  128.     $o->{ua};
  129. }
  130.  
  131. sub init_ua {
  132.     my $o = shift;
  133.     my $ua = shift || $o->{ua};
  134.     $o->{ua}->env_proxy;
  135.     # Special configuration should go here:
  136. }
  137.  
  138. # Create a HTTP::Request object, and authenticate it
  139. sub new_request {
  140.     my $o = shift;
  141.     my $req = HTTP::Request->new(@_);
  142.     my $user = $o->username;
  143.     my $pass = $o->password;
  144.     if (defined $user and defined $pass) {
  145.     $req->authorization_basic($user, $pass);
  146.     }
  147.     if (defined $ENV{HTTP_proxy_user} and defined $ENV{HTTP_proxy_pass}) {
  148.     $req->proxy_authorization_basic($ENV{HTTP_proxy_user}, $ENV{HTTP_proxy_pass});
  149.     }
  150.     # Special headers (HTTP 1.1, keepalive) should go here:
  151.     $req;
  152. }
  153.  
  154. sub search {
  155.     my $o = shift;
  156.     my $target = shift;
  157.     my $query = shift;
  158.     die "Error: base method PPM::Repository::search() called";
  159. }
  160.  
  161. sub describe {
  162.     my $o = shift;
  163.     my $target = shift;
  164.     my $pkg = shift;
  165.     die "Error: base method PPM::Repository::describe() called";
  166. }
  167.  
  168. sub getppd {
  169.     my $o = shift;
  170.     my $target = shift;
  171.     my $pkg = shift;
  172.     die "Error: base method PPM::Repository::getppd() called";
  173. }
  174.  
  175. # absolutize(): the codebase is potentially relative to the location of the
  176. # PPD, which in turn lives at the base of the repository itself,
  177. # $o->{location}.
  178. sub absolutize {
  179.     my $o = shift;
  180.     my $codebase_rel = shift;
  181.     return URI->new_abs($codebase_rel, $o->{url_base})->as_string;
  182. }
  183.  
  184. # This function is provided so that the three unintelligent subclasses (Local,
  185. # WWW, and PPMServer) know how to find packages when they're asked to find
  186. # modules. This naive function assumes that the package containing a module is
  187. # just the module name with '::' converted to '-'.
  188. sub mod_to_pkg {
  189.     my $o = shift;
  190.     my $module = shift;
  191.     $module =~ s/::/-/g;
  192.     $module;
  193. }
  194.  
  195. # This guarantees to return a "complete" PPM::PPD object based on the actual
  196. # PPD text downloaded from the server.
  197. sub getppd_obj {
  198.     my $o = shift;
  199.     my $target = shift;
  200.     my $pkg = shift;
  201.     $o->describe($target, $pkg);
  202. }
  203.  
  204. sub getppm {
  205.     my $o = shift;
  206.     my $target = shift;
  207.     my $pkg = shift;
  208.     my $tmp = shift;
  209.     my $status_cb = shift;
  210.     my $cb_bytes = shift;
  211.  
  212.     # Calculate the target's name:
  213.     my $tname = $target->name;
  214.  
  215.     # We can't rely on $o->describe() returning a fully-featured PPD object,
  216.     # because the PPM3Server only returns exactly what we need to display for
  217.     # searching and describing. The getppd_obj() method is guaranteed to
  218.     # return a full PPD object, with a codebase.
  219.     my $ppd = $o->getppd_obj($target, $pkg);
  220.     return $ppd unless $ppd->ok;
  221.     $ppd = $ppd->result;
  222.     my $ver = $ppd->version;
  223.     my $impl = $ppd->find_impl($target);
  224.     return $impl unless $impl->ok;
  225.     my $codebase = $impl->result->codebase;
  226.  
  227.     # Make sure the codebase is an absolute URL:
  228.     $codebase = $o->absolutize($codebase, $pkg);
  229.  
  230.     # Create a temporary directory and chdir there:
  231.     (my $filename = $codebase) =~ s|.*/||;
  232.     (my $pkgname = $filename)  =~ s|\..*||;
  233.     my $tmpdir = join '/', $tmp, "$pkgname-$$-".time;
  234.     mkdir $tmpdir or
  235.       return Error("can't create temporary directory '$tmpdir': $!");
  236.  
  237.     use Cwd qw(cwd);
  238.     my $cwd = cwd();
  239.  
  240.     # Neat trick: create a result that, when it goes out of scope, deletes the
  241.     # temporary directory and cleans up on the remote end. If there's an error
  242.     # before we return it, we auto-clean everything up. If we do return it,
  243.     # then it is destroyed after being used by the calling sub.
  244.     my $success_retval = Ok($tmpdir);
  245.     $success_retval->on_destruct(sub {
  246.     chdir($cwd);
  247.     rmtree($tmpdir) if $tmpdir;
  248.     $target->pkgfini($pkg);
  249.     });
  250.     # Notify the backend that we're going to start processing the files now.
  251.     {
  252.     my $ok = $target->pkginit($pkg);
  253.     return $ok unless $ok->ok;
  254.     }
  255.  
  256.     chdir $tmpdir or
  257.       return Error("can't chdir to $tmpdir: $!");
  258.  
  259.     # Download the tarball:
  260.     my ($bytes, $total, $s_time);
  261.     my $cb = sub {
  262.     my ($data, $res, $prot) = @_;
  263.     $total ||= $res->content_length;
  264.     print FILE $data;
  265.     $bytes += length($data);
  266.  
  267.     # Notify the user through the status callback:
  268.     $status_cb->($pkg, $ver, $tname, 'DOWNLOAD', 
  269.              $bytes, $total, $s_time - time);
  270.     };
  271.     my $ua = $o->{ua};
  272.     my $req = $o->new_request('GET', $codebase);
  273.     open(FILE, '>', $filename) or
  274.       return Error("can't write $filename: $!");
  275.     binmode(FILE) or
  276.       return Error("can't set $filename binary: $!");
  277.     $status_cb->($pkg, $ver, $tname, 'PRE-INSTALL', 0, 0, 0);
  278.     $s_time = time;
  279.     my $res = $ua->request($req, $cb, $cb_bytes);
  280.     unless ($res->is_success) {
  281.     close(FILE);
  282.     return Error("error downloading '$codebase': " . $res->status_line);
  283.     }
  284.     close(FILE) or
  285.       return Error("can't close $filename: $!");
  286.  
  287.     $status_cb->($pkg, $ver, $tname, 'PRE-EXPAND', $total, $total, 0);
  288.     my $ok = eval {
  289.     my $archive = PPM::Archive->new($filename);
  290.     my @files = $archive->list_files;
  291.     my $files = scalar @files;
  292.     my $n = 1;
  293.     for (@files) {
  294.         $status_cb->($pkg, $ver, $tname, 'EXPAND', $n, $files, $_);
  295.         $n++;
  296.         $archive->extract($_);
  297.         next unless -f $_;
  298.         my $ok = $target->transmit($pkg, $_);
  299.         return $ok unless $ok->ok;
  300.     }
  301.     Ok();
  302.     };
  303.     if ($@) {
  304.     return Error("$@"); # stringify it
  305.     }
  306.     return $ok unless $ok->ok;
  307.  
  308.     # Remove the tarball:
  309.     unlink $filename;
  310.  
  311.     # transmit() the install and uninstall scripts to the $target. If it knows
  312.     # how to use them, it will. Otherwise, it won't. YAY!
  313.     for my $thing (qw(install uninstall)) {
  314.     my $method = "${thing}_script";
  315.     my $script = $impl->result->$method;
  316.     next unless $script;
  317.  
  318.     if (my $href = $script->href) {
  319.         $href = $o->absolutize($href, $pkg);
  320.         my $req = $o->new_request('GET', $href);
  321.         my $res = $ua->request($req, $method);
  322.         $res->is_success or return Error(
  323.         "error downloading $thing script '$href': " .
  324.         $res->status_line
  325.         );
  326.     }
  327.     if (-f $method) {
  328.         $target->transmit($pkg, $method);
  329.     }
  330.     }
  331.  
  332.     chdir $cwd;
  333.     return $success_retval;
  334. }
  335.  
  336. sub init { 1 }
  337.  
  338. sub uptodate {
  339.     my $o = shift;
  340.     my $target = shift;
  341.     my $pkg = shift;
  342.     my $version = shift;
  343.     my $ppd = $o->describe($target, $pkg);
  344.     return $ppd unless $ppd->ok;
  345.     List($ppd->result->uptodate($version), $ppd->result->version);
  346. }
  347.  
  348. # Run multiple requests in one call, and return the list of results. This may
  349. # be overridden by sub-repositories if the server supports it. This default
  350. # version just calls each method.
  351. sub batch {
  352.     my $o = shift;
  353.     my $target = shift;
  354.     my @batch;
  355.     for my $task (@_) {
  356.     my ($meth, @args) = @$task;
  357.     push @batch, $o->$meth($target, @args);
  358.     }
  359.     List(@batch);
  360. }
  361.  
  362. sub uptodate2 {
  363.     my ($o, $targ, $pkg, $instver) = @_;
  364.  
  365.     # Check whether it's up to date:
  366.     my $ppd = $o->describe($targ, $pkg);
  367.     return $ppd unless $ppd->ok;
  368.     List($ppd->result->uptodate($instver), $ppd->result);
  369. }
  370.  
  371. sub location {
  372.     my $o = shift;
  373.     $o->{location};
  374. }
  375.  
  376. sub name {
  377.     my $o = shift;
  378.     return $o->{name};
  379. }
  380.  
  381. sub username {
  382.     my $o = shift;
  383.     return $o->{username};
  384. }
  385.  
  386. sub password {
  387.     my $o = shift;
  388.     return $o->{password};
  389. }
  390.  
  391. sub type {
  392.     my $o = shift;
  393.     $o->{type};
  394. }
  395.  
  396. sub protocol {
  397.     my $o = shift;
  398.     $o->{proto};
  399. }
  400.  
  401. sub parse_summary {
  402.     my $o = shift;
  403.     my $doc = shift;
  404.     my $cache_key = shift;
  405.     my $complete = shift;
  406.     $complete = 1 unless defined $complete;
  407.     return Ok($o->{cache}{$cache_key})
  408.       if defined $cache_key and exists $o->{cache}{$cache_key};
  409.     $doc =~ s/<\?xml[^>]+\?>//;
  410.     return Error("could not parse package summary")
  411.       unless $doc =~ /^\s*<REPOSITORYSUMMARY>/;
  412.     $doc =~ s|</?REPOSITORYSUMMARY>||g;
  413.     my %ppds =  map { $_->name, $_ }
  414.         map { @$_{qw(is_complete id)} = ($complete, $_->name); $_ }
  415.         map { $_ .= '</SOFTPKG>'; PPM::PPD->new($_, $o) }
  416.         grep { /\S/ }
  417.         split('</SOFTPKG>', $doc);
  418.     $o->{cache}{$cache_key} = \%ppds
  419.       if defined $cache_key;
  420.     return Ok(\%ppds);
  421. }
  422.  
  423. #=============================================================================
  424. # Profile stuff must be overridden in the PPM3 Server
  425. #=============================================================================
  426. sub profile_list    {
  427.     my $rep = shift;
  428.     my $name = $rep->name;
  429.     my $type = $rep->type_printable;
  430.     Error("Profiles are not supported on the repository '$name'. It is of type '$type', and only 'PPMServer 3.0' or better support profiles.");
  431. }
  432. sub profile_add     { goto &profile_list }
  433. sub profile_del     { goto &profile_list }
  434. sub profile_save    { goto &profile_list }
  435. sub profile_info    { goto &profile_list }
  436. sub profile_target_rename { goto &profile_list }
  437.  
  438. # Profile tracking
  439. sub installed { }
  440. sub upgraded  { }
  441. sub removed   { }
  442.  
  443. package PPM::Repository::Result;
  444. use Data::Dumper;
  445. use PPM::Config;
  446.  
  447. sub new {
  448.     my $p = shift;
  449.     my $msg = shift;
  450.     my $loc = shift;
  451.     my $code = shift || 1;;
  452.     my $site = q{R:\inetpub\wwwroot\www2.ActiveState.com};
  453.  
  454.     # If there's an error about the server being down:
  455.     if ($msg =~ m{\Q$site\E} or $msg =~ m{syntax error}) {
  456.     $msg = "The server '$loc' is not accepting SOAP connections. Please try again later.";
  457.     }
  458.     elsif ($msg =~ /obtaining a license/i) {
  459.     my $file = PPM::Config::get_license_file();
  460.     my $found = -f $file ? "is present" : "not found";
  461.     $msg = join ' ', $msg, "License file '$file' $found.";
  462.     }
  463.     return PPM::Result->new('', $code, $msg);
  464. }
  465.  
  466. 1;
  467.