[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.42 by root, Mon Jul 6 00:08:16 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 ();
…		…
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;
…		…
347	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";	403	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
348	} else {	404	} else {
349	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);	405	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
350	}	406	}
351		407
		408	$hdr{"user-agent"} \|\|= $USERAGENT;
		409	$hdr{referer} \|\|= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
		410
352	$hdr{host} = $uhost;	411	$hdr{host} = "$uhost:$uport";
353	$hdr{"content-length"} = length $arg{body};	412	$hdr{"content-length"} = length $arg{body};
354		413
355	my %state = (connect_guard => 1);	414	my %state = (connect_guard => 1);
356		415
357	_get_slot $uhost, sub {	416	_get_slot $uhost, sub {
…		…
444	}	503	}
445		504
446	substr $_, 0, 1, ""	505	substr $_, 0, 1, ""
447	for values %hdr;	506	for values %hdr;
448		507
		508	# redirect handling
		509	# microsoft and other shitheads don't give a shit for following standards,
		510	# try to support some common forms of broken Location headers.
		511	if ($hdr{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
		512	$hdr{location} =~ s/^\.\/+//;
		513
		514	my $url = "$rscheme://$uhost:$uport";
		515
		516	unless ($hdr{location} =~ s/^\///) {
		517	$url .= $upath;
		518	$url =~ s/\/[^\/]*$//;
		519	}
		520
		521	$hdr{location} = "$url/$hdr{location}";
		522	}
		523
		524	my $redirect;
		525
		526	if ($recurse) {
		527	if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") {
		528	# apparently, mozilla et al. just change POST to GET here
		529	# more research is needed before we do the same
		530	$redirect = 1;
		531	} elsif ($hdr{Status} == 303) {
		532	# even http/1.1 is unclear on how to mutate the method
		533	$method = "GET" unless $method eq "HEAD";
		534	$redirect = 1;
		535	} elsif ($hdr{Status} == 307 && $method =~ /^(?:GET\|HEAD)$/) {
		536	$redirect = 1;
		537	}
		538	}
		539
449	my $finish = sub {	540	my $finish = sub {
450	$state{handle}->destroy;	541	$state{handle}->destroy if $state{handle};
451	%state = ();	542	%state = ();
452		543
453	# set-cookie processing	544	# set-cookie processing
454	if ($arg{cookie_jar}) {	545	if ($arg{cookie_jar}) {
455	for ($hdr{"set-cookie"}) {	546	for ($_[1]{"set-cookie"}) {
456	# parse NAME=VALUE	547	# parse NAME=VALUE
457	my @kv;	548	my @kv;
458		549
459	while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {	550	while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {
460	my $name = $1;	551	my $name = $1;
…		…
498		589
499	redo if /\G\s*,/gc;	590	redo if /\G\s*,/gc;
500	}	591	}
501	}	592	}
502		593
503	# microsoft and other shitheads don't give a shit for following standards,	594	if ($redirect) {
504	# try to support some common forms of broken Location headers.	595	# we ignore any errors, as it is very common to receive
505	if ($_[1]{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {	596	# Content-Length != 0 but no actual body
506	$_[1]{location} =~ s/^\.\/+//;	597	# 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);	598	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 {	599	} else {
529	$cb->($_[0], $_[1]);	600	$cb->($_[0], $_[1]);
530	}	601	}
531	};	602	};
532		603
533	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {	604	my $len = $hdr{"content-length"};
		605
		606	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
		607	$finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
		608	} elsif (
		609	$hdr{Status} =~ /^(?:1..\|[23]04)$/
		610	or $method eq "HEAD"
		611	or (defined $len && !$len)
		612	) {
		613	# no body
534	$finish->(undef, \%hdr);	614	$finish->("", \%hdr);
535	} else {	615	} else {
536	if (exists $hdr{"content-length"}) {	616	# body handling, four different code paths
537	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {	617	# for want_body_handle, on_body (2x), normal (2x)
538	# could cache persistent connection now	618	# we might read too much here, but it does not matter yet (no pers. connections)
539	if ($hdr{connection} =~ /\bkeep-alive\b/i) {	619	if (!$redirect && $arg{want_body_handle}) {
540	# but we don't, due to misdesigns, this is annoyingly complex	620	$_[0]->on_eof (undef);
		621	$_[0]->on_error (undef);
		622	$_[0]->on_read (undef);
		623
		624	$finish->(delete $state{handle}, \%hdr);
		625
		626	} elsif ($arg{on_body}) {
		627	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
		628	if ($len) {
		629	$_[0]->on_eof (undef);
		630	$_[0]->on_read (sub {
		631	$len -= length $_[0]{rbuf};
		632
		633	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		634	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
		635
		636	$len > 0
		637	or $finish->("", \%hdr);
541	};	638	});
542		639	} else {
		640	$_[0]->on_eof (sub {
543	$finish->($_[1], \%hdr);	641	$finish->("", \%hdr);
		642	});
		643	$_[0]->on_read (sub {
		644	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		645	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
		646	});
544	});	647	}
545	} else {	648	} 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);	649	$_[0]->on_eof (undef);
		650
		651	if ($len) {
		652	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
		653	$_[0]->on_read (sub {
		654	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
		655	if $len <= length $_[0]{rbuf};
		656	});
		657	} else {
		658	$_[0]->on_error (sub {
		659	$! == Errno::EPIPE
		660	? $finish->(delete $_[0]{rbuf}, \%hdr)
		661	: $finish->(undef, { Status => 599, Reason => $_[2], URL => $url });
		662	});
554	$_[0]->on_read (sub { });	663	$_[0]->on_read (sub { });
		664	}
555	}	665	}
556	}	666	}
557	});	667	});
558	});	668	});
559	};	669	};

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.42 by root, Mon Jul 6 00:08:16 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.42 by root, Mon Jul 6 00:08:16 2009 UTC