view release on metacpan or  search on metacpan

lib/AnyEvent/UserAgent.pm  view on Meta::CPAN

has request_timeout    => (is => 'rw', default => sub { 0 });

my @OPTIONS = qw(
	proxy tls_ctx session timeout on_prepare tcp_connect on_header on_body
	want_body_handle persistent keepalive handle_params
);

for my $o (@OPTIONS) {
	has $o => (is => 'rw', default => undef);
}

sub request {
	my $cb = pop();
	my ($self, $req, %opts) = @_;

	$self->_request($req, \%opts, sub {
		$self->_response($req, @_, $cb);
	});
}

sub get    { _do_request(\&HTTP::Request::Common::GET    => @_) }
sub head   { _do_request(\&HTTP::Request::Common::HEAD   => @_) }
sub put    { _do_request(\&HTTP::Request::Common::PUT    => @_) }
sub delete { _do_request(\&HTTP::Request::Common::DELETE => @_) }
sub post   { _do_request(\&HTTP::Request::Common::POST   => @_) }
sub patch   { _do_request(\&HTTP::Request::Common::PATCH   => @_) }
sub options   { _do_request(\&HTTP::Request::Common::OPTIONS   => @_) }

sub _do_request {
	my $cb   = pop();
	my $meth = shift();
	my $self = shift();

	$self->request($meth->(@_), $cb);
}

sub _request {
	my ($self, $req, $opts, $cb) = @_;

	my $uri  = $req->uri;
	my $hdrs = $req->headers;

	unless ($hdrs->user_agent) {
		$hdrs->user_agent($self->agent);
	}

	if ($uri->can('userinfo') && $uri->userinfo && !$hdrs->authorization) {
		$hdrs->authorization_basic(split(':', $uri->userinfo, 2));
	}
	if ($uri->scheme) {
		$self->cookie_jar->add_cookie_header($req);
	}

	for (qw(max_redirects inactivity_timeout request_timeout), @OPTIONS) {
		$opts->{$_} = $self->$_() unless exists($opts->{$_});
	}

	my ($grd, $tmr);

	if ($opts->{request_timeout}) {
		$tmr = AE::timer $opts->{request_timeout}, 0, sub {
			undef($grd);
			$cb->($opts, undef, {Status => 597, Reason => 'Request timeout'});
		};
	}
	$grd = AnyEvent::HTTP::http_request(
		$req->method,
		$req->uri,
		headers => {map { $_ => scalar($hdrs->header($_)) } $hdrs->header_field_names},
		body    => $req->content,
		recurse => 0,
		timeout => $opts->{inactivity_timeout},
		(map { $_ => $opts->{$_} } grep { defined($opts->{$_}) } @OPTIONS),
		sub {
			undef($grd);
			undef($tmr);
			$cb->($opts, @_);
		}
	);
}

sub _response {
	my $cb = pop();
	my ($self, $req, $opts, $body, $hdrs, $prev, $count) = @_;

	my $res = HTTP::Response->new(delete($hdrs->{Status}), delete($hdrs->{Reason}));

	$res->request($req);
	$res->previous($prev) if $prev;

	delete($hdrs->{URL});
	if (defined($hdrs->{HTTPVersion})) {
		$res->protocol('HTTP/' . delete($hdrs->{HTTPVersion}));
	}
	if (my $hdr = $hdrs->{'set-cookie'}) {
		# Split comma-concatenated "Set-Cookie" values.
		# Based on RFC 6265, section 4.1.1.
		local @_ = split(/,([\w.!"'%\$&*+-^`]+=)/, ',' . $hdr);
		shift();
		my @val;
		push(@val, join('', shift(), shift())) while @_;
		$hdrs->{'set-cookie'} = \@val;
	}
	if (keys(%$hdrs)) {
		$res->header(%$hdrs);
	}
	if ($res->code >= 590 && $res->code <= 599 && $res->message) {
		if ($res->message eq 'Connection timed out') {
			$res->message('Inactivity timeout');
		}
		unless ($res->header('client-warning')) {
			$res->header('client-warning' => $res->message);
		}
	}
	if (defined($body)) {
		$res->content_ref(\$body);
	}
	$self->cookie_jar->extract_cookies($res);

	my $code = $res->code;