git.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/t/robot/ua.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..7\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 $req = new HTTP::Request GET => url("/someplace", $base);
  97 $res = $ua->request($req);
  98 #print $res->as_string;
  99 print "not " unless $res->is_success;
 100 print "ok 1\n";
 101
 102 $req = new HTTP::Request GET => url("/private/place", $base);
 103 $res = $ua->request($req);
 104 #print $res->as_string;
 105 print "not " unless $res->code == 403
 106                 and $res->message =~ /robots.txt/;
 107 print "ok 2\n";
 108
 109 $req = new HTTP::Request GET => url("/foo", $base);
 110 $res = $ua->request($req);
 111 #print $res->as_string;
 112 print "not " unless $res->code == 404;  # not found
 113 print "ok 3\n";
 114
 115 # Let the robotua generate "Service unavailable/Retry After response";
 116 $ua->delay(1);
 117 $ua->use_sleep(0);
 118 $req = new HTTP::Request GET => url("/foo", $base);
 119 $res = $ua->request($req);
 120 #print $res->as_string;
 121 print "not " unless $res->code == 503   # Unavailable
 122                 and $res->header("Retry-After");
 123 print "ok 4\n";
 124
 125 #----------------------------------------------------------------
 126 print "Terminating server...\n";
 127 sub httpd_get_quit
 128 {
 129     my($c) = @_;
 130     $c->send_error(503, "Bye, bye");
 131     exit;  # terminate HTTP server
 132 }
 133
 134 $ua->delay(0);
 135 $req = new HTTP::Request GET => url("/quit", $base);
 136 $res = $ua->request($req);
 137
 138 print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
 139 print "ok 5\n";
 140
 141 #---------------------------------------------------------------
 142 $ua->delay(1);
 143
 144 # host_wait() should be around 60s now
 145 print "not " unless abs($ua->host_wait($base->host_port) - 60) < 5;
 146 print "ok 6\n";
 147
 148 # Number of visits to this place should be
 149 print "not " unless $ua->no_visits($base->host_port) == 4;
 150 print "ok 7\n";
 151