home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _dec5d9f17be37b809b4e37a910ea435d < prev    next >
Encoding:
Text File  |  2004-06-01  |  6.9 KB  |  221 lines
  1. package PPM::Repository::PPMServer;
  2.  
  3. use strict;
  4. use PPM::PPD;
  5. use PPM::Search;
  6. use PPM::Result qw(Ok Error Warning List);
  7. use base qw(PPM::Repository);
  8. use vars qw($VERSION @ISA);
  9.  
  10. use Data::Dumper;
  11.  
  12. $VERSION = '3.06';
  13.  
  14. #=============================================================================
  15. # Note: The server appears to expose this interface:
  16. # search_ppds('archname', 'package', 'searchtag')
  17. # fetch_ppd('package')
  18. # fetch_summary()
  19. # packages()
  20. #=============================================================================
  21.  
  22. # The server-side search function only supports totally lame queries:
  23. sub search {
  24.     my $o = shift;
  25.     my $target = shift;
  26.     my $qstring = $o->mod_to_pkg(shift);
  27.     my ($q_type, $query, $searchtag) = parse_query($qstring);
  28.     my $casei = shift;
  29.  
  30.     my @ppds;
  31.     if ($q_type eq 'TRADITIONAL') {
  32.     substr($query, 0, 0) = "(?i)" if $casei;
  33.     my $archname = $target->config_get("ARCHITECTURE")->result;
  34.     my $data = eval {
  35.         $o->{client}->search_ppds($archname, $query, $searchtag)->result
  36.     };
  37.     if ($@) {
  38.         chomp $@;
  39.         return Error("server-side search failed: $@");
  40.     }
  41.     my $res = $o->parse_summary($data, $qstring);
  42.     return $res unless $res->ok;
  43.     @ppds = values %{$res->result};
  44.     }
  45.     else {
  46.     unless ($o->{full_summary}) {
  47.         my $data = eval {
  48.         $o->{client}->fetch_summary()->result
  49.         };
  50.         if ($@) {
  51.         chomp $@;
  52.         return Error("server-side summary fetch failed: $@");
  53.         }
  54.         $o->{full_summary} = $data;
  55.     }
  56.     my $res = $o->parse_summary($o->{full_summary}, 'full_summary');
  57.     return $res unless $res->ok;
  58.     my $compiled = PPM::PPD::Search->new($query, $casei);
  59.     return Error($compiled->error) unless $compiled->valid;
  60.         @ppds = $compiled->search(values %{$res->result});
  61.     }
  62.     $_->{is_complete} = 0 for @ppds;
  63.     return List(@ppds);
  64. }
  65.  
  66. sub describe {
  67.     my $o = shift;
  68.     my $target = shift;
  69.     my $pkg = $o->mod_to_pkg(shift);
  70.     my $ppd = $o->getppd($target, $pkg);
  71.     return $ppd unless $ppd->ok;
  72.     my $ppd_ref = PPM::PPD->new($ppd->result, $o, $pkg);
  73.     $ppd_ref->{from} = 'repository';
  74.     return Ok($ppd_ref);
  75. }
  76.  
  77. sub getppd {
  78.     my $o = shift;
  79.     my $target = shift;
  80.     my $pkg = $o->mod_to_pkg(shift);
  81.     my $ppd = eval { $o->{client}->fetch_ppd($pkg)->result };
  82.     if ($@) {
  83.     chomp $@;
  84.     return Error("server-side fetch-ppd failed: $@");
  85.     }
  86.     elsif (not $ppd) {
  87.     return Error("Package '$pkg' not found on server. "
  88.              . "Please 'search' for it first.");
  89.     }
  90.     Ok($ppd);
  91. }
  92.  
  93. sub load_pkg { }
  94. sub type_printable { "PPMServer 2.0" }
  95.  
  96. #=============================================================================
  97. # This query parser decides what type of query we're getting: a traditional
  98. # query which searches by TITLE only, or an advanced query:
  99. #=============================================================================
  100. sub parse_query {
  101.     my $query = shift;
  102.     
  103.     # If the query is '*', return everything:
  104.     if ($query eq '*') {
  105.     # Although we could do this with TRADITIONAL, it's actually faster to
  106.     # request the whole summary, and just return it directly. It's also
  107.     # more portable: the guy at theoryx5.uwinnipeg.ca decided not to
  108.     # implement empty searches. He must have reverse-engineered the PPM
  109.     # Server.
  110.     return ('ADVANCED', '');
  111.     }
  112.     # If there are only alphanumeric characters in it:
  113.     if ($query =~ /^[-_A-Za-z0-9]+$/) {
  114.     return ('TRADITIONAL', $query);
  115.     }
  116.     # If there's only 1 field spec: i.e. NAME=foo, or TITLE=bar
  117.     if ($query =~ /^([A-Za-z]+)=([-_A-Za-z0-9]+)$/ && is_traditional($1)) {
  118.     my ($f, $q) = (uc($1), $2);
  119.     $f = 'TITLE' if $f eq 'NAME'; # Required for the server
  120.     return ('TRADITIONAL', $q, $f);
  121.     }
  122.     # If there are only alphanumeric characters, plus '*' and '.' in it,
  123.     # convert it to the same regular expression PPM::Search would use, and let
  124.     # the server do it:
  125.     if ($query =~ /^[-_A-Za-z0-9\*\.\?]+$/) {
  126.     my $re = PPM::Search::glob_to_regex($query, 0);
  127.     return ('TRADITIONAL', "$re");
  128.     }
  129.  
  130.     # Otherwise, get the whole summary and use PPM::Search
  131.     return ('ADVANCED', $query);
  132. }
  133.  
  134. sub is_traditional {
  135.     my $field = uc(shift);
  136.     return scalar grep { $field eq $_ } qw(ABSTRACT AUTHOR TITLE NAME);
  137. }
  138.  
  139. #=============================================================================
  140. # The batch method, plus supporting setup_ and cleanup_ methods.
  141. #=============================================================================
  142. sub batch {
  143.     my $o = shift;
  144.  
  145.     # The batch() method was introduced to PPM2 in protocol version 201
  146.     return $o->SUPER::batch(@_) unless $o->protocol >= 201;
  147.  
  148.     my $targ = shift; # ignored
  149.     my @tasks = @_;
  150.  
  151.     # Because the PPMServer is quite lame, a lot of the PPMServer code is
  152.     # executed client-side. That means a more complicated batch() method:
  153.     # those methods which require client-side code are executed entirely
  154.     # client side. Those which don't are dispatched to the server in one go.
  155.     # The original task list is stitched back together after the call.
  156.     my @batch;   # this will actually be dispatched to the server.
  157.     my @results; # the dispatched slots are left undefined, so that
  158.  
  159.     # Decide what stuff to dispatch. Each setup method is free to munge
  160.     # arguments as needed. If $to_dispatch is false, the method will not be
  161.     # dispatched to the server, and $task is assumed to contain the result.
  162.     for my $i (0 .. $#tasks) {
  163.     my $task = $tasks[$i];
  164.     my $meth = "setup_$task->[0]";
  165.     if ($o->can($meth)) {
  166.         my $to_dispatch = $o->$meth($task);
  167.         if ($to_dispatch) {
  168.         push @batch, $task;
  169.         $results[$i] = undef;
  170.         }
  171.         else {
  172.         $results[$i] = $task;
  173.         }
  174.     }
  175.     }
  176.  
  177.     # Dispatch the batch, then stitch and patch. Atchoo!
  178.     my $response = eval {
  179.     $o->{client}->batch(@batch)->result;
  180.     };
  181.     if ($@) {
  182.     chomp $@;
  183.     return Error("batch method failed: $@");
  184.     }
  185.     elsif (not defined $response) {
  186.     return Error("batch method returned undefined results");
  187.     }
  188.  
  189.     # Stitch the results back together, calling cleanup methods as we go:
  190.     for my $i (0 .. $#results) {
  191.     $results[$i] = shift @$response unless defined $results[$i];
  192.     my $result = $results[$i];
  193.     if ($result->{error}) {
  194.         $results[$i] = Error($result->{error});
  195.     }
  196.     else {
  197.         my $method = "cleanup_$tasks[$i][0]";
  198.         $results[$i] = $o->can($method)
  199.         ? $o->$method($result->{result})
  200.         : Ok($result->{result});
  201.     }
  202.     }
  203.     List(@results);
  204. }
  205.  
  206. # Just tell it to dispatch to the server
  207. sub setup_uptodate2 { 1 }
  208.  
  209. sub cleanup_uptodate2 {
  210.     my ($o, $result) = @_;
  211.     my ($uptodate, $ppdtext) = @$result{qw(uptodate ppd)};
  212.     defined $uptodate and defined $ppdtext
  213.     or return Error("uptodate2 method returned undefined results");
  214.     my $ppd_ref = PPM::PPD->new($ppdtext, $o);
  215.     $ppd_ref->{id}   = $ppd_ref->name;
  216.     $ppd_ref->{from} = 'repository';
  217.     List($uptodate, $ppd_ref);
  218. }
  219.  
  220. 1;
  221.