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