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