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

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.44 by root, Tue Jul 7 00:15:32 2009 UTC vs.
Revision 1.61 by root, Thu Dec 30 03:45:01 2010 UTC

…		…
41	use strict;	41	use strict;
42	no warnings;	42	no warnings;
43		43
44	use Errno ();	44	use Errno ();
45		45
46	use AnyEvent 4.8 ();	46	use AnyEvent 5.0 ();
47	use AnyEvent::Util ();	47	use AnyEvent::Util ();
48	use AnyEvent::Socket ();
49	use AnyEvent::Handle ();	48	use AnyEvent::Handle ();
50		49
51	use base Exporter::;	50	use base Exporter::;
52		51
53	our $VERSION = '1.4';	52	our $VERSION = '1.46';
54		53
55	our @EXPORT = qw(http_get http_post http_head http_request);	54	our @EXPORT = qw(http_get http_post http_head http_request);
56		55
57	our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";	56	our $USERAGENT = "Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)";
58	our $MAX_RECURSE = 10;	57	our $MAX_RECURSE = 10;
…		…
92	must be an absolute http or https URL.	91	must be an absolute http or https URL.
93		92
94	When called in void context, nothing is returned. In other contexts,	93	When called in void context, nothing is returned. In other contexts,
95	C<http_request> returns a "cancellation guard" - you have to keep the	94	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	95	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.	96	destroyed before the callback is called, the request will be cancelled.
98		97
99	The callback will be called with the response body data as first argument	98	The callback will be called with the response body data as first argument
100	(or C<undef> if an error occured), and a hash-ref with response headers as	99	(or C<undef> if an error occured), and a hash-ref with response headers as
101	second argument.	100	second argument.
102		101
103	All the headers in that hash are lowercased. In addition to the response	102	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>	103	headers, the "pseudo-headers" (uppercase to avoid clashing with possible
		104	response headers) C<HTTPVersion>, C<Status> and C<Reason> contain the
105	contain the three parts of the HTTP Status-Line of the same name. The	105	three parts of the HTTP Status-Line of the same name.
		106
106	pseudo-header C<URL> contains the original URL (which can differ from the	107	The pseudo-header C<URL> contains the actual URL (which can differ from
107	requested URL when following redirects).	108	the requested URL when following redirects - for example, you might get
		109	an error that your URL scheme is not supported even though your URL is a
		110	valid http URL because it redirected to an ftp URL, in which case you can
		111	look at the URL pseudo header).
		112
		113	The pseudo-header C<Redirect> only exists when the request was a result
		114	of an internal redirect. In that case it is an array reference with
		115	the C<($data, $headers)> from the redirect response. Note that this
		116	response could in turn be the result of a redirect itself, and C<<
		117	$headers->{Redirect}[1]{Redirect} >> will then contain the original
		118	response, and so on.
108		119
109	If the server sends a header multiple times, then their contents will be	120	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.	121	joined together with a comma (C<,>), as per the HTTP spec.
111		122
112	If an internal error occurs, such as not being able to resolve a hostname,	123	If an internal error occurs, such as not being able to resolve a hostname,
…		…
138		149
139	=item headers => hashref	150	=item headers => hashref
140		151
141	The request headers to use. Currently, C<http_request> may provide its	152	The request headers to use. Currently, C<http_request> may provide its
142	own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers	153	own C<Host:>, C<Content-Length:>, C<Connection:> and C<Cookie:> headers
143	and will provide defaults for C<User-Agent:> and C<Referer:>.	154	and will provide defaults for C<User-Agent:> and C<Referer:> (this can be
		155	suppressed by using C<undef> for these headers in which case they won't be
		156	sent at all).
144		157
145	=item timeout => $seconds	158	=item timeout => $seconds
146		159
147	The time-out to use for various stages - each connect attempt will reset	160	The time-out to use for various stages - each connect attempt will reset
148	the timeout, as will read or write activity. Default timeout is 5 minutes.	161	the timeout, as will read or write activity, i.e. this is not an overall
		162	timeout.
		163
		164	Default timeout is 5 minutes.
