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