"Fossies" - the Fresh Open Source Software Archive

Member "libwww-perl-6.43/t/robot/ua-get.t" (26 Nov 2019, 4732 Bytes) of package /linux/www/libwww-perl-6.43.tar.gz:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 use strict;
    2 use warnings;
    3 use Test::More;
    4 
    5 use Config;
    6 use FindBin qw($Bin);
    7 use HTTP::Daemon;
    8 use HTTP::Request;
    9 use IO::Socket;
   10 use LWP::RobotUA;
   11 use URI;
   12 use utf8;
   13 
   14 delete $ENV{PERL_LWP_ENV_PROXY};
   15 $| = 1; # autoflush
   16 
   17 my $DAEMON;
   18 my $base;
   19 my $CAN_TEST = (0==system($^X, "$Bin/../../talk-to-ourself"))? 1: 0;
   20 
   21 my $D = shift(@ARGV) || '';
   22 if ($D eq 'daemon') {
   23     daemonize();
   24 }
   25 else {
   26     # start the daemon and the testing
   27     if ( $^O ne 'MacOS' and $CAN_TEST ) {
   28         my $perl = $Config{'perlpath'};
   29         $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
   30         open($DAEMON, "$perl $0 daemon |") or die "Can't exec daemon: $!";
   31         my $greeting = <$DAEMON> || '';
   32         if ( $greeting =~ /(<[^>]+>)/ ) {
   33             $base = URI->new($1);
   34         }
   35     }
   36     _test();
   37 }
   38 exit(0);
   39 
   40 sub _test {
   41     # First we make ourself a daemon in another process
   42     # listen to our daemon
   43     return plan skip_all => "Can't test on this platform" if $^O eq 'MacOS';
   44     return plan skip_all => 'We cannot talk to ourselves' unless $CAN_TEST;
   45     return plan skip_all => 'We could not talk to our daemon' unless $DAEMON;
   46     return plan skip_all => 'No base URI' unless $base;
   47 
   48     plan tests => 18;
   49 
   50     my $ua = LWP::RobotUA->new('lwp-spider/0.1', 'gisle@aas.no');
   51     $ua->delay(0.05);  # rather quick robot
   52 
   53     { # someplace
   54         my $res = $ua->get( url("/someplace", $base) );
   55         isa_ok($res, 'HTTP::Response', 'someplace: got a response object');
   56         ok($res->is_success, 'someplace: is_success');
   57     }
   58     { # robots
   59         my $res = $ua->get( url("/private/place", $base) );
   60         isa_ok($res, 'HTTP::Response', 'robots: got a response object');
   61         is($res->code, 403, 'robots: code: 403');
   62         like($res->message, qr/robots\.txt/, 'robots: msg contains robots.txt');
   63     }
   64     { # foo
   65         my $res = $ua->get( url("/foo", $base) );
   66         isa_ok($res, 'HTTP::Response', 'foo: got a response object');
   67         is($res->code, 404, 'foo: code: 404');
   68         # Let the robotua generate "Service unavailable/Retry After response";
   69         $ua->delay(1);
   70         $ua->use_sleep(0);
   71         $res = $ua->get( url("/foo", $base) );
   72         isa_ok($res, 'HTTP::Response', 'foo: got a response object');
   73         is( $res->code, 503, 'foo: code: 503');
   74         ok($res->header("Retry-After"), 'foo: header: retry-after');
   75     }
   76     { # quit
   77         $ua->delay(0);
   78         my $res = $ua->get( url("/quit", $base) );
   79         isa_ok($res, 'HTTP::Response', 'quit: got a response object');
   80         is( $res->code, 503, 'quit: code: 503');
   81         like($res->content, qr/Bye, bye/, 'quit: Content: bye bye');
   82 
   83         $ua->delay(1);
   84 
   85         # host_wait() should be around 60s now
   86         ok(abs($ua->host_wait($base->host_port) - 60) < 5, 'quit: host-wait');
   87 
   88         # Number of visits to this place should be
   89         is($ua->no_visits($base->host_port), 4, 'quit: no_visits 4');
   90     }
   91     { # RobotUA used to have problem with mailto URLs.
   92         $ENV{SENDMAIL} = "dummy";
   93         my $res = $ua->get("mailto:gisle\@aas.no");
   94         isa_ok($res, 'HTTP::Response', 'mailto: got a response object');
   95 
   96         is($res->code, 400, 'mailto: response code: 400');
   97         is($res->message, "Library does not allow method GET for 'mailto:' URLs", "mailto: right message");
   98     }
   99 }
  100 sub daemonize {
  101     my %router;
  102     $router{get_robotstxt} = sub {
  103         my($c,$r) = @_;
  104         $c->send_basic_header;
  105         $c->print("Content-Type: text/plain");
  106         $c->send_crlf;
  107         $c->send_crlf;
  108         $c->print("User-Agent: *\n    Disallow: /private\n    ");
  109     };
  110     $router{get_someplace} = sub {
  111         my($c,$r) = @_;
  112         $c->send_basic_header;
  113         $c->print("Content-Type: text/plain");
  114         $c->send_crlf;
  115         $c->send_crlf;
  116         $c->print("Okidok\n");
  117     };
  118     $router{get_quit} = sub {
  119         my($c) = @_;
  120         $c->send_error(503, "Bye, bye");
  121         exit;  # terminate HTTP server
  122     };
  123 
  124     my $d = HTTP::Daemon->new(Timeout => 10, LocalAddr => '127.0.0.1') || die $!;
  125     print "Pleased to meet you at: <URL:", $d->url, ">\n";
  126     open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/dev/null");
  127 
  128     while (my $c = $d->accept) {
  129         while (my $r = $c->get_request) {
  130             my $p = ($r->uri->path_segments)[1];
  131             $p =~ s/\W//g;
  132             my $func = lc($r->method . "_$p");
  133             if ( $router{$func} ) {
  134                 $router{$func}->($c, $r);
  135             }
  136             else {
  137                 $c->send_error(404);
  138             }
  139         }
  140         $c->close;
  141         undef($c);
  142     }
  143     print STDERR "HTTP Server terminated\n";
  144     exit;
  145 }
  146 sub url {
  147     my $u = URI->new(@_);
  148     $u = $u->abs($_[1]) if @_ > 1;
  149     $u->as_string;
  150 }