← Back to branch summary

~ubuntu-branches/ubuntu/edgy/libwww-perl/edgy

« back to all changes in this revision

Viewing changes to t/robot/ua-get.t

  • Committer: Bazaar Package Importer
  • Author(s): Jay Bonci
  • Date: 2005-02-13 18:45:32 UTC
  • mfrom: (2.1.2 hoary)
  • Revision ID: james.westby@ubuntu.com-20050213184532-67qvopi4wre3010u
Tags: 5.803-4
http://bugs.debian.org/294597
http://bugs.debian.org/294595
* Make GET/POST/HEAD symlinks (Closes: #294597)
* lwp-requests now honors -b when dumping links (Closes: #294595)
  - Thanks to giuseppe bonacci for the patch
* Moved symlinks to a libwww-perl.links file

Show diffs side-by-side

added added

removed removed

Lines of Context:
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";