home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _9e860ac0273bd61bf4eb28fc1b97e219 < prev    next >
Encoding:
Text File  |  2004-06-01  |  4.8 KB  |  171 lines
  1. package PPM::Repository::WWW;
  2.  
  3. use strict;
  4.  
  5. use File::Listing;    # part of LWP - used to parse FTP-style dir listings
  6. use PPM::PPD;
  7. use PPM::Search;
  8. use PPM::Result qw(Ok Error Warning List);
  9.  
  10. use Data::Dumper;
  11.  
  12. use base qw(PPM::Repository);
  13. use vars qw($VERSION);
  14. $VERSION = '3.05';
  15.  
  16. sub search {
  17.     my $o = shift;
  18.     my $target = shift;
  19.     my $query = shift;
  20.     my $case = shift;
  21.     my $res;
  22.     $res = $o->load_pkgs($target);
  23.     return $res unless $res->ok;
  24.     $query = $o->mod_to_pkg($query);
  25.     my $compiled = PPM::PPD::Search->new($query, $case);
  26.     return Error($compiled->error) unless $compiled->valid;
  27.     my @pkgs = $compiled->search($o->pkgs);
  28.     List(@pkgs);
  29. }
  30.  
  31. sub getppd {
  32.     my $o = shift;
  33.     my $target = shift;
  34.     my $pkg = $o->mod_to_pkg(shift);
  35.     my $res = $o->describe($target, $pkg);
  36.     return $res unless $res->ok;
  37.     return Ok($res->result->ppd);
  38. }
  39.  
  40. # Load the PPD at the given URL. The unique key will be the URL.
  41. sub describe {
  42.     my $o = shift;
  43.     my $target = shift;
  44.     my $rel = shift;
  45.     my $url = $o->absolutize($rel);
  46.     $url .= ".ppd" unless $url =~ /\.ppd$/i;
  47.     return Ok($o->{ppds}{$url})
  48.     if exists $o->{ppds}{$url} and $o->{ppds}{$url}->is_complete;
  49.  
  50.     my $req = $o->new_request('GET', $url);
  51.     my $res = $o->{ua}->request($req);
  52.     return Error("Failed to download URL $url: " . $res->status_line)
  53.     unless $res->is_success;
  54.     $o->{ppds}{$url} = PPM::PPD->new($res->content, $o, $url);
  55.     $o->{ppds}{$url}{from} = 'repository';
  56.     Ok($o->{ppds}{$url});
  57. }
  58.  
  59. sub load_pkgs {
  60.     my $o = shift;
  61.     my $target = shift;
  62.     return Ok() if $o->{pkgs_loaded};
  63.  
  64.     # A list of files to try downloading. These are listed in preferred order:
  65.     # the summary is the smallest, followed by the search summary (why?), and
  66.     # finally the package.lst is just the concatenation of all the packages.
  67.     # The values represent whether the generated PPDs are "complete", or
  68.     # whether we'll need to re-fetch them.
  69.     my @indices = (
  70.     # INDEX            COMPLETE    PARSE METHOD
  71.     'summary.ppm'        => 0        => summary =>
  72.     'searchsummary.ppm'    => 0        => summary =>
  73.     'package.lst'        => 1        => summary =>
  74.     ''            => 0        => listing =>
  75.     );
  76.  
  77.     # This closure calls the appropriate parse method with the right
  78.     # arguments, depending on how the thing needs to be parsed.
  79.     my $parser = sub {
  80.     my $o = shift;
  81.     my ($doc, $complete, $method) = @_;
  82.     return $o->parse_summary($doc, undef, $complete)
  83.         if $method eq 'summary';
  84.     return $o->parse_listing($doc, $target)
  85.         if $method eq 'listing';
  86.     die "internal error: PPM::Repository::WWW::load_pkgs corrupted.";
  87.     };
  88.  
  89.     # NOTE: it may pay to provide a callback to update the UI for very long
  90.     # downloads of package.lst files:
  91.     delete $o->{ppds};
  92.     my $error;
  93.     while (@indices) {
  94.     my ($index, $complete, $parse_method) = splice @indices, 0, 3;
  95.     my $url = $o->absolutize($index);
  96.     my $req = $o->new_request('GET', $url);
  97.     my $res = $o->{ua}->request($req);
  98.     $error = $res->status_line, next unless $res->is_success;
  99.     my $smry = $o->$parser($res->content, $complete, $parse_method);
  100.     return $smry unless $smry->ok;
  101.     $o->{ppds} = $smry->result;
  102.     last;
  103.     }
  104.     return Error("couldn't download package list from $o->{url}: $error")
  105.     unless $o->{ppds} and %{$o->{ppds} || {}};
  106.  
  107.     $o->{pkgs_loaded} = 1;
  108.     Ok();
  109. }
  110.  
  111. sub parse_listing {
  112.     my $o = shift;
  113.     my $doc = shift;
  114.     my $target = shift;
  115.     my @urls;
  116.  
  117.     # FTP-style directory listing
  118.     if ($doc =~ /^total\s+(\d+)\s+[-rwx]{9,}/) {
  119.     @urls = grep { m/\.ppd$/i }
  120.         map  { $$_[0] }
  121.         grep { $$_[1] eq 'f' }
  122.         parse_dir($doc);
  123.     }
  124. #    # IIS format directory listing
  125. #    elsif ($doc =~ /^<head><title>/) {
  126. #    @ppds = map  { s/\.ppd<.*$//is; s/.*>//is; $_ }
  127. #        grep { m/\.ppd/i }
  128. #        split('<br>', $doc);
  129. #    }
  130. #    # output of default.prk
  131. #    elsif ($doc =~ /<BODY BGCOLOR=FFFFFF>\n\n<form name=VPMform/s) {
  132. #    @ppds = map  { /^<!--Key:(.*)-->$/; $1 }
  133. #        grep { /^<!--Key:.*-->$/ }
  134. #        split('\n', $doc);
  135. #    }
  136.     # pick up all plain "*.ppd" links
  137.     else {
  138.     require HTML::Parser;
  139.     my $p = HTML::Parser->new(api_version => 3,
  140.                   report_tags => ['a', 'base'],
  141.                   start_h => [sub {
  142.                       my $tag = shift;
  143.                       my $href = shift->{href} || return;
  144.                       if ($tag eq 'base') {
  145.                       $o->{url_base} = URI->new_abs(
  146.                           $href,
  147.                           $o->{url_base}
  148.                       );
  149.                       }
  150.                       else {
  151.                       return unless $href =~ /\.ppd$/i;
  152.                       push(@urls, $href);
  153.                       }
  154.                   }, "tagname,attr"],
  155.                  );
  156.     $p->parse($doc)->eof;
  157.     }
  158.     $o->describe($target, $_) for @urls;
  159.     unless (keys %{$o->{ppds}}) {
  160.     return Error("may not be a PPM repository.");
  161.     }
  162.     return Ok($o->{ppds});
  163. }
  164.  
  165. sub pkgs {
  166.     my $o = shift;
  167.     return values %{$o->{ppds}};
  168. }
  169.  
  170. sub type_printable { "Webpage" }
  171.