home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _3ffaae2b68ffe6a2893aaaa8e044a98d < prev    next >
Text File  |  2000-03-15  |  7KB  |  285 lines
  1. # $Id: RobotUA.pm,v 1.15 1999/03/20 07:37:36 gisle Exp $
  2.  
  3. package LWP::RobotUA;
  4.  
  5. require LWP::UserAgent;
  6. @ISA = qw(LWP::UserAgent);
  7. $VERSION = sprintf("%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/);
  8.  
  9. require WWW::RobotRules;
  10. require HTTP::Request;
  11. require HTTP::Response;
  12.  
  13. use Carp ();
  14. use LWP::Debug ();
  15. use HTTP::Status ();
  16. use HTTP::Date qw(time2str);
  17. use strict;
  18.  
  19. =head1 NAME
  20.  
  21. LWP::RobotUA - A class for Web Robots
  22.  
  23. =head1 SYNOPSIS
  24.  
  25.   require LWP::RobotUA;
  26.   $ua = new LWP::RobotUA 'my-robot/0.1', 'me@foo.com';
  27.   $ua->delay(10);  # be very nice, go slowly
  28.   ...
  29.   # just use it just like a normal LWP::UserAgent
  30.   $res = $ua->request($req);
  31.  
  32. =head1 DESCRIPTION
  33.  
  34. This class implements a user agent that is suitable for robot
  35. applications.  Robots should be nice to the servers they visit.  They
  36. should consult the F</robots.txt> file to ensure that they are welcomed
  37. and they should not make requests too frequently.
  38.  
  39. But, before you consider writing a robot take a look at
  40. <URL:http://info.webcrawler.com/mak/projects/robots/robots.html>.
  41.  
  42. When you use a I<LWP::RobotUA> as your user agent, then you do not
  43. really have to think about these things yourself.  Just send requests
  44. as you do when you are using a normal I<LWP::UserAgent> and this
  45. special agent will make sure you are nice.
  46.  
  47. =head1 METHODS
  48.  
  49. The LWP::RobotUA is a sub-class of LWP::UserAgent and implements the
  50. same methods. In addition the following methods are provided:
  51.  
  52. =over 4
  53.  
  54. =cut
  55.  
  56.  
  57. #
  58. # Additional attributes in addition to those found in LWP::UserAgent:
  59. #
  60. # $self->{'delay'}    Required delay between request to the same
  61. #                     server in minutes.
  62. #
  63. # $self->{'rules'}     A WWW::RobotRules object
  64. #
  65.  
  66.  
  67. =item $ua = LWP::RobotUA->new($agent_name, $from, [$rules])
  68.  
  69. Your robot's name and the mail address of the human responsible for
  70. the robot (i.e. you) are required by the constructor.
  71.  
  72. Optionally it allows you to specify the I<WWW::RobotRules> object to
  73. use.
  74.  
  75. =cut
  76.  
  77. sub new
  78. {
  79.     my($class,$name,$from,$rules) = @_;
  80.  
  81.     Carp::croak('LWP::RobotUA name required') unless $name;
  82.     Carp::croak('LWP::RobotUA from address required') unless $from;
  83.  
  84.     my $self = new LWP::UserAgent;
  85.     $self = bless $self, $class;
  86.  
  87.     $self->{'delay'} = 1;   # minutes
  88.     $self->{'agent'} = $name;
  89.     $self->{'from'}  = $from;
  90.     $self->{'use_sleep'} = 1;
  91.  
  92.     if ($rules) {
  93.     $rules->agent($name);
  94.     $self->{'rules'} = $rules;
  95.     } else {
  96.     $self->{'rules'} = new WWW::RobotRules $name;
  97.     }
  98.  
  99.     $self;
  100. }
  101.  
  102.  
  103. =item $ua->delay([$minutes])
  104.  
  105. Set the minimum delay between requests to the same server.  The
  106. default is 1 minute.
  107.  
  108. =item $ua->use_sleep([$boolean])
  109.  
  110. Get/set a value indicating whether the UA should sleep() if requests
  111. arrive too fast (before $ua->delay minutes has passed).  The default is
  112. TRUE.  If this value is FALSE then an internal SERVICE_UNAVAILABLE
  113. response will be generated.  It will have an Retry-After header that
  114. indicates when it is OK to send another request to this server.
  115.  
  116. =cut
  117.  
  118. sub delay     { shift->_elem('delay',     @_); }
  119. sub use_sleep { shift->_elem('use_sleep', @_); }
  120.  
  121. sub agent
  122. {
  123.     my $self = shift;
  124.     my $old = $self->SUPER::agent(@_);
  125.     if (@_) {
  126.     # Changing our name means to start fresh
  127.     $self->{'rules'}->agent($self->{'agent'}); 
  128.     }
  129.     $old;
  130. }
  131.  
  132.  
  133. =item $ua->rules([$rules])
  134.  
  135. Set/get which I<WWW::RobotRules> object to use. 
  136.  
  137. =cut
  138.  
  139. sub rules {
  140.     my $self = shift;
  141.     my $old = $self->_elem('rules', @_);
  142.     $self->{'rules'}->agent($self->{'agent'}) if @_;
  143.     $old;
  144. }
  145.  
  146.  
  147. =item $ua->no_visits($netloc)
  148.  
  149. Returns the number of documents fetched from this server host. Yes I
  150. know, this method should probably have been named num_visits() or
  151. something like that. :-(
  152.  
  153. =cut
  154.  
  155. sub no_visits
  156. {
  157.     my($self, $netloc) = @_;
  158.     $self->{'rules'}->no_visits($netloc);
  159. }
  160.  
  161. *host_count = \&no_visits;  # backwards compatibility with LWP-5.02
  162.  
  163.  
  164. =item $ua->host_wait($netloc)
  165.  
  166. Returns the number of seconds (from now) you must wait before you can
  167. make a new request to this host.
  168.  
  169. =cut
  170.  
  171. sub host_wait
  172. {
  173.     my($self, $netloc) = @_;
  174.     return undef unless defined $netloc;
  175.     my $last = $self->{'rules'}->last_visit($netloc);
  176.     if ($last) {
  177.     my $wait = int($self->{'delay'} * 60 - (time - $last));
  178.     $wait = 0 if $wait < 0;
  179.     return $wait;
  180.     }
  181.     return 0;
  182. }
  183.  
  184.  
  185. sub simple_request
  186. {
  187.     my($self, $request, $arg, $size) = @_;
  188.  
  189.     LWP::Debug::trace('()');
  190.  
  191.     # Do we try to access a new server?
  192.     my $allowed = $self->{'rules'}->allowed($request->url);
  193.  
  194.     if ($allowed < 0) {
  195.     LWP::Debug::debug("Host is not visited before, or robots.txt expired.");
  196.     # fetch "robots.txt"
  197.     my $robot_url = $request->url->clone;
  198.     $robot_url->path("robots.txt");
  199.     $robot_url->query(undef);
  200.     LWP::Debug::debug("Requesting $robot_url");
  201.  
  202.     # make access to robot.txt legal since this will be a recursive call
  203.     $self->{'rules'}->parse($robot_url, ""); 
  204.  
  205.     my $robot_req = new HTTP::Request 'GET', $robot_url;
  206.     my $robot_res = $self->request($robot_req);
  207.     my $fresh_until = $robot_res->fresh_until;
  208.     if ($robot_res->is_success) {
  209.         LWP::Debug::debug("Parsing robot rules");
  210.         $self->{'rules'}->parse($robot_url, $robot_res->content, 
  211.                     $fresh_until);
  212.     } else {
  213.         LWP::Debug::debug("No robots.txt file found");
  214.         $self->{'rules'}->parse($robot_url, "", $fresh_until);
  215.     }
  216.  
  217.     # recalculate allowed...
  218.     $allowed = $self->{'rules'}->allowed($request->url);
  219.     }
  220.  
  221.     # Check rules
  222.     unless ($allowed) {
  223.     return new HTTP::Response
  224.       &HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt';
  225.     }
  226.  
  227.     my $netloc = $request->url->host_port;
  228.     my $wait = $self->host_wait($netloc);
  229.  
  230.     if ($wait) {
  231.     LWP::Debug::debug("Must wait $wait seconds");
  232.     if ($self->{'use_sleep'}) {
  233.         sleep($wait)
  234.     } else {
  235.         my $res = new HTTP::Response
  236.           &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down';
  237.         $res->header('Retry-After', time2str(time + $wait));
  238.         return $res;
  239.     }
  240.     }
  241.  
  242.     # Perform the request
  243.     my $res = $self->SUPER::simple_request($request, $arg, $size);
  244.  
  245.     $self->{'rules'}->visit($netloc);
  246.  
  247.     $res;
  248. }
  249.  
  250.  
  251. =item $ua->as_string
  252.  
  253. Returns a string that describes the state of the UA.
  254. Mainly useful for debugging.
  255.  
  256. =cut
  257.  
  258. sub as_string
  259. {
  260.     my $self = shift;
  261.     my @s;
  262.     push(@s, "Robot: $self->{'agent'} operated by $self->{'from'}  [$self]");
  263.     push(@s, "    Minimum delay: " . int($self->{'delay'}*60) . "s");
  264.     push(@s, "    Will sleep if too early") if $self->{'use_sleep'};
  265.     push(@s, "    Rules = $self->{'rules'}");
  266.     join("\n", @s, '');
  267. }
  268.  
  269. 1;
  270.  
  271. =back
  272.  
  273. =head1 SEE ALSO
  274.  
  275. L<LWP::UserAgent>, L<WWW::RobotRules>
  276.  
  277. =head1 COPYRIGHT
  278.  
  279. Copyright 1996-1997 Gisle Aas.
  280.  
  281. This library is free software; you can redistribute it and/or
  282. modify it under the same terms as Perl itself.
  283.  
  284. =cut
  285.