t/robot/ua-get.t

   1 if($^O eq "MacOS") {
   2     print "1..0\n";
   3     exit(0);
   4 }
   5
   6 unless (-f "CAN_TALK_TO_OURSELF") {
   7     print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n";
   8     exit;
   9 }
  10
  11 $| = 1; # autoflush
  12 require IO::Socket;  # make sure this work before we try to make a HTTP::Daemon
  13
  14 # First we make ourself a daemon in another process
  15 my $D = shift || '';
  16 if ($D eq 'daemon') {
  17
  18     require HTTP::Daemon;
  19
  20     my $d = new HTTP::Daemon Timeout => 10;
  21
  22     print "Please to meet you at: <URL:", $d->url, ">\n";
  23     open(STDOUT, $^O eq 'MSWin32' ?  ">nul" : $^O eq 'VMS' ? ">NL:"  : ">/dev/null");
  24
  25     while ($c = $d->accept) {
  26         $r = $c->get_request;
  27         if ($r) {
  28             my $p = ($r->url->path_segments)[1];
  29             $p =~ s/\W//g;
  30             my $func = lc("httpd_" . $r->method . "_$p");
  31             #print STDERR "Calling $func...\n";
  32             if (defined &$func) {
  33                 &$func($c, $r);
  34             }
  35             else {
  36                 $c->send_error(404);
  37             }
  38         }
  39         $c = undef;  # close connection
  40     }
  41     print STDERR "HTTP Server terminated\n";
  42     exit;
  43 }
  44 else {
  45     use Config;
  46     my $perl = $Config{'perlpath'};
  47     $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
  48     open(DAEMON , "$perl robot/ua.t daemon |") or die "Can't exec daemon: $!";
  49 }
  50
  51 print "1..8\n";
  52
  53
  54 $greating = <DAEMON>;
  55 $greating =~ /(<[^>]+>)/;
  56
  57 require URI;
  58 my $base = URI->new($1);
  59 sub url {
  60    my $u = URI->new(@_);
  61    $u = $u->abs($_[1]) if @_ > 1;
  62    $u->as_string;
  63 }
  64
  65 print "Will access HTTP server at $base\n";
  66
  67 require LWP::RobotUA;
  68 require HTTP::Request;
  69 $ua = new LWP::RobotUA 'lwp-spider/0.1', 'gisle@aas.no';
  70 $ua->delay(0.05);  # rather quick robot
  71
  72 #----------------------------------------------------------------
  73 sub httpd_get_robotstxt
  74 {
  75    my($c,$r) = @_;
  76    $c->send_basic_header;
  77    $c->print("Content-Type: text/plain");
  78    $c->send_crlf;
  79    $c->send_crlf;
  80    $c->print("User-Agent: *
  81 Disallow: /private
  82
  83 ");
  84 }
  85
  86 sub httpd_get_someplace
  87 {
  88    my($c,$r) = @_;
  89    $c->send_basic_header;
  90    $c->print("Content-Type: text/plain");
  91    $c->send_crlf;
  92    $c->send_crlf;
  93    $c->print("Okidok\n");
  94 }
  95
  96 $res = $ua->get( url("/someplace", $base) );
  97 #print $res->as_string;
  98 print "not " unless $res->is_success;
  99 print "ok 1\n";
 100
 101 $res = $ua->get( url("/private/place", $base) );
 102 #print $res->as_string;
 103 print "not " unless $res->code == 403
 104                 and $res->message =~ /robots.txt/;
 105 print "ok 2\n";
 106
 107
 108 $res = $ua->get( url("/foo", $base) );
 109 #print $res->as_string;
 110 print "not " unless $res->code == 404;  # not found
 111 print "ok 3\n";
 112
 113 # Let the robotua generate "Service unavailable/Retry After response";
 114 $ua->delay(1);
 115 $ua->use_sleep(0);
 116
 117 $res = $ua->get( url("/foo", $base) );
 118 #print $res->as_string;
 119 print "not " unless $res->code == 503   # Unavailable
 120                 and $res->header("Retry-After");
 121 print "ok 4\n";
 122
 123 #----------------------------------------------------------------
 124 print "Terminating server...\n";
 125 sub httpd_get_quit
 126 {
 127     my($c) = @_;
 128     $c->send_error(503, "Bye, bye");
 129     exit;  # terminate HTTP server
 130 }
 131
 132 $ua->delay(0);
 133
 134 $res = $ua->get( url("/quit", $base) );
 135
 136 print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
 137 print "ok 5\n";
 138
 139 #---------------------------------------------------------------
 140 $ua->delay(1);
 141
 142 # host_wait() should be around 60s now
 143 print "not " unless abs($ua->host_wait($base->host_port) - 60) < 5;
 144 print "ok 6\n";
 145
 146 # Number of visits to this place should be
 147 print "not " unless $ua->no_visits($base->host_port) == 4;
 148 print "ok 7\n";
 149
 150 # RobotUA used to have problem with mailto URLs.
 151 $ENV{SENDMAIL} = "dummy";
 152 $res = $ua->get("mailto:gisle\@aas.no");
 153 #print $res->as_string;
 154
 155 print "not " unless $res->code == 400 && $res->message eq "Library does not allow method GET for 'mailto:' URLs";
 156 print "ok 8\n";