home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Perl_Libs / site_perl / WWW / RobotRules / AnyDBM_File.pm
Encoding:
Perl POD Document  |  1997-12-02  |  3.5 KB  |  170 lines
  1. # $Id: AnyDBM_File.pm,v 1.8 1997/12/02 13:27:43 aas Exp $
  2.  
  3. package WWW::RobotRules::AnyDBM_File;
  4.  
  5. require  WWW::RobotRules;
  6. @ISA = qw(WWW::RobotRules);
  7.  
  8. use Carp ();
  9. use AnyDBM_File;
  10. use Fcntl;
  11. use strict;
  12.  
  13. =head1 NAME
  14.  
  15. WWW::RobotRules::AnyDBM_File - Persistent RobotRules
  16.  
  17. =head1 SYNOPSIS
  18.  
  19.  require WWW::RobotRules::AnyDBM_File;
  20.  require LWP::RobotUA;
  21.  
  22.  # Create a robot useragent that uses a diskcaching RobotRules
  23.  my $rules = new WWW::RobotRules::AnyDBM_File 'my-robot/1.0', 'cachefile';
  24.  my $ua = new WWW::RobotUA 'my-robot/1.0', 'me@foo.com', $rules;
  25.  
  26.  # Then just use $ua as usual
  27.  $res = $ua->request($req);
  28.  
  29. =head1 DESCRIPTION
  30.  
  31. This is a subclass of I<WWW::RobotRules> that uses the AnyDBM_File
  32. package to implement persistent diskcaching of F<robots.txt> and host
  33. visit information.
  34.  
  35. The constructor (the new() method) takes an extra argument specifying
  36. the name of the DBM file to use.  If the DBM file already exists, then
  37. you can specify undef as agent name as the name can be obtained from
  38. the DBM database.
  39.  
  40. =cut
  41.  
  42. sub new 
  43. { 
  44.   my ($class, $ua, $file) = @_;
  45.   Carp::croak('WWW::RobotRules::AnyDBM_File filename required') unless $file;
  46.  
  47.   my $self = bless { }, $class;
  48.   $self->{'filename'} = $file;
  49.   tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_CREAT|O_RDWR, 0640
  50.     or Carp::croak("Can't open $file: $!");
  51.   
  52.   if ($ua) {
  53.       $self->agent($ua);
  54.   } else {
  55.       # Try to obtain name from DBM file
  56.       $ua = $self->{'dbm'}{"|ua-name|"};
  57.       Carp::croak("No agent name specified") unless $ua;
  58.   }
  59.  
  60.   $self;
  61. }
  62.  
  63. sub agent {
  64.     my($self, $newname) = @_;
  65.     my $old = $self->{'dbm'}{"|ua-name|"};
  66.     if (defined $newname) {
  67.     $newname =~ s!/?\s*\d+.\d+\s*$!!;  # loose version
  68.     unless ($old && $old eq $newname) {
  69.     # Old info is now stale.
  70.         my $file = $self->{'filename'};
  71.         untie %{$self->{'dbm'}};
  72.         tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_TRUNC|O_RDWR, 0640;
  73.         $self->{'dbm'}{"|ua-name|"} = $newname;
  74.     }
  75.     }
  76.     $old;
  77. }
  78.  
  79. sub no_visits {
  80.     my ($self, $netloc) = @_;
  81.     my $t = $self->{'dbm'}{"$netloc|vis"};
  82.     return 0 unless $t;
  83.     (split(/;\s*/, $t))[0];
  84. }
  85.  
  86. sub last_visit {
  87.     my ($self, $netloc) = @_;
  88.     my $t = $self->{'dbm'}{"$netloc|vis"};
  89.     return undef unless $t;
  90.     (split(/;\s*/, $t))[1];
  91. }
  92.  
  93. sub fresh_until {
  94.     my ($self, $netloc, $fresh) = @_;
  95.     my $old = $self->{'dbm'}{"$netloc|exp"};
  96.     if ($old) {
  97.     $old =~ s/;.*//;  # remove cleartext
  98.     }
  99.     if (defined $fresh) {
  100.     $fresh .= "; " . localtime($fresh);
  101.     $self->{'dbm'}{"$netloc|exp"} = $fresh;
  102.     }
  103.     $old;
  104. }
  105.  
  106. sub visit {
  107.     my($self, $netloc, $time) = @_;
  108.     $time ||= time;
  109.  
  110.     my $count = 0;
  111.     my $old = $self->{'dbm'}{"$netloc|vis"};
  112.     if ($old) {
  113.     my $last;
  114.     ($count,$last) = split(/;\s*/, $old);
  115.     $time = $last if $last > $time;
  116.     }
  117.     $count++;
  118.     $self->{'dbm'}{"$netloc|vis"} = "$count; $time; " . localtime($time);
  119. }
  120.  
  121. sub push_rules {
  122.     my($self, $netloc, @rules) = @_;
  123.     my $cnt = 1;
  124.     $cnt++ while $self->{'dbm'}{"$netloc|r$cnt"};
  125.  
  126.     foreach (@rules) {
  127.     $self->{'dbm'}{"$netloc|r$cnt"} = $_;
  128.     $cnt++;
  129.     }
  130. }
  131.  
  132. sub clear_rules {
  133.     my($self, $netloc) = @_;
  134.     my $cnt = 1;
  135.     while ($self->{'dbm'}{"$netloc|r$cnt"}) {
  136.     delete $self->{'dbm'}{"$netloc|r$cnt"};
  137.     $cnt++;
  138.     }
  139. }
  140.  
  141. sub rules {
  142.     my($self, $netloc) = @_;
  143.     my @rules = ();
  144.     my $cnt = 1;
  145.     while (1) {
  146.     my $rule = $self->{'dbm'}{"$netloc|r$cnt"};
  147.     last unless $rule;
  148.     push(@rules, $rule);
  149.     $cnt++;
  150.     }
  151.     @rules;
  152. }
  153.  
  154. sub dump
  155. {
  156. }
  157.  
  158. 1;
  159.  
  160. =head1 SEE ALSO
  161.  
  162. L<WWW::RobotRules>, L<LWP::RobotUA>
  163.  
  164. =head1 AUTHORS
  165.  
  166. Hakan Ardo E<lt>hakan@munin.ub2.lu.se>, Gisle Aas E<lt>aas@sn.no>
  167.  
  168. =cut
  169.  
  170.