[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.43 by root, Mon Jul 6 03:03:12 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.452 ();
47	use AnyEvent::Util ();	47	use AnyEvent::Util ();
48	use AnyEvent::Socket ();	48	use AnyEvent::Socket ();
49	use AnyEvent::Handle ();	49	use AnyEvent::Handle ();
…		…
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 {
…		…
431	# things seen, not parsed:	491	# things seen, not parsed:
432	# p3pP="NON CUR OTPi OUR NOR UNI"	492	# p3pP="NON CUR OTPi OUR NOR UNI"
433		493
434	$hdr{lc $1} .= ",$2"	494	$hdr{lc $1} .= ",$2"
435	while /\G	495	while /\G
436	([^:\000-\037]+):	496	([^:\000-\037]*):
437	[\011\040]*	497	[\011\040]*
438	((?: [^\012]+ \| \012[\011\040] )*)	498	((?: [^\012]+ \| \012[\011\040] )*)
439	\012	499	\012
440	/gxc;	500	/gxc;
441		501
…		…
444	}	504	}
445		505
446	substr $_, 0, 1, ""	506	substr $_, 0, 1, ""
447	for values %hdr;	507	for values %hdr;
448		508
		509	# redirect handling
		510	# microsoft and other shitheads don't give a shit for following standards,
		511	# try to support some common forms of broken Location headers.
		512	if ($hdr{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
		513	$hdr{location} =~ s/^\.\/+//;
		514
		515	my $url = "$rscheme://$uhost:$uport";
		516
		517	unless ($hdr{location} =~ s/^\///) {
		518	$url .= $upath;
		519	$url =~ s/\/[^\/]*$//;
		520	}
		521
		522	$hdr{location} = "$url/$hdr{location}";
		523	}
		524
		525	my $redirect;
		526
		527	if ($recurse) {
		528	if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") {
		529	# apparently, mozilla et al. just change POST to GET here
		530	# more research is needed before we do the same
		531	$redirect = 1;
		532	} elsif ($hdr{Status} == 303) {
		533	# even http/1.1 is unclear on how to mutate the method
		534	$method = "GET" unless $method eq "HEAD";
		535	$redirect = 1;
		536	} elsif ($hdr{Status} == 307 && $method =~ /^(?:GET\|HEAD)$/) {
		537	$redirect = 1;
		538	}
		539	}
		540
449	my $finish = sub {	541	my $finish = sub {
450	$state{handle}->destroy;	542	$state{handle}->destroy if $state{handle};
451	%state = ();	543	%state = ();
452		544
453	# set-cookie processing	545	# set-cookie processing
454	if ($arg{cookie_jar}) {	546	if ($arg{cookie_jar}) {
455	for ($hdr{"set-cookie"}) {	547	for ($_[1]{"set-cookie"}) {
456	# parse NAME=VALUE	548	# parse NAME=VALUE
457	my @kv;	549	my @kv;
458		550
459	while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {	551	while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {
460	my $name = $1;	552	my $name = $1;
…		…
498		590
499	redo if /\G\s*,/gc;	591	redo if /\G\s*,/gc;
500	}	592	}
501	}	593	}
502		594
503	# microsoft and other shitheads don't give a shit for following standards,	595	if ($redirect) {
504	# try to support some common forms of broken Location headers.	596	# we ignore any errors, as it is very common to receive
505	if ($_[1]{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {	597	# Content-Length != 0 but no actual body
506	$_[1]{location} =~ s/^\.\/+//;	598	# 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);	599	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 {	600	} else {
529	$cb->($_[0], $_[1]);	601	$cb->($_[0], $_[1]);
530	}	602	}
531	};	603	};
532		604
533	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {	605	my $len = $hdr{"content-length"};
		606
		607	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
		608	$finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
		609	} elsif (
		610	$hdr{Status} =~ /^(?:1..\|[23]04)$/
		611	or $method eq "HEAD"
		612	or (defined $len && !$len)
		613	) {
		614	# no body
534	$finish->(undef, \%hdr);	615	$finish->("", \%hdr);
535	} else {	616	} else {
536	if (exists $hdr{"content-length"}) {	617	# body handling, four different code paths
537	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {	618	# for want_body_handle, on_body (2x), normal (2x)
538	# could cache persistent connection now	619	# we might read too much here, but it does not matter yet (no pers. connections)
539	if ($hdr{connection} =~ /\bkeep-alive\b/i) {	620	if (!$redirect && $arg{want_body_handle}) {
540	# but we don't, due to misdesigns, this is annoyingly complex	621	$_[0]->on_eof (undef);
		622	$_[0]->on_error (undef);
		623	$_[0]->on_read (undef);
		624
		625	$finish->(delete $state{handle}, \%hdr);
		626
		627	} elsif ($arg{on_body}) {
		628	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
		629	if ($len) {
		630	$_[0]->on_eof (undef);
		631	$_[0]->on_read (sub {
		632	$len -= length $_[0]{rbuf};
		633
		634	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		635	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
		636
		637	$len > 0
		638	or $finish->("", \%hdr);
541	};	639	});
542		640	} else {
		641	$_[0]->on_eof (sub {
543	$finish->($_[1], \%hdr);	642	$finish->("", \%hdr);
		643	});
		644	$_[0]->on_read (sub {
		645	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		646	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
		647	});
544	});	648	}
545	} else {	649	} 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);	650	$_[0]->on_eof (undef);
		651
		652	if ($len) {
		653	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
		654	$_[0]->on_read (sub {
		655	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
		656	if $len <= length $_[0]{rbuf};
		657	});
		658	} else {
		659	$_[0]->on_error (sub {
		660	$! == Errno::EPIPE \|\| !$!
		661	? $finish->(delete $_[0]{rbuf}, \%hdr)
		662	: $finish->(undef, { Status => 599, Reason => $_[2], URL => $url });
		663	});
554	$_[0]->on_read (sub { });	664	$_[0]->on_read (sub { });
		665	}
555	}	666	}
556	}	667	}
557	});	668	});
558	});	669	});
559	};	670	};
…		…
622	=item $AnyEvent::HTTP::USERAGENT	733	=item $AnyEvent::HTTP::USERAGENT
623		734
624	The default value for the C<User-Agent> header (the default is	735	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)>).	736	C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
626		737
627	=item $AnyEvent::HTTP::MAX_PERSISTENT	738	=item $AnyEvent::HTTP::MAX_PER_HOST
628		739
629	The maximum number of persistent connections to keep open (default: 8).	740	The maximum number of concurrent conenctions to the same host (identified
		741	by the hostname). If the limit is exceeded, then the additional requests
		742	are queued until previous connections are closed.
630		743
631	Not implemented currently.	744	The default value for this is C<4>, and it is highly advisable to not
632		745	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		746
639	=item $AnyEvent::HTTP::ACTIVE	747	=item $AnyEvent::HTTP::ACTIVE
640		748
641	The number of active connections. This is not the number of currently	749	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	750	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.43 by root, Mon Jul 6 03:03:12 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.43 by root, Mon Jul 6 03:03:12 2009 UTC