home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / LWP / RobotUA.pm < prev    next >
Text File  |  1997-11-06  |  7KB  |  282 lines

  1. # $Id: RobotUA.pm,v 1.10 1997/11/06 19:46:34 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. =cut
  56.  
  57.  
  58. #
  59. # Additional attributes in addition to those found in LWP::UserAgent:
  60. #
  61. # $self->{'delay'}    Required delay between request to the same
  62. #                     server in minutes.
  63. #
  64. # $self->{'rules'}     A WWW::RobotRules object
  65. #
  66.  
  67.  
  68. =head2 $ua = LWP::RobotUA->new($agent_name, $from, [$rules])
  69.  
  70. Your robot's name and the mail address of the human responsible for
  71. the robot (i.e. you) is required by the constructor.
  72.  
  73. Optionally it allows you to specify the I<WWW::RobotRules> object to
  74. use.
  75.  
  76. =cut
  77.  
  78. sub new
  79. {
  80.     my($class,$name,$from,$rules) = @_;
  81.  
  82.     Carp::croak('LWP::RobotUA name required') unless $name;
  83.     Carp::croak('LWP::RobotUA from address required') unless $from;
  84.  
  85.     my $self = new LWP::UserAgent;
  86.     $self = bless $self, $class;
  87.  
  88.     $self->{'delay'} = 1;   # minutes
  89.     $self->{'agent'} = $name;
  90.     $self->{'from'}  = $from;
  91.     $self->{'use_sleep'} = 1;
  92.  
  93.     if ($rules) {
  94.     $rules->agent($name);
  95.     $self->{'rules'} = $rules;
  96.     } else {
  97.     $self->{'rules'} = new WWW::RobotRules $name;
  98.     }
  99.  
  100.     $self;
  101. }
  102.  
  103.  
  104. =head2 $ua->delay([$minutes])
  105.  
  106. Set the minimum delay between requests to the same server.  The
  107. default is 1 minute.
  108.  
  109. =head2 $ua->use_sleep([$boolean])
  110.  
  111. Get/set a value indicating wether the UA should sleep() if request
  112. arrive to fast (before $ua->delay minutes has passed).  The default is
  113. TRUE.  If this value is FALSE then an internal SERVICE_UNAVAILABLE
  114. response will be generated.  It will have an Retry-After header that
  115. indicate when it is OK to send another request to this server.
  116.  
  117. =cut
  118.  
  119. sub delay     { shift->_elem('delay',     @_); }
  120. sub use_sleep { shift->_elem('use_sleep', @_); }
  121.  
  122. sub agent
  123. {
  124.     my $self = shift;
  125.     my $old = $self->SUPER::agent(@_);
  126.     if (@_) {
  127.     # Changing our name means to start fresh
  128.     $self->{'rules'}->agent($self->{'agent'}); 
  129.     }
  130.     $old;
  131. }
  132.  
  133.  
  134. =head2 $ua->rules([$rules])
  135.  
  136. Set/get which I<WWW::RobotRules> object to use. 
  137.  
  138. =cut
  139.  
  140. sub rules {
  141.     my $self = shift;
  142.     my $old = $self->_elem('rules', @_);
  143.     $self->{'rules'}->agent($self->{'agent'}) if @_;
  144.     $old;
  145. }
  146.  
  147.  
  148. =head2 $ua->no_visits($netloc)
  149.  
  150. Returns the number of documents fetched from this server host. Yes I
  151. know, this method should probably have been named num_visits() or
  152. something like that :-(
  153.  
  154. =cut
  155.  
  156. sub no_visits
  157. {
  158.     my($self, $netloc) = @_;
  159.     $self->{'rules'}->no_visits($netloc);
  160. }
  161.  
  162. *host_count = \&no_visits;  # backwards compatibility with LWP-5.02
  163.  
  164.  
  165. =head2 $ua->host_wait($netloc)
  166.  
  167. Returns the number of seconds (from now) you must wait before you can
  168. make a new request to this host.
  169.  
  170. =cut
  171.  
  172. sub host_wait
  173. {
  174.     my($self, $netloc) = @_;
  175.     return undef unless defined $netloc;
  176.     my $last = $self->{'rules'}->last_visit($netloc);
  177.     if ($last) {
  178.     my $wait = int($self->{'delay'} * 60 - (time - $last));
  179.     $wait = 0 if $wait < 0;
  180.     return $wait;
  181.     }
  182.     return 0;
  183. }
  184.  
  185.  
  186. sub simple_request
  187. {
  188.     my($self, $request, $arg, $size) = @_;
  189.  
  190.     LWP::Debug::trace('()');
  191.  
  192.     # Do we try to access a new server?
  193.     my $allowed = $self->{'rules'}->allowed($request->url);
  194.  
  195.     if ($allowed < 0) {
  196.     LWP::Debug::debug("Host is not visited before, or robots.txt expired.");
  197.     # fetch "robots.txt"
  198.     my $robot_url = $request->url->clone;
  199.     $robot_url->path("robots.txt");
  200.     $robot_url->params(undef);
  201.     $robot_url->query(undef);
  202.     LWP::Debug::debug("Requesting $robot_url");
  203.  
  204.     # make access to robot.txt legal since this will be a recursive call
  205.     $self->{'rules'}->parse($robot_url, ""); 
  206.  
  207.     my $robot_req = new HTTP::Request 'GET', $robot_url;
  208.     my $robot_res = $self->request($robot_req);
  209.     my $fresh_until = $robot_res->fresh_until;
  210.     if ($robot_res->is_success) {
  211.         LWP::Debug::debug("Parsing robot rules");
  212.         $self->{'rules'}->parse($robot_url, $robot_res->content, 
  213.                     $fresh_until);
  214.     } else {
  215.         LWP::Debug::debug("No robots.txt file found");
  216.         $self->{'rules'}->parse($robot_url, "", $fresh_until);
  217.     }
  218.  
  219.     # recalculate allowed...
  220.     $allowed = $self->{'rules'}->allowed($request->url);
  221.     }
  222.  
  223.     # Check rules
  224.     unless ($allowed) {
  225.     return new HTTP::Response
  226.       &HTTP::Status::RC_FORBIDDEN, 'Forbidden by robots.txt';
  227.     }
  228.  
  229.     my $netloc = $request->url->netloc;
  230.     my $wait = $self->host_wait($netloc);
  231.  
  232.     if ($wait) {
  233.     LWP::Debug::debug("Must wait $wait seconds");
  234.     if ($self->{'use_sleep'}) {
  235.         sleep($wait)
  236.     } else {
  237.         my $res = new HTTP::Response
  238.           &HTTP::Status::RC_SERVICE_UNAVAILABLE, 'Please, slow down';
  239.         $res->header('Retry-After', time2str(time + $wait));
  240.         return $res;
  241.     }
  242.     }
  243.  
  244.     # Perform the request
  245.     my $res = $self->SUPER::simple_request($request, $arg, $size);
  246.  
  247.     $self->{'rules'}->visit($netloc);
  248.  
  249.     $res;
  250. }
  251.  
  252.  
  253. =head2 $ua->as_string
  254.  
  255. Returns a text that describe the state of the UA.
  256. Mainly useful for debugging.
  257.  
  258. =cut
  259.  
  260. sub as_string
  261. {
  262.     my $self = shift;
  263.     my @s;
  264.     push(@s, "Robot: $self->{'agent'} operated by $self->{'from'}  [$self]");
  265.     push(@s, "    Minimum delay: " . int($self->{'delay'}*60) . "s");
  266.     push(@s, "    Will sleep if too early") if $self->{'use_sleep'};
  267.     push(@s, "    Rules = $self->{'rules'}");
  268.     join("\n", @s, '');
  269. }
  270.  
  271. 1;
  272.  
  273. =head1 SEE ALSO
  274.  
  275. L<LWP::UserAgent>, L<WWW::RobotRules>
  276.  
  277. =head1 AUTHOR
  278.  
  279. Gisle Aas E<lt>aas@sn.no>
  280.  
  281. =cut
  282.