File Coverage

blib/lib/WWW/REST.pm

Criterion	Covered	Total	%
statement	71	75	94.6
branch	12	16	75.0
condition	2	3	66.6
subroutine	19	20	95.0
pod	3	3	100.0
total	107	117	91.4

use 5.006;
package WWW::REST;
# $WWW::REST::VERSION = '0.011';
$WWW::REST::VERSION = '0.023';
use strict;
use vars '$AUTOLOAD';

use URI ();
use LWP::UserAgent ();
use HTTP::Request::Common ();
use Class::Struct ();

use constant MEMBERS => qw(_uri _ua _res dispatch);
use constant METHODS => qw(options get head post put delete trace connect);

Class::Struct::struct(map { $_ => '$' } +MEMBERS);


my $old_new = \&new;

*new = sub {
    my $obj = shift;
    my $class = ref($obj) || $obj;
    my $uri = shift;
    my $self = $old_new->($class);
    $self->_uri( URI->new($uri) );
    $self->_uri( $self->_uri->abs($obj->_uri) ) if ref($obj);
    $self->_ua(
        ref($obj) ? $obj->_ua : LWP::UserAgent->new( cookie_jar => {}, @_)
    );
    $self->dispatch( $obj->dispatch ) if ref($obj);
    return $self;
};


*url = \&new;


sub AUTOLOAD {
    my $self = shift;
    $AUTOLOAD =~ s/^.*:://;
    foreach my $delegate (+MEMBERS) {
        my $obj = $self->can($delegate)->($self);
        my $code = UNIVERSAL::can($obj, $AUTOLOAD) or next;
        unshift @_, $obj;
        goto &$code;
    }
    die "No such method: $AUTOLOAD";
}

sub DESTROY {}

sub _request {
    my $method = uc(+shift);
    sub {
        my $self = shift;
        $self->query_form(@_);
        my $request = _simple_req( $method, $self->as_string );
        my $res = $self->_ua->request($request);
        $self->_res($res);
        my $dispatch = $self->dispatch or return $self;
        return $dispatch->($self);
    };
}

sub _simple_req
{
    my($method, $url) = splice(@_, 0, 2);
    my $req = HTTP::Request->new($method => $url);
    my($k, $v);
    while (($k,$v) = splice(@_, 0, 2)) {
        if (lc($k) eq 'content') {
            $req->add_content($v);
        } else {
            $req->push_header($k, $v);
        }
    }
    $req;
}


BEGIN {
    foreach my $method (+METHODS) {
        no strict 'refs';
        *$method = _request($method) unless $method eq 'post';
    }
}

sub post {
    my $self = shift;
    my $request = HTTP::Request::Common::POST( $self->as_string, \@_ );
    my $res = $self->_ua->request($request);
    $self->_res($res);
    my $dispatch = $self->dispatch or return $self;
    return $dispatch->($res);
}


sub parent { $_[0]->new('../') }


sub dir {
    my @segs = $_[0]->path_segments;
    pop @segs;
    return $_[0]->new(join('/', @segs, ''));
}


1;

__END__