git.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/t/local/http-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 # Hm, this should really use Test.pm, but not worth changing over, really.
  12
  13
  14 $| = 1; # autoflush
  15
  16 require IO::Socket;  # make sure this work before we try to make a HTTP::Daemon
  17
  18 # First we make ourself a daemon in another process
  19 my $D = shift || '';
  20 if ($D eq 'daemon') {
  21
  22     require HTTP::Daemon;
  23
  24     my $d = HTTP::Daemon->new(Timeout => 10);
  25
  26     print "Please to meet you at: <URL:", $d->url, ">\n";
  27     open(STDOUT, $^O eq 'VMS'? ">nl: " : ">/dev/null");
  28
  29     while ($c = $d->accept) {
  30         $r = $c->get_request;
  31         if ($r) {
  32             my $p = ($r->url->path_segments)[1];
  33             my $func = lc("httpd_" . $r->method . "_$p");
  34             if (defined &$func) {
  35                 &$func($c, $r);
  36             }
  37             else {
  38                 $c->send_error(404);
  39             }
  40         }
  41         $c = undef;  # close connection
  42     }
  43     print STDERR "HTTP Server terminated\n";
  44     exit;
  45 }
  46 else {
  47     use Config;
  48     my $perl = $Config{'perlpath'};
  49     $perl = $^X if $^O eq 'VMS' or -x $^X and $^X =~ m,^([a-z]:)?/,i;
  50     open(DAEMON, "$perl local/http-get.t daemon |") or die "Can't exec daemon: $!";
  51 }
  52
  53 print "1..21\n";
  54
  55
  56 my $greeting = <DAEMON>;
  57 $greeting =~ /(<[^>]+>)/;
  58
  59 require URI;
  60 my $base = URI->new($1);
  61 sub url {
  62    my $u = URI->new(@_);
  63    $u = $u->abs($_[1]) if @_ > 1;
  64    $u->as_string;
  65 }
  66
  67 print "# Will access HTTP server at $base\n";
  68
  69 require LWP::UserAgent;
  70 require HTTP::Request;
  71 $ua = new LWP::UserAgent;
  72 $ua->agent("Mozilla/0.01 " . $ua->agent);
  73 $ua->from('gisle@aas.no');
  74 $ua->cookie_jar({});
  75
  76 #----------------------------------------------------------------
  77 print "#------------Testing: Bad request...\n";
  78 $res = $ua->get(
  79   url("/not_found", $base),
  80     'X-Foo' => "Bar",
  81 );
  82
  83 print "not " unless $res->is_error
  84                 and $res->code == 404
  85                 and $res->message =~ /not\s+found/i;
  86 print "ok 1\n";
  87 # we also expect a few headers
  88 print "not " if !$res->server and !$res->date;
  89 print "ok 2\n";
  90
  91 #----------------------------------------------------------------
  92 print "#------------Testing: Simple echo...\n";
  93 sub httpd_get_echo
  94 {
  95     my($c, $req) = @_;
  96     $c->send_basic_header(200);
  97     print $c "Content-Type: text/plain\015\012";
  98     $c->send_crlf;
  99     print $c $req->as_string;
 100 }
 101
 102 $res = $ua->get(
 103   url("/echo/path_info?query", $base),
 104     Accept => 'text/html',
 105     Accept => 'text/plain; q=0.9',
 106     Accept => 'image/*',
 107     Long_text => 'This is a very long header line
 108 which is broken between
 109 more than one line.',
 110     X_Foo => "Bar",
 111
 112 );
 113 #print $res->as_string;
 114
 115 print "not " unless $res->is_success
 116                and  $res->code == 200 && $res->message eq "OK";
 117 print "ok 3\n";
 118
 119 $_ = $res->content;
 120 @accept = /^Accept:\s*(.*)/mg;
 121
 122 #print "$_\n";
 123
 124 print "not " unless /^From:\s*gisle\@aas\.no$/m
 125                 and /^Host:/m
 126                 and @accept == 3
 127                 and /^Accept:\s*text\/html/m
 128                 and /^Accept:\s*text\/plain/m
 129                 and /^Accept:\s*image\/\*/m
 130                 and /^Long-Text:\s*This.*broken between/m
 131                 and /^X-Foo:\s*Bar$/m
 132                 and /^User-Agent:\s*Mozilla\/0.01/m;
 133 print "ok 4\n";
 134
 135 #----------------------------------------------------------------
 136 print "#------------Testing: Send file...\n";
 137
 138 my $file = "test-$$.html";
 139 sub _write_file {
 140   open(FILE, ">$file") or die "Can't create $file: $!";
 141   binmode FILE or die "Can't binmode $file: $!";
 142   print FILE <<EOT;
 143 <html><title>En prøve</title>
 144 <h1>Dette er en testfil</h1>
 145 Jeg vet ikke hvor stor fila behøver å være heller, men dette
 146 er sikkert nok i massevis.
 147 EOT
 148   close(FILE);
 149   print "# ", -s $file, " bytes written to $file\n";
 150   return;
 151 }
 152
 153 sub httpd_get_file
 154 {
 155     my($c, $r) = @_;
 156     my %form = $r->url->query_form;
 157     my $file = $form{'name'};
 158     $c->send_file_response($file);
 159 }
 160
 161 _write_file();
 162
 163 $res = $ua->get( url("/file?name=$file", $base) );
 164
 165 #print $res->as_string;
 166
 167 print "not " unless $res->is_success
 168                 and $res->content_type eq 'text/html'
 169                 and $res->content_length == 147
 170                 and $res->title eq 'En prøve'
 171                 and $res->content =~ /å være/;
 172 print "ok 5\n";
 173
 174
 175
 176 {
 177
 178 my $content;
 179
 180 $res = $ua->get( url("/file?name=$file", $base),
 181   ':content_cb'     => sub { $content .= $_[0]; return; },
 182 );
 183 #print $res->as_string;
 184
 185 print "not " unless $res->is_success
 186                 and $res->content_type eq 'text/html'
 187                 and $res->content_length == 147
 188                 and defined $content
 189                 and $res->title eq 'En prøve'
 190                 and ! $res->content   # No content, because callback
 191                 and $content =~ /å være/;
 192 print "ok 6\n";
 193
 194 }
 195
 196 unlink($file);
 197
 198
 199
 200 # Then try to list current directory
 201 $res = $ua->get( url("/file?name=.", $base) );
 202 #print $res->as_string;
 203 print "not " unless $res->code == 501;   # NYI
 204 print "ok 7\n";
 205
 206
 207 #----------------------------------------------------------------
 208 print "#------------Testing: Check redirect...\n";
 209 sub httpd_get_redirect
 210 {
 211    my($c) = @_;
 212    $c->send_redirect("/echo/redirect");
 213 }
 214
 215 $res = $ua->get( url("/redirect/foo", $base) );
 216 #print $res->as_string;
 217
 218 print "not " unless $res->is_success
 219                 and $res->content =~ m|/echo/redirect|;
 220 print "ok 8\n";
 221 print "not " unless $res->previous->is_redirect
 222                 and $res->previous->code == 301;
 223 print "ok 9\n";
 224
 225 # Let's test a redirect loop too
 226 sub httpd_get_redirect2 { shift->send_redirect("/redirect3/") }
 227 sub httpd_get_redirect3 { shift->send_redirect("/redirect2/") }
 228
 229 $res = $ua->get(url("/redirect2", $base));
 230 #print $res->as_string;
 231 print "not " unless $res->is_redirect
 232                 and $res->header("Client-Warning") =~ /loop detected/i;
 233 print "ok 10\n";
 234 $i = 0;
 235 while ($res->previous) {
 236    $i++;
 237    $res = $res->previous;
 238 }
 239 print "not " unless $i == 7;
 240 print "ok 11\n";
 241
 242 sub httpd_get_redirect_file { shift->send_redirect("file:/etc/passwd") }
 243 $res = $ua->get(url("/redirect_file/", $base));
 244 #print $res->as_string;
 245 print "not " unless $res->is_redirect
 246                 and $res->header("Client-Warning") =~ /can't redirect to a file:/i;
 247 print "ok 12\n";
 248
 249
 250 #----------------------------------------------------------------
 251 print "#------------Testing: Check basic authorization...\n";
 252 sub httpd_get_basic
 253 {
 254     my($c, $r) = @_;
 255     #print STDERR $r->as_string;
 256     my($u,$p) = $r->authorization_basic;
 257     if (defined($u) && $u eq 'ok 13' && $p eq 'xyzzy') {
 258         $c->send_basic_header(200);
 259         print $c "Content-Type: text/plain";
 260         $c->send_crlf;
 261         $c->send_crlf;
 262         $c->print("$u\n");
 263     }
 264     else {
 265         $c->send_basic_header(401);
 266         $c->print("WWW-Authenticate: Basic realm=\"libwww-perl\"\015\012");
 267         $c->send_crlf;
 268     }
 269 }
 270
 271 {
 272    package MyUA; @ISA=qw(LWP::UserAgent);
 273    sub get_basic_credentials {
 274       my($self, $realm, $uri, $proxy) = @_;
 275       if ($realm eq "libwww-perl" && $uri->rel($base) eq "basic") {
 276           return ("ok 13", "xyzzy");
 277       }
 278       else {
 279           return undef;
 280       }
 281    }
 282 }
 283
 284 {
 285 my $that_url = url("/basic", $base);
 286
 287 $res = MyUA->new->get( $that_url );
 288 #print $res->as_string;
 289
 290 my $host_port = $res->request->uri->host_port;
 291
 292 print "not " unless $res->is_success;
 293 print $res->content;
 294
 295 # Let's try with a $ua that does not pass out credentials
 296 $res = $ua->get( $that_url );
 297 print "not " unless $res->code == 401;
 298 print "ok 14\n";
 299
 300
 301 print "# Host port: $host_port\n";
 302
 303 # Let's try to set credentials for this realm
 304 $ua->credentials($host_port, "libwww-perl", "ok 13", "xyzzy");
 305
 306 $res = $ua->get( $that_url );
 307
 308 print "not " unless $res->is_success;
 309 print "ok 15\n";
 310
 311 # Then illegal credentials
 312 $ua->credentials($host_port, "libwww-perl", "user", "passwd");
 313 $res = $ua->get( $that_url );
 314 print "not " unless $res->code == 401;
 315 print "ok 16\n";
 316 }
 317
 318 #----------------------------------------------------------------
 319 print "#------------Testing: Check proxy...\n";
 320 sub httpd_get_proxy
 321 {
 322    my($c,$r) = @_;
 323    if ($r->method eq "GET" and
 324        $r->url->scheme eq "ftp") {
 325        $c->send_basic_header(200);
 326        $c->send_crlf;
 327    }
 328    else {
 329        $c->send_error;
 330    }
 331 }
 332
 333 $ua->proxy(ftp => $base);
 334
 335 $res = $ua->get( "ftp://ftp.perl.com/proxy" );
 336 #print $res->as_string;
 337 print "not " unless $res->is_success;
 338 print "ok 17\n";
 339
 340 #----------------------------------------------------------------
 341 print "#------------Testing: Check POSTing...\n";
 342 sub httpd_post_echo
 343 {
 344    my($c,$r) = @_;
 345    $c->send_basic_header;
 346    $c->print("Content-Type: text/plain");
 347    $c->send_crlf;
 348    $c->send_crlf;
 349    $c->print($r->as_string);
 350 }
 351
 352 $res = $ua->post(
 353   url("/echo/foo", $base),
 354     ['foo' => 'bar', 'bar' => 'test'],
 355 );
 356 #print $res->as_string;
 357
 358 $_ = $res->content;
 359 print "not " unless $res->is_success
 360                 and /^Content-Length:\s*16$/mi
 361                 and /^Content-Type:\s*application\/x-www-form-urlencoded$/mi
 362                 and /^foo=bar&bar=test/m;
 363 print "ok 18\n";
 364
 365
 366 {
 367
 368 my $content;
 369
 370 $res = $ua->post(
 371   url("/echo/foo", $base),
 372     ['foo' => 'bar', 'bar' => 'test'],
 373   ':content_cb'     => sub { $content .= $_[0]; return; },
 374 );
 375
 376 $_ = $content;
 377 print "not " unless $res->is_success
 378                 and /^Content-Length:\s*16$/mi
 379                 and /^Content-Type:\s*application\/x-www-form-urlencoded$/mi
 380                 and /^foo=bar&bar=test/m
 381                 and ! $res->content
 382 ;
 383 print "ok 19\n";
 384
 385 }
 386
 387 {
 388
 389 my $content;
 390
 391 $res = $ua->post(
 392   url("/echo/foo", $base),
 393   Content_Type   => 'text/plain',
 394   Content        => "Plain Text",
 395   ':content_cb'  => sub { $content .= $_[0]; return; },
 396 );
 397
 398 $_ = $content;
 399 print "not " unless $res->is_success
 400                 and /^Content-Length:\s*10$/mi
 401                 and /^Content-Type:\s*text\/plain$/mi
 402                 and /^Plain Text$/m
 403                 and ! $res->content
 404 ;
 405 print "ok 20\n";
 406
 407 }
 408
 409 #----------------------------------------------------------------
 410 print "#------------Testing: Terminating server...\n";
 411 sub httpd_get_quit
 412 {
 413     my($c) = @_;
 414     $c->send_error(503, "Bye, bye");
 415     exit;  # terminate HTTP server
 416 }
 417
 418 $res = $ua->get( url("/quit", $base) );
 419
 420 print "not " unless $res->code == 503 and $res->content =~ /Bye, bye/;
 421 print "ok 21\n";
 422