File Coverage

blib/lib/Web/Machine.pm

Criterion	Covered	Total	%
statement	68	68	100.0
branch	14	16	87.5
condition	2	6	33.3
subroutine	20	20	100.0
pod	6	6	100.0
total	110	116	94.8

package Web::Machine;
BEGIN {
  $Web::Machine::AUTHORITY = 'cpan:STEVAN';
}
# ABSTRACT: A Perl port of Webmachine
$Web::Machine::VERSION = '0.15';
use strict;
use warnings;

use Try::Tiny;
use Carp         qw[ confess ];
use Scalar::Util qw[ blessed ];
use Module::Runtime qw[ use_package_optimistically ];

use Plack::Request;
use Plack::Response;

use Web::Machine::Util qw[ inflate_headers ];
use Web::Machine::FSM;

use parent 'Plack::Component';

sub new {
    my ($class, %args) = @_;

    (exists $args{'resource'}
        && (not blessed $args{'resource'})
            && use_package_optimistically($args{'resource'})->isa('Web::Machine::Resource'))
                || confess 'You must pass in a resource for this Web::Machine';

    if (exists $args{'request_class'}) {
        use_package_optimistically($args{'request_class'})->isa('Plack::Request')
            || confess 'The request_class class must inherit from Plack::Request';
    }
    else {
        $args{'request_class'} = 'Plack::Request';
    }

    $class->SUPER::new( \%args );
}

sub inflate_request {
    my ($self, $env) = @_;
    inflate_headers( $self->{request_class}->new( $env ) );
}

sub create_fsm {
    my $self = shift;
    Web::Machine::FSM->new( tracing => $self->{'tracing'} )
}

sub create_resource {
    my ($self, $request) = @_;
    $self->{'resource'}->new(
        request  => $request,
        response => $request->new_response,
        @{ $self->{'resource_args'} || [] },
    );
}

sub finalize_response {
    my ($self, $response) = @_;
    $response->finalize;
}

sub call {
    my ($self, $env) = @_;

    my $request  = try { $self->inflate_request( $env ) };

    return $self->finalize_response( Plack::Response->new( 400 ) )
        unless defined $request;

    my $resource = $self->create_resource( $request );
    my $fsm      = $self->create_fsm;

    if ($self->{'streaming'}) {
        return sub {
            my $responder = shift;

            my $response = $self->finalize_response( $fsm->run( $resource ) );

            if (my $cb = $env->{'web.machine.streaming_push'}) {
                pop @$response;
                my $writer = $responder->($response);
                $cb->($writer);
            }
            else {
                $responder->($response);
            }
        }
    }
    else {
        my $response = $self->finalize_response( $fsm->run( $resource ) );

        if ($env->{'web.machine.streaming_push'}) {
            die "Can't do a streaming push response "
              . "unless the 'streaming' option was set";
        }
        else {
            return $response;
        }
    }
}

1;

__END__