File Coverage

blib/lib/CPAN/WAIT.pm

Criterion	Covered	Total	%
statement	7	86	8.1
branch	1	40	2.5
condition	0	51	0.0
subroutine	3	9	33.3
pod	5	5	100.0
total	16	191	8.3

#                              -*- Mode: Perl -*-
# $Basename: WAIT.pm $
# $Revision: 1.6 $
# Author          : Ulrich Pfeifer
# Created On      : Fri Jan 31 11:30:46 1997
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Thu Mar 23 21:19:20 2000
# Language        : CPerl
# Update Count    : 145
# Status          : Unknown, Use with caution!
#
# (C) Copyright 1997, Ulrich Pfeifer, all rights reserved.
#
#

package CPAN::WAIT;
use ExtUtils::MakeMaker; # MM->catfile

# try to avoid 'use'ing CPAN.pm
# code stolen from CPAN::Config::load ;

eval {require CPAN::Config;};       # We eval because of some
                                    # MakeMaker problems
unless ($CPAN::dot_cpan++){
  unshift @INC, MM->catdir($ENV{HOME},".cpan");
  eval {require CPAN::MyConfig;};   # where you can override
                                    # system wide settings
  shift @INC;
}



require WAIT::Client;
require FileHandle;
use vars qw($VERSION $DEBUG $TIMEOUT);

# $Format: "\$\V\E\R\S\I\O\N = '$ModuleVersion$';"$ MM_Unix bug
$VERSION = '0.27';
$TIMEOUT = 20;                  # Set this to some larger value if you
                                # have a slow connection.

