[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.41 by root, Sun Jul 5 23:50:59 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 ();
…		…
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->($hdr)
		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	=item on_body => $callback->($data, $hdr)
		206
		207	When specified, all body data will be "filtered" through this callback.
		208
		209	The callback will incrementally receive body data, and is supposed to
		210	return it or a modified version of it (empty strings are valid returns).
		211
		212	If the callback returns C<undef>, then the request will be cancelled.
		213
		214	This callback is useful when you want to do some processing on the data,
		215	or the data is too large to be held in memory (so the callback writes it
		216	to a file and returns the empty string) and so on.
		217
		218	It is usually preferred over doing your own body handling via
		219	C<want_body_handle>.
		220
		221	=item want_body_handle => $enable
		222
		223	When enabled (default is disabled), the behaviour of AnyEvent::HTTP
		224	changes considerably: after parsing the headers, and instead of
		225	downloading the body (if any), the completion callback will be
		226	called. Instead of the C<$body> argument containing the body data, the
		227	callback will receive the L<AnyEvent::Handle> object associated with the
		228	connection. In error cases, C<undef> will be passed. When there is no body
		229	(e.g. status C<304>), the empty string will be passed.
		230
		231	The handle object might or might not be in TLS mode, might be connected to
		232	a proxy, be a persistent connection etc., and configured in unspecified
		233	ways. The user is responsible for this handle (it will not be used by this
		234	module anymore).
		235
		236	This is useful with some push-type services, where, after the initial
		237	headers, an interactive protocol is used (typical example would be the
		238	push-style twitter API which starts a JSON/XML stream).
		239
		240	If you think you need this, first have a look at C<on_body>, to see if
		241	that doesn'T solve your problem in a better way.
189		242
190	=back	243	=back
191		244
192	Example: make a simple HTTP GET request for http://www.nethype.de/	245	Example: make a simple HTTP GET request for http://www.nethype.de/
193		246
…		…
252	}	305	}
253		306
254	our $qr_nl = qr<\015?\012>;	307	our $qr_nl = qr<\015?\012>;
255	our $qr_nlnl = qr<\015?\012\015?\012>;	308	our $qr_nlnl = qr<\015?\012\015?\012>;
256		309
257	our $TLS_CTX_LOW = { cache => 1, dh => undef, sslv2 => 1 };	310	our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
258	our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_cn => "https", dh => "skip4096" };	311	our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
259		312
260	sub http_request($$@) {	313	sub http_request($$@) {
261	my $cb = pop;	314	my $cb = pop;
262	my ($method, $url, %arg) = @_;	315	my ($method, $url, %arg) = @_;
263		316
…		…
280	if $recurse < 0;	333	if $recurse < 0;
281		334
282	my $proxy = $arg{proxy} \|\| $PROXY;	335	my $proxy = $arg{proxy} \|\| $PROXY;
283	my $timeout = $arg{timeout} \|\| $TIMEOUT;	336	my $timeout = $arg{timeout} \|\| $TIMEOUT;
284		337
285	$hdr{"user-agent"} \|\|= $USERAGENT;
286
287	my ($uscheme, $uauthority, $upath, $query, $fragment) =	338	my ($uscheme, $uauthority, $upath, $query, $fragment) =
288	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;	339	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;
289		340
290	$uscheme = lc $uscheme;	341	$uscheme = lc $uscheme;
291		342
292	my $uport = $uscheme eq "http" ? 80	343	my $uport = $uscheme eq "http" ? 80
293	: $uscheme eq "https" ? 443	344	: $uscheme eq "https" ? 443
294	: return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported (not '$uscheme')", URL => $url });	345	: 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		346
298	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x	347	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
299	or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });	348	or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });
300		349
301	my $uhost = $1;	350	my $uhost = $1;
…		…
347	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";	396	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
348	} else {	397	} else {
349	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);	398	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
350	}	399	}
351		400
		401	$hdr{"user-agent"} \|\|= $USERAGENT;
		402	$hdr{referer} \|\|= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic
		403
352	$hdr{host} = $uhost;	404	$hdr{host} = "$uhost:$uport";
353	$hdr{"content-length"} = length $arg{body};	405	$hdr{"content-length"} = length $arg{body};
354		406
355	my %state = (connect_guard => 1);	407	my %state = (connect_guard => 1);
356		408
357	_get_slot $uhost, sub {	409	_get_slot $uhost, sub {
…		…
444	}	496	}
445		497
446	substr $_, 0, 1, ""	498	substr $_, 0, 1, ""
447	for values %hdr;	499	for values %hdr;
448		500
		501	# redirect handling
		502	# microsoft and other shitheads don't give a shit for following standards,
		503	# try to support some common forms of broken Location headers.
		504	if ($hdr{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
		505	$hdr{location} =~ s/^\.\/+//;
		506
		507	my $url = "$rscheme://$uhost:$uport";
		508
		509	unless ($hdr{location} =~ s/^\///) {
		510	$url .= $upath;
		511	$url =~ s/\/[^\/]*$//;
		512	}
		513
		514	$hdr{location} = "$url/$hdr{location}";
		515	}
		516
		517	my $redirect;
		518
		519	if ($recurse) {
		520	if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") {
		521	# apparently, mozilla et al. just change POST to GET here
		522	# more research is needed before we do the same
		523	$redirect = 1;
		524	} elsif ($hdr{Status} == 303) {
		525	# even http/1.1 is unclear on how to mutate the method
		526	$method = "GET" unless $method eq "HEAD";
		527	$redirect = 1;
		528	} elsif ($hdr{Status} == 307 && $method =~ /^(?:GET\|HEAD)$/) {
		529	$redirect = 1;
		530	}
		531	}
		532