149		165
150	=item proxy => [$host, $port[, $scheme]] or undef	166	=item proxy => [$host, $port[, $scheme]] or undef
151		167
152	Use the given http proxy for all requests. If not specified, then the	168	Use the given http proxy for all requests. If not specified, then the
153	default proxy (as specified by C<$ENV{http_proxy}>) is used.	169	default proxy (as specified by C<$ENV{http_proxy}>) is used.
154		170
155	C<$scheme> must be either missing or C<http> for HTTP, or C<https> for	171	C<$scheme> must be either missing, C<http> for HTTP or C<https> for
156	HTTPS.	172	HTTPS.
157		173
158	=item body => $string	174	=item body => $string
159		175
160	The request body, usually empty. Will be-sent as-is (future versions of	176	The request body, usually empty. Will be-sent as-is (future versions of
…		…
186	verification) TLS context.	202	verification) TLS context.
187		203
188	The default for this option is C<low>, which could be interpreted as "give	204	The default for this option is C<low>, which could be interpreted as "give
189	me the page, no matter what".	205	me the page, no matter what".
190		206
		207	=item on_prepare => $callback->($fh)
		208
		209	In rare cases you need to "tune" the socket before it is used to
		210	connect (for exmaple, to bind it on a given IP address). This parameter
		211	overrides the prepare callback passed to C<AnyEvent::Socket::tcp_connect>
		212	and behaves exactly the same way (e.g. it has to provide a
		213	timeout). See the description for the C<$prepare_cb> argument of
		214	C<AnyEvent::Socket::tcp_connect> for details.
		215
		216	=item tcp_connect => $callback->($host, $service, $connect_cb, $prepare_cb)
		217
		218	In even rarer cases you want total control over how AnyEvent::HTTP
		219	establishes connections. Normally it uses L<AnyEvent::Socket::tcp_connect>
		220	to do this, but you can provide your own C<tcp_connect> function -
		221	obviously, it has to follow the same calling conventions, except that it
		222	may always return a connection guard object.
		223
		224	There are probably lots of weird uses for this function, starting from
		225	tracing the hosts C<http_request> actually tries to connect, to (inexact
		226	but fast) host => IP address caching or even socks protocol support.
		227
191	=item on_header => $callback->($headers)	228	=item on_header => $callback->($headers)
192		229
193	When specified, this callback will be called with the header hash as soon	230	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	231	as headers have been successfully received from the remote server (not on
195	locally-generated errors).	232	locally-generated errors).
…		…
221	This callback is useful when the data is too large to be held in memory	258	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	259	(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.	260	be extracted, or when the body should be processed incrementally.
224		261
225	It is usually preferred over doing your own body handling via	262	It is usually preferred over doing your own body handling via
226	C<want_body_handle>.	263	C<want_body_handle>, but in case of streaming APIs, where HTTP is
		264	only used to create a connection, C<want_body_handle> is the better
		265	alternative, as it allows you to install your own event handler, reducing
		266	resource usage.
227		267
228	=item want_body_handle => $enable	268	=item want_body_handle => $enable
229		269
230	When enabled (default is disabled), the behaviour of AnyEvent::HTTP	270	When enabled (default is disabled), the behaviour of AnyEvent::HTTP
231	changes considerably: after parsing the headers, and instead of	271	changes considerably: after parsing the headers, and instead of
…		…
243	This is useful with some push-type services, where, after the initial	283	This is useful with some push-type services, where, after the initial
244	headers, an interactive protocol is used (typical example would be the	284	headers, an interactive protocol is used (typical example would be the
245	push-style twitter API which starts a JSON/XML stream).	285	push-style twitter API which starts a JSON/XML stream).
246		286
247	If you think you need this, first have a look at C<on_body>, to see if	287	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.	288	that doesn't solve your problem in a better way.
249		289
250	=back	290	=back
251		291
252	Example: make a simple HTTP GET request for http://www.nethype.de/	292	Example: make a simple HTTP GET request for http://www.nethype.de/
253		293
…		…
309	push @{ $CO_SLOT{$_[0]}[1] }, $_[1];	349	push @{ $CO_SLOT{$_[0]}[1] }, $_[1];
310		350
311	_slot_schedule $_[0];	351	_slot_schedule $_[0];
312	}	352	}
313		353
314	our $qr_nl = qr<\015?\012>;	354	our $qr_nlnl = qr{(?<![^\012])\015?\012};
315	our $qr_nlnl = qr<\015?\012\015?\012>;
316		355
317	our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };	356	our $TLS_CTX_LOW = { cache => 1, sslv2 => 1 };
318	our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };	357	our $TLS_CTX_HIGH = { cache => 1, verify => 1, verify_peername => "https" };
319		358
320	sub http_request($$@) {	359	sub http_request($$@) {
…		…
332	while (my ($k, $v) = each %$hdr) {	371	while (my ($k, $v) = each %$hdr) {
333	$hdr{lc $k} = $v;	372	$hdr{lc $k} = $v;
334	}	373	}
335	}	374	}
336		375
		376	# pseudo headers for all subsequent responses
		377	my @pseudo = (URL => $url);
		378	push @pseudo, Redirect => delete $arg{Redirect} if exists $arg{Redirect};
		379