sub _open_connection () {
  my ($host, $port, $con);

  # Make sure that there is a wait server to try
  unless ($CPAN::Config->{'wait_list'}) {
    $CPAN::Config->{'wait_list'} = ['wait://ls6.informatik.uni-dortmund.de'];
  }

  # Try direct connection
  my $server;
 SERVER:
  for $server (@{$CPAN::Config->{'wait_list'}}) {
    warn "CPAN::WAIT $VERSION checking $server\n" if $DEBUG;
    if ($server =~ m(^wait://([^:]+)(?::(\d+))?)) {
      ($host, $port) = ($1, $2 || 1404);
      # Constructor is inherited from Net::NNTP
      $con = WAIT::Client->new($host, Port => $port, Timeout => $TIMEOUT)
        unless $DEBUG and $DEBUG =~ /force proxy/;
      last SERVER if $con;
    }
  }

  # Try connection via an http proxy
  unless ($con) {
    warn "Could not connect to the WAIT server at $host port $port\n"
      unless $DEBUG and $DEBUG =~ /force proxy/;

    if ($CPAN::Config->{'http_proxy'}) {
      print "Trying your http proxy $CPAN::Config->{'http_proxy'}\n";
    SERVER:
      for $server (@{$CPAN::Config->{'wait_list'}}) {
        if ($server =~ m(^wait://([^:]+)(?::(\d+))?)) {
          ($host, $port) = ($1, $2 || 1404);
          $con = WAIT::Client::HTTP->new($host,
                                         Port  => $port,
                                         Proxy => $CPAN::Config->{'http_proxy'},
                                         Timeout => $TIMEOUT);
          last SERVER if $con;
        }
      }
      warn "No luck with your proxy either. Giving up\n"
        unless $con;
    } else {
      warn "You did not tell the CPAN module about an http proxy.\n" .
        "I could use such a beast instead of a direct connection.\n";
    }
  }

  # We had no luck.
  warn "No searching available!\n" unless $con;

  return $con;
}

my $con;
# Temporary file for retrieved documents
my $tmp = MM->catfile($CPAN::Config->{'cpan_home'}, 'w4c.pod');

# run a search
sub wq {
  my $self = shift;
  my $result;
  local ($") = ' ';

  $con ||= _open_connection || return;
  print "Searching for '@_'\n";
  unless ($result = $con->search(@_)) {
    print "Your query contains a syntax error.\n";
    $self->wh('wq');
  } else {
    print $con->message;
    print @{$result};
    print "Type 'wr ' or 'wd ' to examine the results\n";
  }
  $result;
}

# display hit record
sub wr {
  my $self = shift;
  my $hit  = shift;
  my $result;

  if (@_ or !$hit) {
    print "USAGE: wr \n";
  } else {
    $con ||= _open_connection || return;
    print "fetching info on hit number $hit\n";
    $result = $con->info($hit);
    print @$result;
  }
  $result;
}

# display hit document
sub wd {
  my $self = shift;
  my $hit  = shift;
  my $result;

  if (@_ or !$hit) {
    print "USAGE: wd \n";
    return;
  }
  $con ||= _open_connection || return;
  print "Get hit number $hit ...";
  my $text  = $con->get($hit);
  my $lines = ($text)?@$text:'no';
  print " done\nGot $lines lines\nRunning perldoc on it ...\n";

  # perldoc does not read STDIN; so we need a temp file
  {
    my $fh = new FileHandle ">$tmp";
    $fh->print(@{$text});
  }

  # is system available every were ??
  system $^X, '-S', 'perldoc', $tmp
    and warn "Could not run '$^X -S perldoc $tmp': $?\n"
      and system $Config{'pager'}, $tmp
        and warn "Could not run '$Config{'pager'} $tmp': $?\n"
          and print @$text;
  $text;
}

sub wl {
  my $self = shift;
  my $hits = shift;

  if (@_) {
    print "USAGE: wl \n";
    return;
  }
  $con ||= _open_connection || return;
  print "Setting maximum hit count to $hits\n";
  $con->hits($hits);
}

my %HELP =
  (
   'h' => q{
'wh'           displays a short summary of commands available via the WAIT
               plugin.
'wh ' displays information about a the command given as argument
   },
   'q' => q{
Here are some query examples:

information retrieval               free text query
information or retrieval            same as above
des=information retrieval           `information' must be in the description
des=(information retrieval)         one of them in description
des=(information or retrieval)      same as above
des=(information and retrieval)     both of them in description
des=(information not retrieval)     `information' in description and
                                    `retrieval' not in description
des=(information system*)           wild-card search
au=ilia                             author names may be misspelled

You can build arbitary boolean combination of the above examples.
The following fields are known:

  'synopsis', 'name', 'bugs', 'author', 'example', 'description',
  'environment'

Field names may be abbreviated.
},
   'r' => q{
'wr '  displays the record of the selected hit. Records look
                   like this:

   source          authors/id/CHIPS/perl5.003_24.tar.gz
   headline        perl - Practical Extraction and Report Language
   size            12786
   docid           data/perl/pod/perl.pod

'source'   is the patch relative to http://www.perl.org/CPAN/.
'headline' is the contents of the 'NAME' section of the POD document
'size'     is the size of the POD document (not the size of the tar archive)!
'docid'    is the path the POS document is stored in. It should be the
           path in the tar archive minus the version number + a 'data'
           prefix.
   },
   'l' => q{
Since answers to queries are sorted by decreasing probability of relevance,
you will probably be interested only in the first few hits. To limit the amout
of network traffic, the WAIT server only returns the best 10 hits per default.
You can change this limit with 'wl '.
   },
   'd' => q{
The 'wd ' command retrieves the POD document form the
server and stores it in the file 'w2c' in your CPAN directory. Then it
runs 'perlpod' on it. If you have problems, check if you local
'perlpod' works with absolute path names. Older versions are know to
fail. Also try to avoid fetching of large documents like 'perlfunc.pod'.
Use 'wr ' to see how large the documents are before fetching
the actually if you have a slow connection.
},

  );

sub wh {
  my $self = shift;
  my $cmd  = shift;

  if ($cmd and $cmd =~ /(\w)$/) {
    print $HELP{$1} || "No help for 'w$1' yet.\n";
  } else {
    print qq[
Available commands:
wq        query           search the WAIT4CPAN server
wr        hit-number      display search result record
wd        hit-number      fetch the document and run perldoc on it
wl        count           limit search to  hits
wh        command         displays help on command if available
];
  }
  1;
}

END {
  unlink $tmp if -e $tmp;
}

1;

__DATA__