[ViewVC] Diff of: cvs/AnyEvent-HTTP/HTTP.pm

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.40 by root, Sun Jul 5 01:45:01 2009 UTC vs.
Revision 1.44 by root, Tue Jul 7 00:15:32 2009 UTC

…		…
39	package AnyEvent::HTTP;	39	package AnyEvent::HTTP;
40		40
41	use strict;	41	use strict;
42	no warnings;	42	no warnings;
43		43
44	use Carp;	44	use Errno ();
45		45
46	use AnyEvent 4.452 ();	46	use AnyEvent 4.8 ();
47	use AnyEvent::Util ();	47	use AnyEvent::Util ();
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.12';	53	our $VERSION = '1.4';
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; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";	57	our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58	our $MAX_RECURSE = 10;	58	our $MAX_RECURSE = 10;
59	our $MAX_PERSISTENT = 8;	59	our $MAX_PERSISTENT = 8;
60	our $PERSISTENT_TIMEOUT = 2;	60	our $PERSISTENT_TIMEOUT = 2;
61	our $TIMEOUT = 300;	61	our $TIMEOUT = 300;
62		62
63	# changing these is evil	63	# changing these is evil
64	our $MAX_PERSISTENT_PER_HOST = 2;	64	our $MAX_PERSISTENT_PER_HOST = 0;
65	our $MAX_PER_HOST = 4;	65	our $MAX_PER_HOST = 4;
66		66
67	our $PROXY;	67	our $PROXY;
68	our $ACTIVE = 0;	68	our $ACTIVE = 0;
69		69
…		…
94	When called in void context, nothing is returned. In other contexts,	94	When called in void context, nothing is returned. In other contexts,
95	C<http_request> returns a "cancellation guard" - you have to keep the	95	C<http_request> returns a "cancellation guard" - you have to keep the
96	object at least alive until the callback get called. If the object gets	96	object at least alive until the callback get called. If the object gets
97	destroyed before the callbakc is called, the request will be cancelled.	97	destroyed before the callbakc is called, the request will be cancelled.
98		98
99	The callback will be called with the response data as first argument	99	The callback will be called with the response body data as first argument
100	(or C<undef> if it wasn't available due to errors), and a hash-ref with	100	(or C<undef> if an error occured), and a hash-ref with response headers as
101	response headers as second argument.	101	second argument.
102		102
103	All the headers in that hash are lowercased. In addition to the response	103	All the headers in that hash are lowercased. In addition to the response
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
…		…
108		108
109	If the server sends a header multiple times, then their contents will be	109	If the server sends a header multiple times, then their contents will be
110	joined together with a comma (C<,>), as per the HTTP spec.	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<59x>
114	and the C<Reason> pseudo-header will contain an error message.	114	(usually C<599>) and the C<Reason> pseudo-header will contain an error
		115	message.
115		116
116	A typical callback might look like this:	117	A typical callback might look like this:
117		118
118	sub {	119	sub {
119	my ($body, $hdr) = @_;	120	my ($body, $hdr) = @_;
…		…
184	verification, highest compatibility) and high-security (CA and common-name	185	verification, highest compatibility) and high-security (CA and common-name
185	verification) TLS context.	186	verification) TLS context.
186		187
187	The default for this option is C<low>, which could be interpreted as "give	188	The default for this option is C<low>, which could be interpreted as "give
188	me the page, no matter what".	189	me the page, no matter what".
		190
		191	=item on_header => $callback->($headers)
		192
		193	When specified, this callback will be called with the header hash as soon
		194	as headers have been successfully received from the remote server (not on
		195	locally-generated errors).
		196
		197	It has to return either true (in which case AnyEvent::HTTP will continue),
		198	or false, in which case AnyEvent::HTTP will cancel the download (and call
		199	the finish callback with an error code of C<598>).
		200
		201	This callback is useful, among other things, to quickly reject unwanted
		202	content, which, if it is supposed to be rare, can be faster than first
		203	doing a C<HEAD> request.
		204
		205	Example: cancel the request unless the content-type is "text/html".
		206
		207	on_header => sub {
		208	$_[0]{"content-type"} =~ /^text\/html\s*(?:;\|$)/
		209	},
		210
		211	=item on_body => $callback->($partial_body, $headers)
		212
		213	When specified, all body data will be passed to this callback instead of
		214	to the completion callback. The completion callback will get the empty
		215	string instead of the body data.
		216
		217	It has to return either true (in which case AnyEvent::HTTP will continue),
		218	or false, in which case AnyEvent::HTTP will cancel the download (and call
		219	the completion callback with an error code of C<598>).
		220
		221	This callback is useful when the data is too large to be held in memory
		222	(so the callback writes it to a file) or when only some information should
		223	be extracted, or when the body should be processed incrementally.
		224
		225	It is usually preferred over doing your own body handling via
		226	C<want_body_handle>.
		227
		228	=item want_body_handle => $enable
		229
		230	When enabled (default is disabled), the behaviour of AnyEvent::HTTP
		231	changes considerably: after parsing the headers, and instead of
		232	downloading the body (if any), the completion callback will be
		233	called. Instead of the C<$body> argument containing the body data, the
		234	callback will receive the L<AnyEvent::Handle> object associated with the
		235	connection. In error cases, C<undef> will be passed. When there is no body
		236	(e.g. status C<304>), the empty string will be passed.
		237
		238	The handle object might or might not be in TLS mode, might be connected to
		239	a proxy, be a persistent connection etc., and configured in unspecified
		240	ways. The user is responsible for this handle (it will not be used by this
		241	module anymore).
		242
		243	This is useful with some push-type services, where, after the initial
		244	headers, an interactive protocol is used (typical example would be the
		245	push-style twitter API which starts a JSON/XML stream).
		246
		247	If you think you need this, first have a look at C<on_body>, to see if
		248	that doesn'T solve your problem in a better way.
189		249
190	=back	250	=back
191		251
192	Example: make a simple HTTP GET request for http://www.nethype.de/	252	Example: make a simple HTTP GET request for http://www.nethype.de/
193		253
…		…
252	}	312	}
253		313
254	our $qr_nl = qr<\015?\012>;	314	our $qr_nl = qr<\015?\012>;
255	our $qr_nlnl = qr<\015?\012\015?\012>;	315	our $qr_nlnl = qr<\015?\012\015?\012>;
256		316
257	our $TLS_CTX_LOW = { cache => 1, dh => undef, sslv2 => 1 };	317	our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
258	our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_cn => "https", dh => "skip4096" };	318	our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
259		319
260	sub http_request($$@) {	320	sub http_request($$@) {
261	my $cb = pop;	321	my $cb = pop;
262	my ($method, $url, %arg) = @_;	322	my ($method, $url, %arg) = @_;
263		323
…		…
280	if $recurse < 0;	340	if $recurse < 0;
281		341
282	my $proxy = $arg{proxy} \|\| $PROXY;	342	my $proxy = $arg{proxy} \|\| $PROXY;
283	my $timeout = $arg{timeout} \|\| $TIMEOUT;	343	my $timeout = $arg{timeout} \|\| $TIMEOUT;
284		344
285	$hdr{"user-agent"} \|\|= $USERAGENT;
286
287	my ($uscheme, $uauthority, $upath, $query, $fragment) =	345	my ($uscheme, $uauthority, $upath, $query, $fragment) =
288	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;	346	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;
289		347
290	$uscheme = lc $uscheme;	348	$uscheme = lc $uscheme;
291		349
292	my $uport = $uscheme eq "http" ? 80	350	my $uport = $uscheme eq "http" ? 80
293	: $uscheme eq "https" ? 443	351	: $uscheme eq "https" ? 443
294	: return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported (not '$uscheme')", URL => $url });	352	: return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url });
295
296	$hdr{referer} \|\|= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
297		353
298	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x	354	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
299	or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });	355	or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
300		356
301	my $uhost = $1;	357	my $uhost = $1;
302	$uport = $2 if defined $2;	358	$uport = $2 if defined $2;
		359
		360	$hdr{host} = defined $2 ? "$uhost:$2" : "$uhost";
