6 unless (-f "CAN_TALK_TO_OURSELF") {
7 print "1..0 # Skipped: Can't talk to ourself (misconfigured system)\n";
13 require IO::Socket; # make sure this work before we try to make a HTTP::Daemon
15 # First we make ourself a daemon in another process
21 my $d = HTTP::Daemon->new(Timeout => 10);
23 print "Please to meet you at: <URL:", $d->url, ">\n";
24 open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/dev/null");
26 while ($c = $d->accept) {
29 my $p = ($r->url->path_segments)[1];
30 my $func = lc("httpd_" . $r->method . "_$p");
38 $c = undef; # close connection
40 print STDERR "HTTP Server terminated\n";
45 my $perl = $Config{'perlpath'};
46 $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
47 open(DAEMON, "$perl local/http.t daemon |") or die "Can't exec daemon: $!";
53 my $greeting = <DAEMON>;
54 $greeting =~ /(<[^>]+>)/;
57 my $base = URI->new($1);
60 $u = $u->abs($_[1]) if @_ > 1;
64 print "Will access HTTP server at $base\n";
66 require LWP::UserAgent;
67 require HTTP::Request;
68 $ua = new LWP::UserAgent;
69 $ua->agent("Mozilla/0.01 " . $ua->agent);
70 $ua->from('gisle@aas.no');
72 #----------------------------------------------------------------
73 print "Bad request...\n";
74 $req = new HTTP::Request GET => url("/not_found", $base);
75 $req->header(X_Foo => "Bar");
76 $res = $ua->request($req);
78 print "not " unless $res->is_error
80 and $res->message =~ /not\s+found/i;
82 # we also expect a few headers
83 print "not " if !$res->server and !$res->date;
86 #----------------------------------------------------------------
87 print "Simple echo...\n";
91 $c->send_basic_header(200);
92 print $c "Content-Type: message/http\015\012";
94 print $c $req->as_string;
97 $req = new HTTP::Request GET => url("/echo/path_info?query", $base);
98 $req->push_header(Accept => 'text/html');
99 $req->push_header(Accept => 'text/plain; q=0.9');
100 $req->push_header(Accept => 'image/*');
101 $req->push_header(':foo_bar' => 1);
102 $req->if_modified_since(time - 300);
103 $req->header(Long_text => 'This is a very long header line
104 which is broken between
105 more than one line.');
106 $req->header(X_Foo => "Bar");
108 $res = $ua->request($req);
109 #print $res->as_string;
111 print "not " unless $res->is_success
112 and $res->code == 200 && $res->message eq "OK";
116 @accept = /^Accept:\s*(.*)/mg;
118 print "not " unless /^From:\s*gisle\@aas\.no$/m
121 and /^Accept:\s*text\/html/m
122 and /^Accept:\s*text\/plain/m
123 and /^Accept:\s*image\/\*/m
124 and /^If-Modified-Since:\s*\w{3},\s+\d+/m
125 and /^Long-Text:\s*This.*broken between/m
126 and /^Foo-Bar:\s*1$/m
127 and /^X-Foo:\s*Bar$/m
128 and /^User-Agent:\s*Mozilla\/0.01/m;
131 #----------------------------------------------------------------
132 print "Send file...\n";
134 my $file = "test-$$.html";
135 open(FILE, ">$file") or die "Can't create $file: $!";
136 binmode FILE or die "Can't binmode $file: $!";
138 <html><title>En prøve</title>
139 <h1>Dette er en testfil</h1>
140 Jeg vet ikke hvor stor fila behøver å være heller, men dette
141 er sikkert nok i massevis.
148 my %form = $r->url->query_form;
149 my $file = $form{'name'};
150 $c->send_file_response($file);
151 unlink($file) if $file =~ /^test-/;
154 $req = new HTTP::Request GET => url("/file?name=$file", $base);
155 $res = $ua->request($req);
156 #print $res->as_string;
158 print "not " unless $res->is_success
159 and $res->content_type eq 'text/html'
160 and $res->content_length == 147
161 and $res->title eq 'En prøve'
162 and $res->content =~ /å være/;
166 # A second try on the same file, should fail because we unlink it
167 $res = $ua->request($req);
168 #print $res->as_string;
169 print "not " unless $res->is_error
170 and $res->code == 404; # not found
173 # Then try to list current directory
174 $req = new HTTP::Request GET => url("/file?name=.", $base);
175 $res = $ua->request($req);
176 #print $res->as_string;
177 print "not " unless $res->code == 501; # NYI
181 #----------------------------------------------------------------
182 print "Check redirect...\n";
183 sub httpd_get_redirect
186 $c->send_redirect("/echo/redirect");
189 $req = new HTTP::Request GET => url("/redirect/foo", $base);
190 $res = $ua->request($req);
191 #print $res->as_string;
193 print "not " unless $res->is_success
194 and $res->content =~ m|/echo/redirect|;
196 print "not " unless $res->previous->is_redirect
197 and $res->previous->code == 301;
200 # Let's test a redirect loop too
201 sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") }
202 sub httpd_get_redirect3 { shift->send_redirect("/redirect2/") }
204 $req->url(url("/redirect2", $base));
205 $ua->max_redirect(5);
206 $res = $ua->request($req);
207 #print $res->as_string;
208 print "not " unless $res->is_redirect
209 and $res->header("Client-Warning") =~ /loop detected/i;
212 while ($res->previous) {
214 $res = $res->previous;
217 print "not " unless $i == 5;
220 #----------------------------------------------------------------
221 print "Check basic authorization...\n";
225 #print STDERR $r->as_string;
226 my($u,$p) = $r->authorization_basic;
227 if (defined($u) && $u eq 'ok 12' && $p eq 'xyzzy') {
228 $c->send_basic_header(200);
229 print $c "Content-Type: text/plain";
235 $c->send_basic_header(401);
236 $c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012");
242 package MyUA; @ISA=qw(LWP::UserAgent);
243 sub get_basic_credentials {
244 my($self, $realm, $uri, $proxy) = @_;
245 if ($realm eq "libwww-perl" && $uri->rel($base) eq "basic") {
246 return ("ok 12", "xyzzy");
253 $req = new HTTP::Request GET => url("/basic", $base);
254 $res = MyUA->new->request($req);
255 #print $res->as_string;
257 print "not " unless $res->is_success;
260 # Let's try with a $ua that does not pass out credentials
261 $res = $ua->request($req);
262 print "not " unless $res->code == 401;
265 # Let's try to set credentials for this realm
266 $ua->credentials($req->url->host_port, "libwww-perl", "ok 12", "xyzzy");
267 $res = $ua->request($req);
268 print "not " unless $res->is_success;
271 # Then illegal credentials
272 $ua->credentials($req->url->host_port, "libwww-perl", "user", "passwd");
273 $res = $ua->request($req);
274 print "not " unless $res->code == 401;
278 #----------------------------------------------------------------
279 print "Check proxy...\n";
283 if ($r->method eq "GET" and
284 $r->url->scheme eq "ftp") {
285 $c->send_basic_header(200);
293 $ua->proxy(ftp => $base);
294 $req = new HTTP::Request GET => "ftp://ftp.perl.com/proxy";
295 $res = $ua->request($req);
296 #print $res->as_string;
297 print "not " unless $res->is_success;
300 #----------------------------------------------------------------
301 print "Check POSTing...\n";
305 $c->send_basic_header;
306 $c->print("Content-Type: text/plain");
310 # Do it the hard way to test the send_file
311 open(TMP, ">tmp$$") || die;
313 print TMP $r->as_string;
316 $c->send_file("tmp$$");
321 $req = new HTTP::Request POST => url("/echo/foo", $base);
322 $req->content_type("application/x-www-form-urlencoded");
323 $req->content("foo=bar&bar=test");
324 $res = $ua->request($req);
325 #print $res->as_string;
328 print "not " unless $res->is_success
329 and /^Content-Length:\s*16$/mi
330 and /^Content-Type:\s*application\/x-www-form-urlencoded$/mi
331 and /^foo=bar&bar=test$/m;
334 #----------------------------------------------------------------
335 print "Terminating server...\n";
339 $c->send_error(503, "Bye, bye");
340 exit; # terminate HTTP server
343 $req = new HTTP::Request GET => url("/quit", $base);
344 $res = $ua->request($req);
346 print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;