File Coverage

inc/Mock/HTTP/Tiny.pm

Criterion	Covered	Total	%
statement	55	58	94.8
branch	14	24	58.3
condition	8	16	50.0
subroutine	15	15	100.0
pod	5	5	100.0
total	97	118	82.2

package HTTP::Tiny;

use 5.008;

use strict;
use warnings;

use Carp;
use Storable ();

our $VERSION = '0.010_01';

use constant HASH_REF	=> ref {};

BEGIN {
    local $@ = undef;

    eval {
	require HTTP::Status;
	*_status_message = \&HTTP::Status::status_message;
	1;
    } or *_status_message = sub {
	my ( $status ) = @_;
	return _is_success( $status ) ? 'OK' : 'Failed';
    };
}

sub new {
    my ( $class, %arg ) = @_;
    defined $arg{fn}
	or $arg{fn} = 't/data/_http/status';
    if ( defined $arg{agent} ) {
	$arg{agent} =~ m/ \s \z /smx
	    and $arg{agent} .= $class->_default_agent();
    } else {
	$arg{agent} = $class->_default_agent();
    }
    return bless \%arg, ref $class || $class;
}

sub agent {
    my ( $invocant ) = @_;
    ref $invocant
	or return $invocant->_default_agent();
    return $invocant->{agent};
}

sub _default_agent {
    my ( $self ) = @_;
    ( my $agent = ref $self || $self ) =~ s/ :: /-/smxg;
    return join '/', "Mock $agent", $self->VERSION();
}

# NOTE this is only the static functionality.
sub can_ssl {
    local $@ = undef;
    my ( $ok, $reason ) = ( 1, '' );
    eval {
	require IO::Socket::SSL;
	IO::Socket::SSL->VERSION( 1.42 );
	1;
    } or ( $ok, $reason ) =
    ( 0, "IO::Socket::SSL 1.42 must be installed for https support\n" );
    wantarray
	or return $ok;
    return ( $ok, $reason );
}

sub head {
    my ( $self, $url ) = @_;
    return $self->request( HEAD => $url );
}

sub request {
    my ( $self, undef, $url ) = @_;
    $self->{status} ||= Storable::retrieve( $self->{fn} );
    my $resp = $self->{status}{$url};
    HASH_REF eq ref $resp
	or $resp = {
	status	=> $resp || 404,
    };
    $resp->{success} = _is_success( $resp->{status} );
    defined $resp->{reason}
	or $resp->{reason} = _status_message( $resp->{status} );
    defined $resp->{url}
	or $resp->{url} = $url;
    defined $resp->{content}
	or $resp->{content} = '';
    $resp->{headers} ||= {};
    return $resp;
}

sub _is_success {
    my ( $status ) = @_;
    return $status >= 200 && $status < 300;
}

1;

__END__