File Coverage

blib/lib/IO/Callback/HTTP.pm

Criterion	Covered	Total	%
statement	93	100	93.0
branch	25	38	65.7
condition	14	30	46.6
subroutine	23	23	100.0
pod	2	2	100.0
total	157	193	81.3

package IO::Callback::HTTP;

use 5.008008;
use constant { false => !1, true => !0 };
use strict;
use warnings;
use utf8;

BEGIN {
	$IO::Callback::HTTP::AUTHORITY = 'cpan:TOBYINK';
	$IO::Callback::HTTP::VERSION   = '0.002';
}

use Carp                     qw();
use Encode                   qw( encode_utf8 );
use Errno                    qw( EIO );
use HTTP::Request::Common    qw( GET PUT );
use LWP::UserAgent           qw();
use Scalar::Util             qw( blessed );
use URI                      qw();

use namespace::clean;
use base 'IO::Callback';

our $_LAST_CODE;

sub USER_AGENT ()
{
	our $USER_AGENT ||= LWP::UserAgent::->new(
		agent => sprintf('%s/%s ', __PACKAGE__, __PACKAGE__->VERSION),
	);
}

sub open
{
	my ($self, $mode, $code, @args) = @_;

	unless (ref $code eq 'CODE')
	{
		$_LAST_CODE =
		$code = ($mode eq '<')
			? $self->_mk_reader($code, @args)
			: $self->_mk_writer($code, @args)
	}

	$self->SUPER::open($mode, $code);
}


sub _process_arg
{
	my ($self, $arg) = @_;

	if (defined $arg->{failure} and not ref $arg->{failure})
	{
		my $carpage = Carp::->can($arg->{failure})
			or Carp::croak("Unknown failure mode: '$arg->{failure}'");
		$arg->{failure} = sub
		{
			my $res = shift;
			$carpage->(sprintf(
				'HTTP %s request for <%s> failed: %s',
				$res->request->method,
				$res->request->uri,
				$res->status_line,
			));
		}
	}
}

sub _mk_reader
{
	my ($self, $code, %args) = @_;
	$self->_process_arg(\%args);

	if ((not ref $code)
	or  (blessed $code and $code->isa('URI')))
	{
		$code = GET($code);
	}

	if (blessed $code and $code->isa('HTTP::Request'))
	{
		my $ua    = $args{agent} || USER_AGENT;
		my $bytes = exists $args{bytes} ? $args{bytes} : true;
		my $req   = $code;
		my $done  = false;

		return sub
		{
			return undef if $done;
			my $res = $ua->request($req);
			$done = true;

			if ($res->is_success)
			{
				return encode_utf8($res->decoded_content) if $bytes;
				return $res->decoded_content;
			}

			$! = EIO;
			$args{failure}->($res) if $args{failure};
			return IO::Callback::Error;
		}
	}

	return;
}

sub _mk_writer
{
	my ($self, $code, %args) = @_;
	$self->_process_arg(\%args);

	if ((not ref $code)
	or  (blessed $code and $code->isa('URI')))
	{
		$code = PUT($code, Content => '');
	}

	if (blessed $code and $code->isa('HTTP::Request'))
	{
		my $ua    = $args{agent} || USER_AGENT;
		my $bytes = exists $args{bytes} ? $args{bytes} : true;
		my $req   = $code;
		my $done  = false;
		my $body  = '';
		return sub
		{
			my $str = shift;
			if (length $str)
			{
				$body .= $bytes ? $str : encode_utf8($str);
				return;
			}

			$req->content($body);
			$req->header(Content_length => length $req->content);
			my $res = $ua->request($req);

			if ($res->is_success)
			{
				$args{success}->($res) if $args{success};
				return;
			}

			$! = EIO;
			$args{failure}->($res) if $args{failure};
			return IO::Callback::Error;
		}
	}

	return;
}

# Your code goes here

true;

__END__