… | |
… | |
48 | use AnyEvent::Socket (); |
48 | use AnyEvent::Socket (); |
49 | use AnyEvent::Handle (); |
49 | use AnyEvent::Handle (); |
50 | |
50 | |
51 | use base Exporter::; |
51 | use base Exporter::; |
52 | |
52 | |
53 | our $VERSION = '1.05'; |
53 | our $VERSION = '1.1'; |
54 | |
54 | |
55 | our @EXPORT = qw(http_get http_post http_head http_request); |
55 | our @EXPORT = qw(http_get http_post http_head http_request); |
56 | |
56 | |
57 | our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; |
57 | our $USERAGENT = "Mozilla/5.0 (compatible; AnyEvent::HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)"; |
58 | our $MAX_RECURSE = 10; |
58 | our $MAX_RECURSE = 10; |
… | |
… | |
104 | headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> |
104 | headers, the "pseudo-headers" C<HTTPVersion>, C<Status> and C<Reason> |
105 | contain the three parts of the HTTP Status-Line of the same name. The |
105 | contain the three parts of the HTTP Status-Line of the same name. The |
106 | pseudo-header C<URL> contains the original URL (which can differ from the |
106 | pseudo-header C<URL> contains the original URL (which can differ from the |
107 | requested URL when following redirects). |
107 | requested URL when following redirects). |
108 | |
108 | |
109 | If the server sends a header multiple lines, then their contents will be |
109 | If the server sends a header multiple times, then their contents will be |
110 | joined together with a command (C<,>). |
110 | joined together with a comma (C<,>), as per the HTTP spec. |
111 | |
111 | |
112 | If an internal error occurs, such as not being able to resolve a hostname, |
112 | If an internal error occurs, such as not being able to resolve a hostname, |
113 | then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599> |
113 | then C<$data> will be C<undef>, C<< $headers->{Status} >> will be C<599> |
114 | and the C<Reason> pseudo-header will contain an error message. |
114 | and the C<Reason> pseudo-header will contain an error message. |
115 | |
115 | |
… | |
… | |
236 | sub _get_slot($$) { |
236 | sub _get_slot($$) { |
237 | push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; |
237 | push @{ $CO_SLOT{$_[0]}[1] }, $_[1]; |
238 | |
238 | |
239 | _slot_schedule $_[0]; |
239 | _slot_schedule $_[0]; |
240 | } |
240 | } |
|
|
241 | |
|
|
242 | our $qr_nl = qr<\015?\012>; |
|
|
243 | our $qr_nlnl = qr<\015?\012\015?\012>; |
241 | |
244 | |
242 | sub http_request($$@) { |
245 | sub http_request($$@) { |
243 | my $cb = pop; |
246 | my $cb = pop; |
244 | my ($method, $url, %arg) = @_; |
247 | my ($method, $url, %arg) = @_; |
245 | |
248 | |
… | |
… | |
339 | return unless $state{connect_guard}; |
342 | return unless $state{connect_guard}; |
340 | |
343 | |
341 | $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { |
344 | $state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub { |
342 | $state{fh} = shift |
345 | $state{fh} = shift |
343 | or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); |
346 | or return $cb->(undef, { Status => 599, Reason => "$!", URL => $url }); |
|
|
347 | pop; # free memory, save a tree |
344 | |
348 | |
345 | delete $state{connect_guard}; # reduce memory usage, save a tree |
349 | return unless delete $state{connect_guard}; |
346 | |
350 | |
347 | # get handle |
351 | # get handle |
348 | $state{handle} = new AnyEvent::Handle |
352 | $state{handle} = new AnyEvent::Handle |
349 | fh => $state{fh}; |
353 | fh => $state{fh}, |
|
|
354 | timeout => $timeout; |
350 | |
355 | |
351 | # limit the number of persistent connections |
356 | # limit the number of persistent connections |
|
|
357 | # keepalive not yet supported |
352 | if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { |
358 | if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) { |
353 | ++$KA_COUNT{$_[1]}; |
359 | ++$KA_COUNT{$_[1]}; |
354 | $state{handle}{ka_count_guard} = AnyEvent::Util::guard { --$KA_COUNT{$_[1]} }; |
360 | $state{handle}{ka_count_guard} = AnyEvent::Util::guard { |
|
|
361 | --$KA_COUNT{$_[1]} |
|
|
362 | }; |
355 | $hdr{connection} = "keep-alive"; |
363 | $hdr{connection} = "keep-alive"; |
356 | delete $hdr{connection}; # keep-alive not yet supported |
|
|
357 | } else { |
364 | } else { |
358 | delete $hdr{connection}; |
365 | delete $hdr{connection}; |
359 | } |
366 | } |
360 | |
367 | |
361 | # (re-)configure handle |
368 | # (re-)configure handle |
362 | $state{handle}->timeout ($timeout); |
|
|
363 | $state{handle}->on_error (sub { |
369 | $state{handle}->on_error (sub { |
364 | my $errno = "$!"; |
370 | my $errno = "$!"; |
365 | %state = (); |
371 | %state = (); |
366 | $cb->(undef, { Status => 599, Reason => $errno, URL => $url }); |
372 | $cb->(undef, { Status => 599, Reason => $errno, URL => $url }); |
367 | }); |
373 | }); |
… | |
… | |
372 | |
378 | |
373 | $state{handle}->starttls ("connect") if $rscheme eq "https"; |
379 | $state{handle}->starttls ("connect") if $rscheme eq "https"; |
374 | |
380 | |
375 | # handle actual, non-tunneled, request |
381 | # handle actual, non-tunneled, request |
376 | my $handle_actual_request = sub { |
382 | my $handle_actual_request = sub { |
377 | # $state{handle}->starttls ("connect") if $uscheme eq "https"; |
383 | $state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls}; |
378 | |
384 | |
379 | # send request |
385 | # send request |
380 | $state{handle}->push_write ( |
386 | $state{handle}->push_write ( |
381 | "$method $rpath HTTP/1.0\015\012" |
387 | "$method $rpath HTTP/1.0\015\012" |
382 | . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) |
388 | . (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr) |
… | |
… | |
385 | ); |
391 | ); |
386 | |
392 | |
387 | %hdr = (); # reduce memory usage, save a kitten |
393 | %hdr = (); # reduce memory usage, save a kitten |
388 | |
394 | |
389 | # status line |
395 | # status line |
390 | $state{handle}->push_read (line => qr/\015?\012/, sub { |
396 | $state{handle}->push_read (line => $qr_nl, sub { |
391 | $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix |
397 | $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix |
392 | or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url })); |
398 | or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid server response ($_[1])", URL => $url })); |
393 | |
399 | |
394 | my %hdr = ( # response headers |
400 | my %hdr = ( # response headers |
395 | HTTPVersion => ",$1", |
401 | HTTPVersion => ",$1", |
… | |
… | |
397 | Reason => ",$3", |
403 | Reason => ",$3", |
398 | URL => ",$url" |
404 | URL => ",$url" |
399 | ); |
405 | ); |
400 | |
406 | |
401 | # headers, could be optimized a bit |
407 | # headers, could be optimized a bit |
402 | $state{handle}->unshift_read (line => qr/\015?\012\015?\012/, sub { |
408 | $state{handle}->unshift_read (line => $qr_nlnl, sub { |
403 | for ("$_[1]\012") { |
409 | for ("$_[1]\012") { |
404 | y/\015//d; # weed out any \015, as they show up in the weirdest of places. |
410 | y/\015//d; # weed out any \015, as they show up in the weirdest of places. |
405 | |
411 | |
406 | # we support spaces in field names, as lotus domino |
412 | # we support spaces in field names, as lotus domino |
407 | # creates them (actually spaces around seperators |
413 | # creates them (actually spaces around seperators |
… | |
… | |
420 | |
426 | |
421 | substr $_, 0, 1, "" |
427 | substr $_, 0, 1, "" |
422 | for values %hdr; |
428 | for values %hdr; |
423 | |
429 | |
424 | my $finish = sub { |
430 | my $finish = sub { |
425 | # TODO: use destroy method, when/if available |
|
|
426 | #$state{handle}->destroy; |
431 | $state{handle}->destroy; |
427 | $state{handle}->on_eof (undef); |
|
|
428 | $state{handle}->on_error (undef); |
|
|
429 | %state = (); |
432 | %state = (); |
430 | |
433 | |
431 | # set-cookie processing |
434 | # set-cookie processing |
432 | if ($arg{cookie_jar}) { |
435 | if ($arg{cookie_jar}) { |
433 | for ($hdr{"set-cookie"}) { |
436 | for ($hdr{"set-cookie"}) { |
… | |
… | |
538 | if ($proxy && $uscheme eq "https") { |
541 | if ($proxy && $uscheme eq "https") { |
539 | # oh dear, we have to wrap it into a connect request |
542 | # oh dear, we have to wrap it into a connect request |
540 | |
543 | |
541 | # maybe re-use $uauthority with patched port? |
544 | # maybe re-use $uauthority with patched port? |
542 | $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); |
545 | $state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012"); |
543 | $state{handle}->push_read (line => qr/\015?\012\015?\012/, sub { |
546 | $state{handle}->push_read (line => $qr_nlnl, sub { |
544 | $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix |
547 | $_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix |
545 | or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid proxy connect response ($_[1])", URL => $url })); |
548 | or return (%state = (), $cb->(undef, { Status => 599, Reason => "invalid proxy connect response ($_[1])", URL => $url })); |
546 | |
549 | |
547 | if ($2 == 200) { |
550 | if ($2 == 200) { |
548 | $rpath = $upath; |
551 | $rpath = $upath; |