home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _cb70ba6e1c67e5bcbb02d5eb9579fac4 < prev    next >
Text File  |  2004-06-01  |  10KB  |  410 lines
  1. package WWW::RobotRules;
  2.  
  3. # $Id: RobotRules.pm,v 1.30 2004/04/09 15:09:14 gisle Exp $
  4.  
  5. $VERSION = sprintf("%d.%02d", q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/);
  6. sub Version { $VERSION; }
  7.  
  8. use strict;
  9. use URI ();
  10.  
  11.  
  12.  
  13. sub new {
  14.     my($class, $ua) = @_;
  15.  
  16.     # This ugly hack is needed to ensure backwards compatibility.
  17.     # The "WWW::RobotRules" class is now really abstract.
  18.     $class = "WWW::RobotRules::InCore" if $class eq "WWW::RobotRules";
  19.  
  20.     my $self = bless { }, $class;
  21.     $self->agent($ua);
  22.     $self;
  23. }
  24.  
  25.  
  26. sub parse {
  27.     my($self, $robot_txt_uri, $txt, $fresh_until) = @_;
  28.     $robot_txt_uri = URI->new("$robot_txt_uri");
  29.     my $netloc = $robot_txt_uri->host . ":" . $robot_txt_uri->port;
  30.  
  31.     $self->clear_rules($netloc);
  32.     $self->fresh_until($netloc, $fresh_until || (time + 365*24*3600));
  33.  
  34.     my $ua;
  35.     my $is_me = 0;        # 1 iff this record is for me
  36.     my $is_anon = 0;        # 1 iff this record is for *
  37.     my @me_disallowed = ();    # rules disallowed for me
  38.     my @anon_disallowed = ();    # rules disallowed for *
  39.  
  40.     # blank lines are significant, so turn CRLF into LF to avoid generating
  41.     # false ones
  42.     $txt =~ s/\015\012/\012/g;
  43.  
  44.     # split at \012 (LF) or \015 (CR) (Mac text files have just CR for EOL)
  45.     for(split(/[\012\015]/, $txt)) {
  46.  
  47.     # Lines containing only a comment are discarded completely, and
  48.         # therefore do not indicate a record boundary.
  49.     next if /^\s*\#/;
  50.  
  51.     s/\s*\#.*//;        # remove comments at end-of-line
  52.  
  53.     if (/^\s*$/) {        # blank line
  54.         last if $is_me; # That was our record. No need to read the rest.
  55.         $is_anon = 0;
  56.     }
  57.         elsif (/^\s*User-Agent\s*:\s*(.*)/i) {
  58.         $ua = $1;
  59.         $ua =~ s/\s+$//;
  60.         if ($is_me) {
  61.         # This record already had a User-agent that
  62.         # we matched, so just continue.
  63.         }
  64.         elsif ($ua eq '*') {
  65.         $is_anon = 1;
  66.         }
  67.         elsif($self->is_me($ua)) {
  68.         $is_me = 1;
  69.         }
  70.     }
  71.     elsif (/^\s*Disallow\s*:\s*(.*)/i) {
  72.         unless (defined $ua) {
  73.         warn "RobotRules: Disallow without preceding User-agent\n";
  74.         $is_anon = 1;  # assume that User-agent: * was intended
  75.         }
  76.         my $disallow = $1;
  77.         $disallow =~ s/\s+$//;
  78.         if (length $disallow) {
  79.         my $ignore;
  80.         eval {
  81.             my $u = URI->new_abs($disallow, $robot_txt_uri);
  82.             $ignore++ if $u->scheme ne $robot_txt_uri->scheme;
  83.             $ignore++ if lc($u->host) ne lc($robot_txt_uri->host);
  84.             $ignore++ if $u->port ne $robot_txt_uri->port;
  85.             $disallow = $u->path_query;
  86.             $disallow = "/" unless length $disallow;
  87.         };
  88.         next if $@;
  89.         next if $ignore;
  90.         }
  91.  
  92.         if ($is_me) {
  93.         push(@me_disallowed, $disallow);
  94.         }
  95.         elsif ($is_anon) {
  96.         push(@anon_disallowed, $disallow);
  97.         }
  98.     }
  99.     else {
  100.         warn "RobotRules: Unexpected line: $_\n";
  101.     }
  102.     }
  103.  
  104.     if ($is_me) {
  105.     $self->push_rules($netloc, @me_disallowed);
  106.     }
  107.     else {
  108.     $self->push_rules($netloc, @anon_disallowed);
  109.     }
  110. }
  111.  
  112.  
  113. #
  114. # Returns TRUE if the given name matches the
  115. # name of this robot
  116. #
  117. sub is_me {
  118.     my($self, $ua_line) = @_;
  119.     my $me = $self->agent;
  120.  
  121.     # See whether my short-name is a substring of the
  122.     #  "User-Agent: ..." line that we were passed:
  123.     
  124.     if(index(lc($me), lc($ua_line)) >= 0) {
  125.       LWP::Debug::debug("\"$ua_line\" applies to \"$me\"")
  126.        if defined &LWP::Debug::debug;
  127.       return 1;
  128.     }
  129.     else {
  130.       LWP::Debug::debug("\"$ua_line\" does not apply to \"$me\"")
  131.        if defined &LWP::Debug::debug;
  132.       return '';
  133.     }
  134. }
  135.  
  136.  
  137. sub allowed {
  138.     my($self, $uri) = @_;
  139.     $uri = URI->new("$uri");
  140.     
  141.     return 1 unless $uri->scheme eq 'http' or $uri->scheme eq 'https';
  142.      # Robots.txt applies to only those schemes.
  143.     
  144.     my $netloc = $uri->host . ":" . $uri->port;
  145.  
  146.     my $fresh_until = $self->fresh_until($netloc);
  147.     return -1 if !defined($fresh_until) || $fresh_until < time;
  148.  
  149.     my $str = $uri->path_query;
  150.     my $rule;
  151.     for $rule ($self->rules($netloc)) {
  152.     return 1 unless length $rule;
  153.     return 0 if index($str, $rule) == 0;
  154.     }
  155.     return 1;
  156. }
  157.  
  158.  
  159. # The following methods must be provided by the subclass.
  160. sub agent;
  161. sub visit;
  162. sub no_visits;
  163. sub last_visits;
  164. sub fresh_until;
  165. sub push_rules;
  166. sub clear_rules;
  167. sub rules;
  168. sub dump;
  169.  
  170.  
  171.  
  172. package WWW::RobotRules::InCore;
  173.  
  174. use vars qw(@ISA);
  175. @ISA = qw(WWW::RobotRules);
  176.  
  177.  
  178.  
  179. sub agent {
  180.     my ($self, $name) = @_;
  181.     my $old = $self->{'ua'};
  182.     if ($name) {
  183.         # Strip it so that it's just the short name.
  184.         # I.e., "FooBot"                                      => "FooBot"
  185.         #       "FooBot/1.2"                                  => "FooBot"
  186.         #       "FooBot/1.2 [http://foobot.int; foo@bot.int]" => "FooBot"
  187.  
  188.     delete $self->{'loc'};   # all old info is now stale
  189.     $name = $1 if $name =~ m/(\S+)/; # get first word
  190.     $name =~ s!/.*!!;  # get rid of version
  191.     $self->{'ua'}=$name;
  192.     }
  193.     $old;
  194. }
  195.  
  196.  
  197. sub visit {
  198.     my($self, $netloc, $time) = @_;
  199.     return unless $netloc;
  200.     $time ||= time;
  201.     $self->{'loc'}{$netloc}{'last'} = $time;
  202.     my $count = \$self->{'loc'}{$netloc}{'count'};
  203.     if (!defined $$count) {
  204.     $$count = 1;
  205.     }
  206.     else {
  207.     $$count++;
  208.     }
  209. }
  210.  
  211.  
  212. sub no_visits {
  213.     my ($self, $netloc) = @_;
  214.     $self->{'loc'}{$netloc}{'count'};
  215. }
  216.  
  217.  
  218. sub last_visit {
  219.     my ($self, $netloc) = @_;
  220.     $self->{'loc'}{$netloc}{'last'};
  221. }
  222.  
  223.  
  224. sub fresh_until {
  225.     my ($self, $netloc, $fresh_until) = @_;
  226.     my $old = $self->{'loc'}{$netloc}{'fresh'};
  227.     if (defined $fresh_until) {
  228.     $self->{'loc'}{$netloc}{'fresh'} = $fresh_until;
  229.     }
  230.     $old;
  231. }
  232.  
  233.  
  234. sub push_rules {
  235.     my($self, $netloc, @rules) = @_;
  236.     push (@{$self->{'loc'}{$netloc}{'rules'}}, @rules);
  237. }
  238.  
  239.  
  240. sub clear_rules {
  241.     my($self, $netloc) = @_;
  242.     delete $self->{'loc'}{$netloc}{'rules'};
  243. }
  244.  
  245.  
  246. sub rules {
  247.     my($self, $netloc) = @_;
  248.     if (defined $self->{'loc'}{$netloc}{'rules'}) {
  249.     return @{$self->{'loc'}{$netloc}{'rules'}};
  250.     }
  251.     else {
  252.     return ();
  253.     }
  254. }
  255.  
  256.  
  257. sub dump
  258. {
  259.     my $self = shift;
  260.     for (keys %$self) {
  261.     next if $_ eq 'loc';
  262.     print "$_ = $self->{$_}\n";
  263.     }
  264.     for (keys %{$self->{'loc'}}) {
  265.     my @rules = $self->rules($_);
  266.     print "$_: ", join("; ", @rules), "\n";
  267.     }
  268. }
  269.  
  270.  
  271. 1;
  272.  
  273. __END__
  274.  
  275.  
  276. # Bender: "Well, I don't have anything else
  277. #          planned for today.  Let's get drunk!"
  278.  
  279. =head1 NAME
  280.  
  281. WWW::RobotRules - database of robots.txt-derived permissions
  282.  
  283. =head1 SYNOPSIS
  284.  
  285.  use WWW::RobotRules;
  286.  my $rules = WWW::RobotRules->new('MOMspider/1.0');
  287.  
  288.  use LWP::Simple qw(get);
  289.  
  290.  {
  291.    my $url = "http://some.place/robots.txt";
  292.    my $robots_txt = get $url;
  293.    $rules->parse($url, $robots_txt) if defined $robots_txt;
  294.  }
  295.  
  296.  {
  297.    my $url = "http://some.other.place/robots.txt";
  298.    my $robots_txt = get $url;
  299.    $rules->parse($url, $robots_txt) if defined $robots_txt;
  300.  }
  301.  
  302.  # Now we can check if a URL is valid for those servers
  303.  # whose "robots.txt" files we've gotten and parsed:
  304.  if($rules->allowed($url)) {
  305.      $c = get $url;
  306.      ...
  307.  }
  308.  
  309. =head1 DESCRIPTION
  310.  
  311. This module parses F</robots.txt> files as specified in
  312. "A Standard for Robot Exclusion", at
  313. <http://www.robotstxt.org/wc/norobots.html>
  314. Webmasters can use the F</robots.txt> file to forbid conforming
  315. robots from accessing parts of their web site.
  316.  
  317. The parsed files are kept in a WWW::RobotRules object, and this object
  318. provides methods to check if access to a given URL is prohibited.  The
  319. same WWW::RobotRules object can be used for one or more parsed
  320. F</robots.txt> files on any number of hosts.
  321.  
  322. The following methods are provided:
  323.  
  324. =over 4
  325.  
  326. =item $rules = WWW::RobotRules->new($robot_name)
  327.  
  328. This is the constructor for WWW::RobotRules objects.  The first
  329. argument given to new() is the name of the robot.
  330.  
  331. =item $rules->parse($robot_txt_url, $content, $fresh_until)
  332.  
  333. The parse() method takes as arguments the URL that was used to
  334. retrieve the F</robots.txt> file, and the contents of the file.
  335.  
  336. =item $rules->allowed($uri)
  337.  
  338. Returns TRUE if this robot is allowed to retrieve this URL.
  339.  
  340. =item $rules->agent([$name])
  341.  
  342. Get/set the agent name. NOTE: Changing the agent name will clear the robots.txt
  343. rules and expire times out of the cache.
  344.  
  345. =back
  346.  
  347. =head1 ROBOTS.TXT
  348.  
  349. The format and semantics of the "/robots.txt" file are as follows
  350. (this is an edited abstract of
  351. <http://www.robotstxt.org/wc/norobots.html> ):
  352.  
  353. The file consists of one or more records separated by one or more
  354. blank lines. Each record contains lines of the form
  355.  
  356.   <field-name>: <value>
  357.  
  358. The field name is case insensitive.  Text after the '#' character on a
  359. line is ignored during parsing.  This is used for comments.  The
  360. following <field-names> can be used:
  361.  
  362. =over 3
  363.  
  364. =item User-Agent
  365.  
  366. The value of this field is the name of the robot the record is
  367. describing access policy for.  If more than one I<User-Agent> field is
  368. present the record describes an identical access policy for more than
  369. one robot. At least one field needs to be present per record.  If the
  370. value is '*', the record describes the default access policy for any
  371. robot that has not not matched any of the other records.
  372.  
  373. =item Disallow
  374.  
  375. The value of this field specifies a partial URL that is not to be
  376. visited. This can be a full path, or a partial path; any URL that
  377. starts with this value will not be retrieved
  378.  
  379. =back
  380.  
  381. =head1 ROBOTS.TXT EXAMPLES
  382.  
  383. The following example "/robots.txt" file specifies that no robots
  384. should visit any URL starting with "/cyberworld/map/" or "/tmp/":
  385.  
  386.   User-agent: *
  387.   Disallow: /cyberworld/map/ # This is an infinite virtual URL space
  388.   Disallow: /tmp/ # these will soon disappear
  389.  
  390. This example "/robots.txt" file specifies that no robots should visit
  391. any URL starting with "/cyberworld/map/", except the robot called
  392. "cybermapper":
  393.  
  394.   User-agent: *
  395.   Disallow: /cyberworld/map/ # This is an infinite virtual URL space
  396.  
  397.   # Cybermapper knows where to go.
  398.   User-agent: cybermapper
  399.   Disallow:
  400.  
  401. This example indicates that no robots should visit this site further:
  402.  
  403.   # go away
  404.   User-agent: *
  405.   Disallow: /
  406.  
  407. =head1 SEE ALSO
  408.  
  409. L<LWP::RobotUA>, L<WWW::RobotRules::AnyDBM_File>
  410.