337	my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;	380	my $recurse = exists $arg{recurse} ? delete $arg{recurse} : $MAX_RECURSE;
338		381
339	return $cb->(undef, { Status => 599, Reason => "Too many redirections", URL => $url })	382	return $cb->(undef, { Status => 599, Reason => "Too many redirections", @pseudo })
340	if $recurse < 0;	383	if $recurse < 0;
341		384
342	my $proxy = $arg{proxy} \|\| $PROXY;	385	my $proxy = $arg{proxy} \|\| $PROXY;
343	my $timeout = $arg{timeout} \|\| $TIMEOUT;	386	my $timeout = $arg{timeout} \|\| $TIMEOUT;
344		387
345	my ($uscheme, $uauthority, $upath, $query, $fragment) =	388	my ($uscheme, $uauthority, $upath, $query, $fragment) =
346	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:\?([^#]))?(?:#(.))?\|;	389	$url =~ m\|(?:([^:/?#]+):)?(?://([^/?#]))?([^?#])(?:(\?[^#]))?(?:#(.))?\|;
347		390
348	$uscheme = lc $uscheme;	391	$uscheme = lc $uscheme;
349		392
350	my $uport = $uscheme eq "http" ? 80	393	my $uport = $uscheme eq "http" ? 80
351	: $uscheme eq "https" ? 443	394	: $uscheme eq "https" ? 443
352	: return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", URL => $url });	395	: return $cb->(undef, { Status => 599, Reason => "Only http and https URL schemes supported", @pseudo });
353		396
354	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x	397	$uauthority =~ /^(?: .*\@ )? ([^\@:]+) (?: : (\d+) )?$/x
355	or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", URL => $url });	398	or return $cb->(undef, { Status => 599, Reason => "Unparsable URL", @pseudo });
356		399
357	my $uhost = $1;	400	my $uhost = $1;
358	$uport = $2 if defined $2;	401	$uport = $2 if defined $2;
359		402
360	$hdr{host} = defined $2 ? "$uhost:$2" : "$uhost";	403	$hdr{host} = defined $2 ? "$uhost:$2" : "$uhost"
		404	unless exists $hdr{host};
361		405
362	$uhost =~ s/^\[(.*)\]$/$1/;	406	$uhost =~ s/^\[(.*)\]$/$1/;
363	$upath .= "?$query" if length $query;	407	$upath .= $query if length $query;
364		408
365	$upath =~ s%^/?%/%;	409	$upath =~ s%^/?%/%;
366		410
367	# cookie processing	411	# cookie processing
368	if (my $jar = $arg{cookie_jar}) {	412	if (my $jar = $arg{cookie_jar}) {
…		…
398	my ($rhost, $rport, $rscheme, $rpath); # request host, port, path	442	my ($rhost, $rport, $rscheme, $rpath); # request host, port, path
399		443
400	if ($proxy) {	444	if ($proxy) {
401	($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);	445	($rpath, $rhost, $rport, $rscheme) = ($url, @$proxy);
402		446
		447	$rscheme = "http" unless defined $rscheme;
		448
403	# don't support https requests over https-proxy transport,	449	# don't support https requests over https-proxy transport,
404	# can't be done with tls as spec'ed, unless you double-encrypt.	450	# can't be done with tls as spec'ed, unless you double-encrypt.
405	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";	451	$rscheme = "http" if $uscheme eq "https" && $rscheme eq "https";
406	} else {	452	} else {
407	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);	453	($rhost, $rport, $rscheme, $rpath) = ($uhost, $uport, $uscheme, $upath);
408	}	454	}
409		455
410	$hdr{"user-agent"} \|\|= $USERAGENT;	456	# leave out fragment and query string, just a heuristic
411	$hdr{referer} \|\|= "$uscheme://$uauthority$upath"; # leave out fragment and query string, just a heuristic	457	$hdr{referer} \|\|= "$uscheme://$uauthority$upath" unless exists $hdr{referer};
		458	$hdr{"user-agent"} \|\|= $USERAGENT unless exists $hdr{"user-agent"};
412		459
413	$hdr{"content-length"} = length $arg{body};	460	$hdr{"content-length"} = length $arg{body}
		461	if length $arg{body} \|\| $method ne "GET";
414		462
415	my %state = (connect_guard => 1);	463	my %state = (connect_guard => 1);
416		464
417	_get_slot $uhost, sub {	465	_get_slot $uhost, sub {
418	$state{slot_guard} = shift;	466	$state{slot_guard} = shift;
419		467
420	return unless $state{connect_guard};	468	return unless $state{connect_guard};
421		469
422	$state{connect_guard} = AnyEvent::Socket::tcp_connect $rhost, $rport, sub {	470	my $tcp_connect = $arg{tcp_connect}
		471	\|\| do { require AnyEvent::Socket; \&AnyEvent::Socket::tcp_connect };
		472
		473	$state{connect_guard} = $tcp_connect->(
		474	$rhost,
		475	$rport,
		476	sub {
423	$state{fh} = shift	477	$state{fh} = shift
424	or do {	478	or do {
425	my $err = "$!";	479	my $err = "$!";
426	%state = ();	480	%state = ();
427	return $cb->(undef, { Status => 599, Reason => $err, URL => $url });	481	return $cb->(undef, { Status => 599, Reason => $err, @pseudo });
428	};	482	};
429		483
430	pop; # free memory, save a tree	484	pop; # free memory, save a tree
431		485
432	return unless delete $state{connect_guard};	486	return unless delete $state{connect_guard};
433		487
434	# get handle	488	# get handle
435	$state{handle} = new AnyEvent::Handle	489	$state{handle} = new AnyEvent::Handle
436	fh => $state{fh},	490	fh => $state{fh},
		491	peername => $rhost,
		492	tls_ctx => $arg{tls_ctx},
		493	# these need to be reconfigured on keepalive handles
437	timeout => $timeout,	494	timeout => $timeout,
438	peername => $rhost,	495	on_error => sub {
439	tls_ctx => $arg{tls_ctx};	496	%state = ();
		497	$cb->(undef, { Status => 599, Reason => $_[2], @pseudo });
		498	},
		499	on_eof => sub {
		500	%state = ();
		501	$cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", @pseudo });
		502	},
		503	;
440		504
441	# limit the number of persistent connections	505	# limit the number of persistent connections
442	# keepalive not yet supported	506	# keepalive not yet supported
443	if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {	507	# if ($KA_COUNT{$_[1]} < $MAX_PERSISTENT_PER_HOST) {
444	++$KA_COUNT{$_[1]};	508	# ++$KA_COUNT{$_[1]};
445	$state{handle}{ka_count_guard} = AnyEvent::Util::guard {	509	# $state{handle}{ka_count_guard} = AnyEvent::Util::guard {
446	--$KA_COUNT{$_[1]}	510	# --$KA_COUNT{$_[1]}
447	};	511	# };
448	$hdr{connection} = "keep-alive";	512	# $hdr{connection} = "keep-alive";
449	} else {	513	# } else {
450	delete $hdr{connection};	514	delete $hdr{connection};
451	}	515	# }
452		516
453	# (re-)configure handle
454	$state{handle}->on_error (sub {
455	%state = ();
456	$cb->(undef, { Status => 599, Reason => $_[2], URL => $url });
457	});
458	$state{handle}->on_eof (sub {
459	%state = ();
460	$cb->(undef, { Status => 599, Reason => "Unexpected end-of-file", URL => $url });
461	});
462
463	$state{handle}->starttls ("connect") if $rscheme eq "https";	517	$state{handle}->starttls ("connect") if $rscheme eq "https";
464		518
465	# handle actual, non-tunneled, request	519	# handle actual, non-tunneled, request
466	my $handle_actual_request = sub {	520	my $handle_actual_request = sub {
467	$state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};	521	$state{handle}->starttls ("connect") if $uscheme eq "https" && !exists $state{handle}{tls};
468		522
469	# send request	523	# send request
470	$state{handle}->push_write (	524	$state{handle}->push_write (
471	"$method $rpath HTTP/1.0\015\012"	525	"$method $rpath HTTP/1.0\015\012"
472	. (join "", map "\u$_: $hdr{$_}\015\012", keys %hdr)	526	. (join "", map "\u$_: $hdr{$_}\015\012", grep defined $hdr{$_}, keys %hdr)
473	. "\015\012"	527	. "\015\012"
474	. (delete $arg{body})	528	. (delete $arg{body})
475	);
476
477	%hdr = (); # reduce memory usage, save a kitten
478
479	# status line
480	$state{handle}->push_read (line => $qr_nl, sub {
481	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
482	or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response ($_[1])", URL => $url }));
483
484	my %hdr = ( # response headers
485	HTTPVersion => ",$1",
486	Status => ",$2",
487	Reason => ",$3",
488	URL => ",$url"
489	);	529	);
490		530
491	# headers, could be optimized a bit	531	# return if error occured during push_write()
		532	return unless %state;
		533
		534	%hdr = (); # reduce memory usage, save a kitten, also make it possible to re-use
		535
		536	# status line and headers
492	$state{handle}->unshift_read (line => $qr_nlnl, sub {	537	$state{handle}->push_read (line => $qr_nlnl, sub {
493	for ("$_[1]\012") {	538	for ("$_[1]") {
494	y/\015//d; # weed out any \015, as they show up in the weirdest of places.	539	y/\015//d; # weed out any \015, as they show up in the weirdest of places.
		540
		541	/^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )? \015?\012/igxc
		542	or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid server response", @pseudo }));
		543
		544	push @pseudo,
		545	HTTPVersion => $1,
		546	Status => $2,
		547	Reason => $3,
		548	;
495		549
496	# things seen, not parsed:	550	# things seen, not parsed:
497	# p3pP="NON CUR OTPi OUR NOR UNI"	551	# p3pP="NON CUR OTPi OUR NOR UNI"
498		552
499	$hdr{lc $1} .= ",$2"	553	$hdr{lc $1} .= ",$2"
…		…
503	((?: [^\012]+ \| \012[\011\040] )*)	557	((?: [^\012]+ \| \012[\011\040] )*)
504	\012	558	\012
505	/gxc;	559	/gxc;
506		560
507	/\G$/	561	/\G$/
508	or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", URL => $url }));	562	or return (%state = (), $cb->(undef, { Status => 599, Reason => "Garbled response headers", @pseudo }));
509	}	563	}
510		564
		565	# remove the "," prefix we added to all headers above
511	substr $_, 0, 1, ""	566	substr $_, 0, 1, ""
512	for values %hdr;	567	for values %hdr;
		568
		569	# patch in all pseudo headers
		570	%hdr = (%hdr, @pseudo);
513		571
514	# redirect handling	572	# redirect handling
515	# microsoft and other shitheads don't give a shit for following standards,	573	# microsoft and other shitheads don't give a shit for following standards,
516	# try to support some common forms of broken Location headers.	574	# try to support some common forms of broken Location headers.
517	if ($hdr{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {	575	if ($hdr{location} !~ /^(?: $ \| [^:\/?\#]+ : )/x) {
…		…
528	}	586	}
529		587
530	my $redirect;	588	my $redirect;
531		589
532	if ($recurse) {	590	if ($recurse) {
533	if ($hdr{Status} =~ /^30[12]$/ && $method ne "POST") {	591	my $status = $hdr{Status};
534	# apparently, mozilla et al. just change POST to GET here	592
535	# more research is needed before we do the same	593	# industry standard is to redirect POST as GET for
536	$redirect = 1;	594	# 301, 302 and 303, in contrast to http/1.0 and 1.1.
537	} elsif ($hdr{Status} == 303) {	595	# also, the UA should ask the user for 301 and 307 and POST,
		596	# industry standard seems to be to simply follow.
		597	# we go with the industry standard.
		598	if ($status == 301 or $status == 302 or $status == 303) {
538	# even http/1.1 is unclear on how to mutate the method	599	# HTTP/1.1 is unclear on how to mutate the method
539	$method = "GET" unless $method eq "HEAD";	600	$method = "GET" unless $method eq "HEAD";
540	$redirect = 1;	601	$redirect = 1;
541	} elsif ($hdr{Status} == 307 && $method =~ /^(?:GET\|HEAD)$/) {	602	} elsif ($status == 307) {
542	$redirect = 1;	603	$redirect = 1;
543	}	604	}
544	}	605	}
545		606
546	my $finish = sub {	607	my $finish = sub {
…		…
595		656
596	redo if /\G\s*,/gc;	657	redo if /\G\s*,/gc;
597	}	658	}
598	}	659	}
599		660
600	if ($redirect) {	661	if ($redirect && exists $hdr{location}) {
601	# we ignore any errors, as it is very common to receive	662	# we ignore any errors, as it is very common to receive
602	# Content-Length != 0 but no actual body	663	# Content-Length != 0 but no actual body
603	# we also access %hdr, as $_[1] might be an erro	664	# we also access %hdr, as $_[1] might be an erro
604	http_request ($method => $hdr{location}, %arg, recurse => $recurse - 1, $cb);	665	http_request (
		666	$method => $hdr{location},
		667	%arg,
		668	recurse => $recurse - 1,
		669	Redirect => \@_,
		670	$cb);
605	} else {	671	} else {
606	$cb->($_[0], $_[1]);	672	$cb->($_[0], $_[1]);
607	}	673	}
608	};	674	};
609		675
610	my $len = $hdr{"content-length"};	676	my $len = $hdr{"content-length"};
611		677
612	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {	678	if (!$redirect && $arg{on_header} && !$arg{on_header}(\%hdr)) {
613	$finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", URL => $url });	679	$finish->(undef, { Status => 598, Reason => "Request cancelled by on_header", @pseudo });
614	} elsif (	680	} elsif (
615	$hdr{Status} =~ /^(?:1..\|[23]04)$/	681	$hdr{Status} =~ /^(?:1..\|[23]04)$/
616	or $method eq "HEAD"	682	or $method eq "HEAD"
617	or (defined $len && !$len)	683	or (defined $len && !$len)
618	) {	684	) {
…		…
621	} else {	687	} else {
622	# body handling, four different code paths	688	# body handling, four different code paths
623	# for want_body_handle, on_body (2x), normal (2x)	689	# for want_body_handle, on_body (2x), normal (2x)
624	# we might read too much here, but it does not matter yet (no pers. connections)	690	# we might read too much here, but it does not matter yet (no pers. connections)
625	if (!$redirect && $arg{want_body_handle}) {	691	if (!$redirect && $arg{want_body_handle}) {
626	$_[0]->on_eof (undef);	692	$_[0]->on_eof (undef);
627	$_[0]->on_error (undef);	693	$_[0]->on_error (undef);
628	$_[0]->on_read (undef);	694	$_[0]->on_read (undef);
629		695
630	$finish->(delete $state{handle}, \%hdr);	696	$finish->(delete $state{handle}, \%hdr);
631		697
632	} elsif ($arg{on_body}) {	698	} elsif ($arg{on_body}) {
633	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });	699	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
634	if ($len) {	700	if ($len) {
635	$_[0]->on_eof (undef);	701	$_[0]->on_eof (undef);
636	$_[0]->on_read (sub {	702	$_[0]->on_read (sub {
637	$len -= length $_[0]{rbuf};	703	$len -= length $_[0]{rbuf};
638		704
639	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)	705	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
640	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });	706	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
641		707
642	$len > 0	708	$len > 0
643	or $finish->("", \%hdr);	709	or $finish->("", \%hdr);
644	});	710	});
645	} else {	711	} else {
646	$_[0]->on_eof (sub {	712	$_[0]->on_eof (sub {
647	$finish->("", \%hdr);	713	$finish->("", \%hdr);
648	});	714	});
649	$_[0]->on_read (sub {	715	$_[0]->on_read (sub {
650	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)	716	$arg{on_body}(delete $_[0]{rbuf}, \%hdr)
651	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", URL => $url });	717	or $finish->(undef, { Status => 598, Reason => "Request cancelled by on_body", @pseudo });
652	});	718	});
653	}	719	}
654	} else {	720	} else {
655	$_[0]->on_eof (undef);	721	$_[0]->on_eof (undef);
656		722
657	if ($len) {	723	if ($len) {
658	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], URL => $url }) });	724	$_[0]->on_error (sub { $finish->(undef, { Status => 599, Reason => $_[2], @pseudo }) });
659	$_[0]->on_read (sub {	725	$_[0]->on_read (sub {
660	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)	726	$finish->((substr delete $_[0]{rbuf}, 0, $len, ""), \%hdr)
661	if $len <= length $_[0]{rbuf};	727	if $len <= length $_[0]{rbuf};
662	});	728	});
663	} else {	729	} else {
664	$_[0]->on_error (sub {	730	$_[0]->on_error (sub {
665	$! == Errno::EPIPE \|\| !$!	731	($! == Errno::EPIPE \|\| !$!)
666	? $finish->(delete $_[0]{rbuf}, \%hdr)	732	? $finish->(delete $_[0]{rbuf}, \%hdr)
667	: $finish->(undef, { Status => 599, Reason => $_[2], URL => $url });	733	: $finish->(undef, { Status => 599, Reason => $_[2], @pseudo });
668	});	734	});
669	$_[0]->on_read (sub { });	735	$_[0]->on_read (sub { });
670	}	736	}
671	}	737	}
672	}	738	}
673	});	739	});
674	});	740	};
675	};
676		741
677	# now handle proxy-CONNECT method	742	# now handle proxy-CONNECT method
678	if ($proxy && $uscheme eq "https") {	743	if ($proxy && $uscheme eq "https") {
679	# oh dear, we have to wrap it into a connect request	744	# oh dear, we have to wrap it into a connect request
680		745
681	# maybe re-use $uauthority with patched port?	746	# maybe re-use $uauthority with patched port?
682	$state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");	747	$state{handle}->push_write ("CONNECT $uhost:$uport HTTP/1.0\015\012Host: $uhost\015\012\015\012");
683	$state{handle}->push_read (line => $qr_nlnl, sub {	748	$state{handle}->push_read (line => $qr_nlnl, sub {
684	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix	749	$_[1] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ix
685	or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", URL => $url }));	750	or return (%state = (), $cb->(undef, { Status => 599, Reason => "Invalid proxy connect response ($_[1])", @pseudo }));
686		751
687	if ($2 == 200) {	752	if ($2 == 200) {
688	$rpath = $upath;	753	$rpath = $upath;
689	&$handle_actual_request;	754	&$handle_actual_request;
690	} else {	755	} else {
691	%state = ();	756	%state = ();
692	$cb->(undef, { Status => $2, Reason => $3, URL => $url });	757	$cb->(undef, { Status => $2, Reason => $3, @pseudo });
		758	}
693	}	759	});
694	});
695	} else {	760	} else {
696	&$handle_actual_request;	761	&$handle_actual_request;
		762	}
		763
697	}	764	},
698		765	$arg{on_prepare} \|\| sub { $timeout }
699	}, sub {
700	$timeout
701	};	766	);
702	};	767	};
703		768
704	defined wantarray && AnyEvent::Util::guard { %state = () }	769	defined wantarray && AnyEvent::Util::guard { %state = () }
705	}	770	}
706		771
…		…
720	&http_request	785	&http_request
721	}	786	}
722		787
723	=back	788	=back
724		789
		790	=head2 DNS CACHING
		791
		792	AnyEvent::HTTP uses the AnyEvent::Socket::tcp_connect function for
		793	the actual connection, which in turn uses AnyEvent::DNS to resolve
		794	hostnames. The latter is a simple stub resolver and does no caching
		795	on its own. If you want DNS caching, you currently have to provide
		796	your own default resolver (by storing a suitable resolver object in
		797	C<$AnyEvent::DNS::RESOLVER>).
		798