449	my $finish = sub {	533	my $finish = sub {
450	$state{handle}->destroy;	534	$state{handle}->destroy if $state{handle};
451	%state = ();	535	%state = ();
452		536
453	# set-cookie processing	537	# set-cookie processing
454	if ($arg{cookie_jar}) {	538	if ($arg{cookie_jar}) {
455	for ($hdr{"set-cookie"}) {	539	for ($_[1]{"set-cookie"}) {
456	# parse NAME=VALUE	540	# parse NAME=VALUE
457	my @kv;	541	my @kv;
458		542
459	while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {	543	while (/\G\s* ([^=;,[:space:]]+) \s=\s (?: "((?:[^\\"]+\|\\.))" \| ([^=;,[:space:]]) )/gcxs) {
460	my $name = $1;	544	my $name = $1;
…		…
498		582
499	redo if /\G\s*,/gc;	583	redo if /\G\s*,/gc;
500	}	584	}
501	}	585	}
502		586
503	# microsoft and other shitheads don't give a shit for following standards,	587	if ($redirect) {
504	# try to support some common forms of broken Location headers.	588	# we ignore any errors, as it is very common to receive
505	if ($_[1]{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {	589	# Content-Length != 0 but no actual body
506	$_[1]{location} =~ s/^\.\/+//;	590	# 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);	591	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 {	592	} else {
529	$cb->($_[0], $_[1]);	593	$cb->($_[0], $_[1]);
530	}	594	}
531	};	595	};
532		596
		597	my $len = $hdr{"content-length"};
		598
		599	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
		600	$finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });
		601	} elsif (
533	if ($hdr{Status} =~ /^(?:1..\|204\|304)$/ or $method eq "HEAD") {	602	$hdr{Status} =~ /^(?:1..\|204\|304)$/
		603	or $method eq "HEAD"
		604	or (defined $len && !$len)
		605	) {
		606	# no body
534	$finish->(undef, \%hdr);	607	$finish->("", \%hdr);
535	} else {	608	} else {
536	if (exists $hdr{"content-length"}) {	609	# body handling, four different code paths
537	$_[0]->unshift_read (chunk => $hdr{"content-length"}, sub {	610	# for want_body_handle, on_body (2x), normal (2x)
538	# could cache persistent connection now	611	# we might read too much here, but it does not matter yet (no pers. connections)
539	if ($hdr{connection} =~ /\bkeep-alive\b/i) {	612	if (!$redirect && $arg{want_body_handle}) {
540	# but we don't, due to misdesigns, this is annoyingly complex	613	$_[0]->on_eof (undef);
		614	$_[0]->on_error (undef);
		615	$_[0]->on_read (undef);
		616
		617	$finish->(delete $state{handle}, \%hdr);
		618
		619	} elsif ($arg{on_body}) {
		620	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
		621	if ($len) {
		622	$_[0]->on_eof (undef);
		623	$_[0]->on_read (sub {
		624	$len -= length $_[0]{rbuf};
		625
		626	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		627	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
		628
		629	$len > 0
		630	or $finish->("", \%hdr);
541	};	631	});
542		632	} else {
		633	$_[0]->on_eof (sub {
543	$finish->($_[1], \%hdr);	634	$finish->("", \%hdr);
		635	});
		636	$_[0]->on_read (sub {
		637	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
		638	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });
		639	});
544	});	640	}
545	} else {	641	} 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);	642	$_[0]->on_eof (undef);
		643
		644	if ($len) {
		645	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });
		646	$_[0]->on_read (sub {
		647	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
		648	if $len <= length $_[0]{rbuf};
		649	});
		650	} else {
		651	$_[0]->on_error (sub {
		652	$! == Errno::EPIPE
		653	? $finish->(delete $_[0]{rbuf}, \%hdr)
		654	: $finish->(undef, { Status => 599, Reason => $_[2], URL => $url });
		655	});
554	$_[0]->on_read (sub { });	656	$_[0]->on_read (sub { });
		657	}
555	}	658	}
556	}	659	}
557	});	660	});
558	});	661	});
559	};	662	};

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.41 by root, Sun Jul 5 23:50:59 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.41 by root, Sun Jul 5 23:50:59 2009 UTC