vcs.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/t/local/http.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
  13 require IO::Socket;  # make sure this work before we try to make a HTTP::Daemon
  14
  15 # First we make ourself a daemon in another process
  16 my $D = shift || '';
  17 if ($D eq 'daemon') {
  18
  19     require HTTP::Daemon;
  20
  21     my $d = HTTP::Daemon->new(Timeout => 10);
  22
  23     print "Please to meet you at: <URL:", $d->url, ">\n";
  24     open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/dev/null");
  25
  26     while ($c = $d->accept) {
  27         $r = $c->get_request;
  28         if ($r) {
  29             my $p = ($r->url->path_segments)[1];
  30             my $func = lc("httpd_" . $r->method . "_$p");
  31             if (defined &$func) {
  32                 &$func($c, $r);
  33             }
  34             else {
  35                 $c->send_error(404);
  36             }
  37         }
  38         $c = undef;  # close connection
  39     }
  40     print STDERR "HTTP Server terminated\n";
  41     exit;
  42 }
  43 else {
  44     use Config;
  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: $!";
  48 }
  49
  50 print "1..18\n";
  51
  52
  53 my $greeting = <DAEMON>;
  54 $greeting =~ /(<[^>]+>)/;
  55
  56 require URI;
  57 my $base = URI->new($1);
  58 sub url {
  59    my $u = URI->new(@_);
  60    $u = $u->abs($_[1]) if @_ > 1;
  61    $u->as_string;
  62 }
  63
  64 print "Will access HTTP server at $base\n";
  65
  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');
  71
  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);
  77
  78 print "not " unless $res->is_error
  79                 and $res->code == 404
  80                 and $res->message =~ /not\s+found/i;
  81 print "ok 1\n";
  82 # we also expect a few headers
  83 print "not " if !$res->server and !$res->date;
  84 print "ok 2\n";
  85
  86 #----------------------------------------------------------------
  87 print "Simple echo...\n";
  88 sub httpd_get_echo
  89 {
  90     my($c, $req) = @_;
  91     $c->send_basic_header(200);
  92     print $c "Content-Type: message/http\015\012";
  93     $c->send_crlf;
  94     print $c $req->as_string;
  95 }
  96
  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");
 107
 108 $res = $ua->request($req);
 109 #print $res->as_string;
 110
 111 print "not " unless $res->is_success
 112                and  $res->code == 200 && $res->message eq "OK";
 113 print "ok 3\n";
 114
 115 $_ = $res->content;
 116 @accept = /^Accept:\s*(.*)/mg;
 117
 118 print "not " unless /^From:\s*gisle\@aas\.no$/m
 119                 and /^Host:/m
 120                 and @accept == 3
 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;
 129 print "ok 4\n";
 130
 131 #----------------------------------------------------------------
 132 print "Send file...\n";
 133
 134 my $file = "test-$$.html";
 135 open(FILE, ">$file") or die "Can't create $file: $!";
 136 binmode FILE or die "Can't binmode $file: $!";
 137 print FILE <<EOT;
 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.
 142 EOT
 143 close(FILE);
 144
 145 sub httpd_get_file
 146 {
 147     my($c, $r) = @_;
 148     my %form = $r->url->query_form;
 149     my $file = $form{'name'};
 150     $c->send_file_response($file);
 151     unlink($file) if $file =~ /^test-/;
 152 }
 153
 154 $req = new HTTP::Request GET => url("/file?name=$file", $base);
 155 $res = $ua->request($req);
 156 #print $res->as_string;
 157
 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/;
 163 print "ok 5\n";
 164
 165
 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
 171 print "ok 6\n";
 172
 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
 178 print "ok 7\n";
 179
 180
 181 #----------------------------------------------------------------
 182 print "Check redirect...\n";
 183 sub httpd_get_redirect
 184 {
 185    my($c) = @_;
 186    $c->send_redirect("/echo/redirect");
 187 }
 188
 189 $req = new HTTP::Request GET => url("/redirect/foo", $base);
 190 $res = $ua->request($req);
 191 #print $res->as_string;
 192
 193 print "not " unless $res->is_success
 194                 and $res->content =~ m|/echo/redirect|;
 195 print "ok 8\n";
 196 print "not " unless $res->previous->is_redirect
 197                 and $res->previous->code == 301;
 198 print "ok 9\n";
 199
 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/") }
 203
 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;
 210 print "ok 10\n";
 211 $i = 0;
 212 while ($res->previous) {
 213    $i++;
 214    $res = $res->previous;
 215 }
 216
 217 print "not " unless $i == 5;
 218 print "ok 11\n";
 219
 220 #----------------------------------------------------------------
 221 print "Check basic authorization...\n";
 222 sub httpd_get_basic
 223 {
 224     my($c, $r) = @_;
 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";
 230         $c->send_crlf;
 231         $c->send_crlf;
 232         $c->print("$u\n");
 233     }
 234     else {
 235         $c->send_basic_header(401);
 236         $c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012");
 237         $c->send_crlf;
 238     }
 239 }
 240
 241 {
 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");
 247       }
 248       else {
 249           return undef;
 250       }
 251    }
 252 }
 253 $req = new HTTP::Request GET => url("/basic", $base);
 254 $res = MyUA->new->request($req);
 255 #print $res->as_string;
 256
 257 print "not " unless $res->is_success;
 258 print $res->content;
 259
 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;
 263 print "ok 13\n";
 264
 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;
 269 print "ok 14\n";
 270
 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;
 275 print "ok 15\n";
 276
 277
 278 #----------------------------------------------------------------
 279 print "Check proxy...\n";
 280 sub httpd_get_proxy
 281 {
 282    my($c,$r) = @_;
 283    if ($r->method eq "GET" and
 284        $r->url->scheme eq "ftp") {
 285        $c->send_basic_header(200);
 286        $c->send_crlf;
 287    }
 288    else {
 289        $c->send_error;
 290    }
 291 }
 292
 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;
 298 print "ok 16\n";
 299
 300 #----------------------------------------------------------------
 301 print "Check POSTing...\n";
 302 sub httpd_post_echo
 303 {
 304    my($c,$r) = @_;
 305    $c->send_basic_header;
 306    $c->print("Content-Type: text/plain");
 307    $c->send_crlf;
 308    $c->send_crlf;
 309
 310    # Do it the hard way to test the send_file
 311    open(TMP, ">tmp$$") || die;
 312    binmode(TMP);
 313    print TMP $r->as_string;
 314    close(TMP) || die;
 315
 316    $c->send_file("tmp$$");
 317
 318    unlink("tmp$$");
 319 }
 320
 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;
 326
 327 $_ = $res->content;
 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;
 332 print "ok 17\n";
 333
 334 #----------------------------------------------------------------
 335 print "Terminating server...\n";
 336 sub httpd_get_quit
 337 {
 338     my($c) = @_;
 339     $c->send_error(503, "Bye, bye");
 340     exit;  # terminate HTTP server
 341 }
 342
 343 $req = new HTTP::Request GET => url("/quit", $base);
 344 $res = $ua->request($req);
 345
 346 print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
 347 print "ok 18\n";
 348