Test::HTTP - Test HTTP interactions.

 use Test::HTTP tests => 9;

 {
     my $uri = "$BASE/data/page/Foo_Bar_Baz";
     my $type = 'text/x.waki-wiki';
     my $test = Test::HTTP->new('HTTP page creation and deletion');

     $test->get($uri, {Accept => $type});
     $test->status_code_is(404, "Page not yet there.");

     $test->put($uri, {'Content-type' => $type}, 'xyzzy');
     $test->status_code_is(201, "PUT returns 201."); # Created
     $test->header_is(
         'Content-type' => $type,
         "Content-type matches on PUT.");
     $test->header_like(
         Location => qr{^$BASE/data/page/},
         "Created page location makes sense.");
     $test->body_is('xyzzy');

     $test->get($uri, {Accept => $type});
     $test->status_code_is(200, "Page is now there.");
     $test->header_is(
         'Content-type' => $type,
         "Content-type matches on GET.");
     $test->body_is('xyzzy');

     $test->delete($uri);
     $test->status_code_is(204, "DELETE returns 204."); # No content
 }

  $obj->run_request(METHOD => ARGS);

    {
        local $Test::HTTP::UaClass = 'MyCorp::REST::FakeUserAgent';
        my $test = Test::HTTP->new("widget HTTP access");
        # ...
    }

package Test::HTTP;
use warnings;
use strict;

our $VERSION = 0.16;

use base 'Exporter';
use Carp 'croak';
use Class::Field 'field';
use Encode qw(encode_utf8 is_utf8);
use Filter::Util::Call;
use HTTP::Request;
use Test::Builder;

our $Builder = Test::Builder->new;
our $BasicPassword;
our $BasicUsername;
our $UaClass = 'LWP::UserAgent';
our $TODO = undef;
our @EXPORT = qw($TODO);

sub _partition(&@);

sub import {
    my $class = shift;

    $Builder->exported_to(scalar caller);

    my ( $syntax, $nargs ) = _partition { $_ eq '-syntax' } @_;
    $Builder->plan(@$nargs);

    # WARNING: This only exports the stuff in @EXPORT.
    $class->export_to_level(1, $class);

    if (@$syntax) {
        @_ = ();
        require Test::HTTP::Syntax;
        goto &Test::HTTP::Syntax::import;
    }
}

sub new {
    my $class = shift;

    my $new_object = bless {}, $class;
    $new_object->_initiliaze(@_);
    return $new_object;
}

sub _initiliaze {
    my ( $self, $name ) = @_;

    $self->name($name);
}

# Given a predicate and a list, return two listrefs.  The elements in the
# first listref satisfy the predicate, and those in the second do not.  The
# predicate acts on a localized value of $_ rather than any arguments to it.
sub _partition(&@) {
    my ( $pred, @l )  = @_;
    my ( $tl,   $fl ) = ( [], [] );

    push @{ &$pred ? $tl : $fl }, $_ for @l;

    return ( $tl, $fl );
}

field 'name';
field 'request';
field 'response';
field 'ua', -init => '$self->_ua_class->new';
field 'username', -init => '$Test::HTTP::BasicUsername';
field 'password', -init => '$Test::HTTP::BasicPassword';

sub head {
    my $self = shift;
    $self->run_request(HEAD => @_);
}

sub get {
    my $self = shift;
    $self->run_request(GET => @_);
}

sub put {
    my $self = shift;
    $self->run_request(PUT => @_);
}

sub post {
    my $self = shift;
    $self->run_request(POST => @_);
}

sub delete {
    my $self = shift;
    $self->run_request(DELETE => @_);
}

sub run_request {
    my ( $self, @request_args ) = @_;
    $self->new_request(@request_args) if @request_args;
    if ($self->request->method ne 'GET') {
        if (is_utf8($self->request->content)) {
            my $content = $self->request->content;
            $content = encode_utf8($content);
            $self->request->content($content);
        }
    }

    $self->response( $self->ua->simple_request( $self->request ) );
    croak( $self->request->uri . ': ' . $self->response->status_line )
        if $self->response->status_line =~ /500 Can't connect to /;
    return $self->response;
}

sub new_request {
    my ( $self, $method, $uri, @args ) = @_;
    $self->request(
        HTTP::Request->new( $method => $uri, @args ) );
    $self->request->authorization_basic($self->username, $self->password)
        if (defined $self->username) || (defined $self->password);
    return $self->request;
}

sub status_code_is {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $self, $expected_code, $description ) = @_;

    $description ||= $self->name . " status is $expected_code.";

    $Builder->is_eq( $self->response->code, $expected_code, $description );
}

sub header_is {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $self, $header_name, $expected_value, $description ) = @_;

    $description ||= $self->name . " $header_name matches '$expected_value'.";

    $Builder->is_eq(
        scalar $self->response->header($header_name),
        $expected_value,
        $description
    );
}

sub header_like {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $self, $header_name, $regex, $description ) = @_;

    $description ||= $self->name . " $header_name matches $regex.";

    $Builder->like(
        scalar $self->response->header($header_name),
        $regex,
        $description
    );
}

sub body_is {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $self, $expected_body, $description ) = @_;

    $description ||= $self->name . " body is '$expected_body'.";

    $Builder->is_eq( $self->_decoded_content, $expected_body, $description );
}

sub body_like {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $self, $regex, $description ) = @_;

    $description ||= $self->name . " body matches $regex.";

    $Builder->like($self->_decoded_content, $regex, $description);
}

sub _ua_class {
    my $self = shift;

    my $class = exists $ENV{TEST_HTTP_UA_CLASS}
        ? $ENV{TEST_HTTP_UA_CLASS}
        : $UaClass;

    eval "require $class";
    die if $@;
    $class->import;

    return $class;
}

sub _decoded_content {
    my $self = shift;
    my $content = $self->response->decoded_content;
   
    # Work around a bug in HTTP::Message where only text or xml content types
    # are decoded
    my $response = $self->response;
    my $ct = $self->response->header("Content-Type");
    unless ($response->content_is_text or $response->content_is_xml) {
        my ($charset) = $ct =~ m{charset=(\S+)};
        $charset ||= "ISO-8859-1";
        require Encode;
        $content = Encode::decode($charset, $content);
    }

    return $content;
}

1;