ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-HTTP/HTTP.pm
(Generate patch)

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.22 by root, Sat Jun 28 21:17:03 2008 UTC vs.
Revision 1.28 by root, Mon Sep 29 13:50:39 2008 UTC

… …
48use AnyEvent::Socket (); 48use AnyEvent::Socket ();
49use AnyEvent::Handle (); 49use AnyEvent::Handle ();
50 50
51use base Exporter::; 51use base Exporter::;
52 52
53our $VERSION = '1.03'; 53our $VERSION = '1.05';
54 54
55our @EXPORT = qw(http_get http_post http_head http_request); 55our @EXPORT = qw(http_get http_post http_head http_request);
56 56
57our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; 57our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58our $MAX_RECURSE = 10; 58our $MAX_RECURSE = 10;
… …
80Executes an HTTP-HEAD request. See the http_request function for details on 80Executes an HTTP-HEAD request. See the http_request function for details on
81additional parameters. 81additional parameters.
82 82
83=item http_post $url, $body, key => value..., $cb->($data, $headers) 83=item http_post $url, $body, key => value..., $cb->($data, $headers)
84 84
85Executes an HTTP-POST request with a request body of C<$bod>. See the 85Executes an HTTP-POST request with a request body of C<$body>. See the
86http_request function for details on additional parameters. 86http_request function for details on additional parameters.
87 87
88=item http_request $method => $url, key => value..., $cb->($data, $headers) 88=item http_request $method => $url, key => value..., $cb->($data, $headers)
89 89
90Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL 90Executes a HTTP request of type C<$method> (e.g. C<GET>, C<POST>). The URL
… …
235 while (my ($k, $v) = each %$hdr) { 235 while (my ($k, $v) = each %$hdr) {
236 $hdr{lc $k} = $v; 236 $hdr{lc $k} = $v;
237 } 237 }
238 } 238 }
239 239
240 my $recurse = exists $arg{recurse} ? $arg{recurse} : $MAX_RECURSE; 240 my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
241 241
242 return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url }) 242 return $cb->(undef, { Status => 599, Reason => "recursion limit reached", URL => $url })
243 if $recurse < 0; 243 if $recurse < 0;
244 244
245 my $proxy = $arg{proxy} || $PROXY; 245 my $proxy = $arg{proxy} || $PROXY;
… …
355 355
356 %hdr = (); # reduce memory usage, save a kitten 356 %hdr = (); # reduce memory usage, save a kitten
357 357
358 # status line 358 # status line
359 $state{handle}->push_read (line => qr/\015?\012/, sub { 359 $state{handle}->push_read (line => qr/\015?\012/, sub {
360 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) \s+ ([^\015\012]+)/ix 360 $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
361 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url })); 361 or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url }));
362 362
363 my %hdr = ( # response headers 363 my %hdr = ( # response headers
364 HTTPVersion => "\x00$1", 364 HTTPVersion => "\x00$1",
365 Status => "\x00$2", 365 Status => "\x00$2",
… …
398 my %kv = (value => $value, map { split /=/, $_, 2 } @arg); 398 my %kv = (value => $value, map { split /=/, $_, 2 } @arg);
399 399
400 my $cdom = (delete $kv{domain}) || $uhost; 400 my $cdom = (delete $kv{domain}) || $uhost;
401 my $cpath = (delete $kv{path}) || "/"; 401 my $cpath = (delete $kv{path}) || "/";
402 402
403 $cdom =~ s/^.?/./; # make sure it starts with a "." 403 $cdom =~ s/^\.?/./; # make sure it starts with a "."
404 404
405 next if $cdom =~ /\.$/; 405 next if $cdom =~ /\.$/;
406 406
407 # this is not rfc-like and not netscape-like. go figure. 407 # this is not rfc-like and not netscape-like. go figure.
408 my $ndots = $cdom =~ y/.//; 408 my $ndots = $cdom =~ y/.//;
… …
412 $arg{cookie_jar}{version} = 1; 412 $arg{cookie_jar}{version} = 1;
413 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv; 413 $arg{cookie_jar}{$cdom}{$cpath}{$name} = \%kv;
414 } 414 }
415 } 415 }
416 416
417 if ($_[1]{Status} =~ /^30[12]$/ && $recurse) {
418 # microsoft and other assholes don't give a shit for following standards, 417 # microsoft and other shitheads don't give a shit for following standards,
419 # try to support a common form of broken Location header. 418 # try to support some common forms of broken Location headers.
419 if ($_[1]{location} !~ /^(?: $ | [^:\/?\#]+ : )/x) {
420 $_[1]{location} =~ s/^\.\/+//;
421
420 $_[1]{location} =~ s%^/%$scheme://$uhost:$uport/%; 422 my $url = "$scheme://$uhost:$uport";
421 423
424 unless ($_[1]{location} =~ s/^\///) {
425 $url .= $upath;
426 $url =~ s/\/[^\/]*$//;
427 }
428
429 $_[1]{location} = "$url/$_[1]{location}";
430 }
431
432 if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
433 # apparently, mozilla et al. just change POST to GET here
434 # more research is needed before we do the same
422 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb); 435 http_request ($method, $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
436 } elsif ($_[1]{Status} == 303 && $recurse) {
437 # even http/1.1 is unlear on how to mutate the method
438 $method = "GET" unless $method eq "HEAD";
439 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
440 } elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET|HEAD)$/) {
441 http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
423 } else { 442 } else {
424 $cb->($_[0], $_[1]); 443 $cb->($_[0], $_[1]);
425 } 444 }
426 }; 445 };
427 446

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines