home *** CD-ROM | disk | FTP | other *** search
/ CLIX - Fazer Clix Custa Nix / CLIX-CD.cdr / mac / lib / WWW / RobotRules / AnyDBM_File.pm
Encoding:
Perl POD Document  |  1997-11-18  |  3.5 KB  |  170 lines  |  [TEXT/McPL]
  1. # $Id: AnyDBM_File.pm,v 1.1 1997/11/18 00:33:58 neeri 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. =head1 SE ALSO
  41.  
  42. L<WWW::RobotRules>, L<LWP::RobotUA>
  43.  
  44. =cut
  45.  
  46. sub new 
  47. { 
  48.   my ($class, $ua, $file) = @_;
  49.   Carp::croak('WWW::RobotRules::AnyDBM_File filename required') unless $file;
  50.  
  51.   my $self = bless { }, $class;
  52.   $self->{'filename'} = $file;
  53.   tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_CREAT|O_RDWR, 0640
  54.     or Carp::croak("Can't open $file: $!");
  55.   
  56.   if ($ua) {
  57.       $self->agent($ua);
  58.   } else {
  59.       # Try to obtain name from DBM file
  60.       $ua = $self->{'dbm'}{"|ua-name|"};
  61.       Carp::croak("No agent name specified") unless $ua;
  62.   }
  63.  
  64.   $self;
  65. }
  66.  
  67. sub agent {
  68.     my($self, $newname) = @_;
  69.     my $old = $self->{'dbm'}{"|ua-name|"};
  70.     if (defined $newname) {
  71.     $newname =~ s!/?\s*\d+.\d+\s*$!!;  # loose version
  72.     unless ($old && $old eq $newname) {
  73.     # Old info is now stale.
  74.         my $file = $self->{'filename'};
  75.         untie %{$self->{'dbm'}};
  76.         tie %{$self->{'dbm'}}, 'AnyDBM_File', $file, O_TRUNC|O_RDWR, 0640;
  77.         $self->{'dbm'}{"|ua-name|"} = $newname;
  78.     }
  79.     }
  80.     $old;
  81. }
  82.  
  83. sub no_visits {
  84.     my ($self, $netloc) = @_;
  85.     my $t = $self->{'dbm'}{"$netloc|vis"};
  86.     return 0 unless $t;
  87.     (split(/;\s*/, $t))[0];
  88. }
  89.  
  90. sub last_visit {
  91.     my ($self, $netloc) = @_;
  92.     my $t = $self->{'dbm'}{"$netloc|vis"};
  93.     return undef unless $t;
  94.     (split(/;\s*/, $t))[1];
  95. }
  96.  
  97. sub fresh_until {
  98.     my ($self, $netloc, $fresh) = @_;
  99.     my $old = $self->{'dbm'}{"$netloc|exp"};
  100.     if ($old) {
  101.     $old =~ s/;.*//;  # remove cleartext
  102.     }
  103.     if (defined $fresh) {
  104.     $fresh .= "; " . localtime($fresh);
  105.     $self->{'dbm'}{"$netloc|exp"} = $fresh;
  106.     }
  107.     $old;
  108. }
  109.  
  110. sub visit {
  111.     my($self, $netloc, $time) = @_;
  112.     $time ||= time;
  113.  
  114.     my $count = 0;
  115.     my $old = $self->{'dbm'}{"$netloc|vis"};
  116.     if ($old) {
  117.     my $last;
  118.     ($count,$last) = split(/;\s*/, $old);
  119.     $time = $last if $last > $time;
  120.     }
  121.     $count++;
  122.     $self->{'dbm'}{"$netloc|vis"} = "$count; $time; " . localtime($time);
  123. }
  124.  
  125. sub push_rules {
  126.     my($self, $netloc, @rules) = @_;
  127.     my $cnt = 1;
  128.     $cnt++ while $self->{'dbm'}{"$netloc|r$cnt"};
  129.  
  130.     foreach (@rules) {
  131.     $self->{'dbm'}{"$netloc|r$cnt"} = $_;
  132.     $cnt++;
  133.     }
  134. }
  135.  
  136. sub clear_rules {
  137.     my($self, $netloc) = @_;
  138.     my $cnt = 1;
  139.     while ($self->{'dbm'}{"$netloc|r$cnt"}) {
  140.     delete $self->{'dbm'}{"$netloc|r$cnt"};
  141.     $cnt++;
  142.     }
  143. }
  144.  
  145. sub rules {
  146.     my($self, $netloc) = @_;
  147.     my @rules = ();
  148.     my $cnt = 1;
  149.     while (1) {
  150.     my $rule = $self->{'dbm'}{"$netloc|r$cnt"};
  151.     last unless $rule;
  152.     push(@rules, $rule);
  153.     $cnt++;
  154.     }
  155.     @rules;
  156. }
  157.  
  158. sub dump
  159. {
  160. }
  161.  
  162. 1;
  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.