303		361
304	$uhost =~ s/^\[(.*)\]$/$1/;	362	$uhost =~ s/^\[(.*)\]$/$1/;
305	$upath .= "?$query" if length $query;	363	$upath .= "?$query" if length $query;
306		364
307	$upath =~ s%^/?%/%;	365	$upath =~ s%^/?%/%;
…		…
347	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";	405	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
348	} else {	406	} else {
349	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);	407	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
350	}	408	}
351		409
352	$hdr{host} = $uhost;	410	$hdr{"user-agent"} \|\|= $USERAGENT;
		411	$hdr{referer} \|\|= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
		412
353	$hdr{"content-length"} = length $arg{body};	413	$hdr{"content-length"} = length $arg{body};
354		414
355	my %state = (connect_guard => 1);	415	my %state = (connect_guard => 1);
356		416
357	_get_slot $uhost, sub {	417	_get_slot $uhost, sub {
…		…
359		419
360	return unless $state{connect_guard};	420	return unless $state{connect_guard};
361		421
362	$state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {	422	$state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {
363	$state{fh} = shift	423	$state{fh} = shift
		424	or do {
		425	my $err = "$!";
		426	%state = ();
364	or return (%state = (), $cb->(undef, { Status => 599, Reason => "$!", URL => $url }));	427	return $cb->(undef, { Status => 599, Reason => $err, URL => $url });
		428	};
		429
365	pop; # free memory, save a tree	430	pop; # free memory, save a tree
366		431
367	return unless delete $state{connect_guard};	432	return unless delete $state{connect_guard};
368		433
369	# get handle	434	# get handle
…		…
431	# things seen, not parsed:	496	# things seen, not parsed:
432	# p3pP="NON CUR OTPi OUR NOR UNI"	497	# p3pP="NON CUR OTPi OUR NOR UNI"
433		498
434	$hdr{lc $1} .= ",$2"	499	$hdr{lc $1} .= ",$2"
435	while /\G	500	while /\G
436	([^:\000-\037]+):	501	([^:\000-\037]*):
437	[\011\040]*	502	[\011\040]*
438	((?: [^\012]+ \| \012[\011\040] )*)	503	((?: [^\012]+ \| \012[\011\040] )*)
439	\012	504	\012
440	/gxc;	505	/gxc;
441		506
…		…
444	}	509	}
445		510
446	substr $_, 0, 1, ""	511	substr $_, 0, 1, ""
447	for values %hdr;	512	for values %hdr;
448		513
		514	# redirect handling
		515	# microsoft and other shitheads don't give a shit for following standards,
		516	# try to support some common forms of broken Location headers.
		517	if ($hdr{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
		518	$hdr{location} =~ s/^\.\/+//;
		519
		520	my $url = "$rscheme://$uhost:$uport";
		521
		522	unless ($hdr{location} =~ s/^\///) {
		523	$url .= $upath;
		524	$url =~ s/\/[^\/]*$//;
		525	}
		526
		527	$hdr{location} = "$url/$hdr{location}";
		528	}
		529
		530	my $redirect;
		531
		532	if ($recurse) {
		533	if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") {
		534	# apparently, mozilla et al. just change POST to GET here
		535	# more research is needed before we do the same
		536	$redirect = 1;
		537	} elsif ($hdr{Status} == 303) {
		538	# even http/1.1 is unclear on how to mutate the method
		539	$method = "GET" unless $method eq "HEAD";
		540	$redirect = 1;
		541	} elsif ($hdr{Status} == 307 && $method =~ /^(?:GET\|HEAD)$/) {
		542	$redirect = 1;
		543	}
		544	}
		545
449	my $finish = sub {	546	my $finish = sub {
450	$state{handle}->destroy;	547	$state{handle}->destroy if $state{handle};
451	%state = ();	548	%state = ();
452		549
453	# set-cookie processing	550	# set-cookie processing
454	if ($arg{cookie_jar}) {	551	if ($arg{cookie_jar}) {
455	for ($hdr{"set-cookie"}) {	552	for ($_[1]{"set-cookie"}) {
456	# parse NAME=VALUE	553	# parse NAME=VALUE
457	my @kv;	554	my @kv;
458		555
459	while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {	556	while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {
460	my $name = $1;	557	my $name = $1;
…		…
498		595
499	redo if /\G\s*,/gc;	596	redo if /\G\s*,/gc;
500	}	597	}
501	}	598	}
502		599
503	# microsoft and other shitheads don't give a shit for following standards,	600	if ($redirect) {
504	# try to support some common forms of broken Location headers.	601	# we ignore any errors, as it is very common to receive
505	if ($_[1]{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {	602	# Content-Length != 0 but no actual body
506	$_[1]{location} =~ s/^\.\/+//;	603	# we also access %hdr, as $_[1] might be an erro
507
508	my $url = "$rscheme://$uhost:$uport";
509
510	unless ($_[1]{location} =~ s/^\///) {
511	$url .= $upath;
512	$url =~ s/\/[^\/]*$//;
513	}
514
515	$_[1]{location} = "$url/$_[1]{location}";
516	}
517
518	if ($_[1]{Status} =~ /^30[12]$/ && $recurse && $method ne "POST") {
519	# apparently, mozilla et al. just change POST to GET here
520	# more research is needed before we do the same
521	http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);	604	http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb);
522	} elsif ($_[1]{Status} == 303 && $recurse) {
523	# even http/1.1 is unclear on how to mutate the method
524	$method = "GET" unless $method eq "HEAD";
525	http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
526	} elsif ($_[1]{Status} == 307 && $recurse && $method =~ /^(?:GET\|HEAD)$/) {
527	http_request ($method => $_[1]{location}, %arg, recurse => $recurse - 1, $cb);
528	} else {	605	} else {
529	$cb->($_[0], $_[1]);	606	$cb->($_[0], $_[1]);
530	}	607	}
531	};	608	};
532		609
533	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {	610	my $len = $hdr{"content-length"};
		611
		612	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
		613	$finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
		614	} elsif (
		615	$hdr{Status} =~ /^(?:1..\|[23]04)$/
		616	or $method eq "HEAD"
		617	or (defined $len && !$len)
		618	) {
		619	# no body
534	$finish->(undef, \%hdr);	620	$finish->("", \%hdr);
535	} else {	621	} else {
536	if (exists $hdr{"content-length"}) {	622	# body handling, four different code paths
537	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {	623	# for want_body_handle, on_body (2x), normal (2x)
538	# could cache persistent connection now	624	# we might read too much here, but it does not matter yet (no pers. connections)
539	if ($hdr{connection} =~ /\bkeep-alive\b/i) {	625	if (!$redirect && $arg{want_body_handle}) {
540	# but we don't, due to misdesigns, this is annoyingly complex	626	$_[0]->on_eof (undef);
		627	$_[0]->on_error (undef);
		628	$_[0]->on_read (undef);
		629
		630	$finish->(delete $state{handle}, \%hdr);
		631
		632	} elsif ($arg{on_body}) {
		633	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
		634	if ($len) {
		635	$_[0]->on_eof (undef);
		636	$_[0]->on_read (sub {
		637	$len -= length $_[0]{rbuf};
		638
		639	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		640	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
		641
		642	$len > 0
		643	or $finish->("", \%hdr);
541	};	644	});
542		645	} else {
		646	$_[0]->on_eof (sub {
543	$finish->($_[1], \%hdr);	647	$finish->("", \%hdr);
		648	});
		649	$_[0]->on_read (sub {
		650	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		651	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
		652	});
544	});	653	}
545	} else {	654	} else {
546	# too bad, need to read until we get an error or EOF,
547	# no way to detect winged data.
548	$_[0]->on_error (sub {
549	# delete ought to be more efficient, as we would have to make
550	# a copy otherwise as $_[0] gets destroyed.
551	$finish->(delete $_[0]{rbuf}, \%hdr);
552	});
553	$_[0]->on_eof (undef);	655	$_[0]->on_eof (undef);
		656
		657	if ($len) {
		658	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
		659	$_[0]->on_read (sub {
		660	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
		661	if $len <= length $_[0]{rbuf};
		662	});
		663	} else {
		664	$_[0]->on_error (sub {
		665	$! == Errno::EPIPE \|\| !$!
		666	? $finish->(delete $_[0]{rbuf}, \%hdr)
		667	: $finish->(undef, { Status => 599, Reason => $_[2], URL => $url });
		668	});
554	$_[0]->on_read (sub { });	669	$_[0]->on_read (sub { });
		670	}
555	}	671	}
556	}	672	}
557	});	673	});
558	});	674	});
559	};	675	};
…		…
622	=item $AnyEvent::HTTP::USERAGENT	738	=item $AnyEvent::HTTP::USERAGENT
623		739
624	The default value for the C<User-Agent> header (the default is	740	The default value for the C<User-Agent> header (the default is
625	C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).	741	C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
626		742
627	=item $AnyEvent::HTTP::MAX_PERSISTENT	743	=item $AnyEvent::HTTP::MAX_PER_HOST
628		744
629	The maximum number of persistent connections to keep open (default: 8).	745	The maximum number of concurrent conenctions to the same host (identified
		746	by the hostname). If the limit is exceeded, then the additional requests
		747	are queued until previous connections are closed.
630		748
631	Not implemented currently.	749	The default value for this is C<4>, and it is highly advisable to not
632		750	increase it.
633	=item $AnyEvent::HTTP::PERSISTENT_TIMEOUT
634
635	The maximum time to cache a persistent connection, in seconds (default: 2).
636
637	Not implemented currently.
638		751
639	=item $AnyEvent::HTTP::ACTIVE	752	=item $AnyEvent::HTTP::ACTIVE
640		753
641	The number of active connections. This is not the number of currently	754	The number of active connections. This is not the number of currently
642	running requests, but the number of currently open and non-idle TCP	755	running requests, but the number of currently open and non-idle TCP

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.40 by root, Sun Jul 5 01:45:01 2009 UTC vs. Revision 1.44 by root, Tue Jul 7 00:15:32 2009 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.40 by root, Sun Jul 5 01:45:01 2009 UTC vs.
Revision 1.44 by root, Tue Jul 7 00:15:32 2009 UTC