725	=head2 GLOBAL FUNCTIONS AND VARIABLES	799	=head2 GLOBAL FUNCTIONS AND VARIABLES
726		800
727	=over 4	801	=over 4
728		802
729	=item AnyEvent::HTTP::set_proxy "proxy-url"	803	=item AnyEvent::HTTP::set_proxy "proxy-url"
730		804
731	Sets the default proxy server to use. The proxy-url must begin with a	805	Sets the default proxy server to use. The proxy-url must begin with a
732	string of the form C<http://host:port> (optionally C<https:...>).	806	string of the form C<http://host:port> (optionally C<https:...>), croaks
		807	otherwise.
		808
		809	To clear an already-set proxy, use C<undef>.
		810
		811	=item $date = AnyEvent::HTTP::format_date $timestamp
		812
		813	Takes a POSIX timestamp (seconds since the epoch) and formats it as a HTTP
		814	Date (RFC 2616).
		815
		816	=item $timestamp = AnyEvent::HTTP::parse_date $date
		817
		818	Takes a HTTP Date (RFC 2616) and returns the corresponding POSIX
		819	timestamp, or C<undef> if the date cannot be parsed.
733		820
734	=item $AnyEvent::HTTP::MAX_RECURSE	821	=item $AnyEvent::HTTP::MAX_RECURSE
735		822
736	The default value for the C<recurse> request parameter (default: C<10>).	823	The default value for the C<recurse> request parameter (default: C<10>).
737		824
…		…
740	The default value for the C<User-Agent> header (the default is	827	The default value for the C<User-Agent> header (the default is
741	C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).	828	C<Mozilla/5.0 (compatible; U; AnyEvent-HTTP/$VERSION; +http://software.schmorp.de/pkg/AnyEvent)>).
742		829
743	=item $AnyEvent::HTTP::MAX_PER_HOST	830	=item $AnyEvent::HTTP::MAX_PER_HOST
744		831
745	The maximum number of concurrent conenctions to the same host (identified	832	The maximum number of concurrent connections to the same host (identified
746	by the hostname). If the limit is exceeded, then the additional requests	833	by the hostname). If the limit is exceeded, then the additional requests
747	are queued until previous connections are closed.	834	are queued until previous connections are closed.
748		835
749	The default value for this is C<4>, and it is highly advisable to not	836	The default value for this is C<4>, and it is highly advisable to not
750	increase it.	837	increase it.
…		…
757		844
758	=back	845	=back
759		846
760	=cut	847	=cut
761		848
		849	our @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
		850	our @weekday = qw(Sun Mon Tue Wed Thu Fri Sat);
		851
		852	sub format_date($) {
		853	my ($time) = @_;
		854
		855	# RFC 822/1123 format
		856	my ($S, $M, $H, $mday, $mon, $year, $wday, $yday, undef) = gmtime $time;
		857
		858	sprintf "%s, %02d %s %04d %02d:%02d:%02d GMT",
		859	$weekday[$wday], $mday, $month[$mon], $year + 1900,
		860	$H, $M, $S;
		861	}
		862
		863	sub parse_date($) {
		864	my ($date) = @_;
		865
		866	my ($d, $m, $y, $H, $M, $S);
		867
		868	if ($date =~ /^[A-Z][a-z][a-z], ([0-9][0-9]) ([A-Z][a-z][a-z]) ([0-9][0-9][0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
		869	# RFC 822/1123, required by RFC 2616
		870	($d, $m, $y, $H, $M, $S) = ($1, $2, $3, $4, $5, $6);
		871
		872	} elsif ($date =~ /^[A-Z][a-z]+, ([0-9][0-9])-([A-Z][a-z][a-z])-([0-9][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) GMT$/) {
		873	# RFC 850
		874	($d, $m, $y, $H, $M, $S) = ($1, $2, $3 < 69 ? $3 + 2000 : $3 + 1900, $4, $5, $6);
		875
		876	} elsif ($date =~ /^[A-Z][a-z][a-z] ([A-Z][a-z][a-z]) ([0-9 ][0-9]) ([0-9][0-9]):([0-9][0-9]):([0-9][0-9]) ([0-9][0-9][0-9][0-9])$/) {
		877	# ISO C's asctime
		878	($d, $m, $y, $H, $M, $S) = ($2, $1, $6, $3, $4, $5);
		879	}
		880	# other formats fail in the loop below
		881
		882	for (0..11) {
		883	if ($m eq $month[$_]) {
		884	require Time::Local;
		885	return Time::Local::timegm ($S, $M, $H, $d, $_, $y);
		886	}
		887	}
		888
		889	undef
		890	}
		891
762	sub set_proxy($) {	892	sub set_proxy($) {
		893	if (length $_[0]) {
763	$PROXY = [$2, $3 \|\| 3128, $1] if $_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix;	894	$_[0] =~ m%^(https?):// ([^:/]+) (?: : (\d*) )?%ix
		895	or Carp::croak "$_[0]: invalid proxy URL";
		896	$PROXY = [$2, $3 \|\| 3128, $1]
		897	} else {
		898	undef $PROXY;
		899	}
764	}	900	}
765		901
766	# initialise proxy from environment	902	# initialise proxy from environment
		903	eval {
767	set_proxy $ENV{http_proxy};	904	set_proxy $ENV{http_proxy};
		905	};
		906
		907	=head2 SOCKS PROXIES
		908
		909	Socks proxies are not directly supported by AnyEvent::HTTP. You can
		910	compile your perl to support socks, or use an external program such as
		911	F<socksify> (dante) or F<tsocks> to make your program use a socks proxy
		912	transparently.
		913
		914	Alternatively, for AnyEvent::HTTP only, you can use your own
		915	C<tcp_connect> function that does the proxy handshake - here is an example
		916	that works with socks4a proxies:
		917
		918	use Errno;
		919	use AnyEvent::Util;
		920	use AnyEvent::Socket;
		921	use AnyEvent::Handle;
		922
		923	# host, port and username of/for your socks4a proxy
		924	my $socks_host = "10.0.0.23";
		925	my $socks_port = 9050;
		926	my $socks_user = "";
		927
		928	sub socks4a_connect {
		929	my ($host, $port, $connect_cb, $prepare_cb) = @_;
		930
		931	my $hdl = new AnyEvent::Handle
		932	connect => [$socks_host, $socks_port],
		933	on_prepare => sub { $prepare_cb->($_[0]{fh}) },
		934	on_error => sub { $connect_cb->() },
		935	;
		936
		937	$hdl->push_write (pack "CCnNZZ", 4, 1, $port, 1, $socks_user, $host);
		938
		939	$hdl->push_read (chunk => 8, sub {
		940	my ($hdl, $chunk) = @_;
		941	my ($status, $port, $ipn) = unpack "xCna4", $chunk;
		942
		943	if ($status == 0x5a) {
		944	$connect_cb->($hdl->{fh}, (format_address $ipn) . ":$port");
		945	} else {
		946	$! = Errno::ENXIO; $connect_cb->();
		947	}
		948	});
		949
		950	$hdl
		951	}
		952
		953	Use C<socks4a_connect> instead of C<tcp_connect> when doing C<http_request>s,
		954	possibly after switching off other proxy types:
		955
		956	AnyEvent::HTTP::set_proxy undef; # usually you do not want other proxies
		957
		958	http_get 'http://www.google.com', tcp_connect => \&socks4a_connect, sub {
		959	my ($data, $headers) = @_;
		960	...
		961	};
768		962
769	=head1 SEE ALSO	963	=head1 SEE ALSO
770		964
771	L<AnyEvent>.	965	L<AnyEvent>.
772		966

Diff Legend

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

Comparing AnyEvent-HTTP/HTTP.pm (file contents): Revision 1.44 by root, Tue Jul 7 00:15:32 2009 UTC vs. Revision 1.61 by root, Thu Dec 30 03:45:01 2010 UTC

Diff Legend

Comparing AnyEvent-HTTP/HTTP.pm (file contents):
Revision 1.44 by root, Tue Jul 7 00:15:32 2009 UTC vs.
Revision 1.61 by root, Thu Dec 30 03:45:01 2010 UTC