File Coverage

blib/lib/HTTP/Engine/MinimalCGI.pm

Criterion	Covered	Total	%
statement	63	71	88.7
branch	8	20	40.0
condition	4	12	33.3
subroutine	23	26	88.4
pod	0	2	0.0
total	98	131	74.8

package HTTP::Engine::MinimalCGI;
use strict;
use warnings;
use Scalar::Util                    ();
use HTTP::Headers::Fast             ();
use HTTP::Engine::ResponseFinalizer ();
use CGI::Simple                     ();

my $CRLF = "\015\012";

sub new {
    my $class = shift;
    bless { @_ }, $class;
}

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

    ### run handler
    my $req = HTTP::Engine::Request->new();
    my $res = $self->{request_handler}->( $req );
    unless ( Scalar::Util::blessed($res) && $res->isa('HTTP::Engine::Response') ) {
        die "You should return instance of HTTP::Engine::Response.";
    }
    HTTP::Engine::ResponseFinalizer->finalize($req => $res);
    print join(
        '',
        $res->headers->as_string_without_sort($CRLF),
        $CRLF,
        $res->body
    );
}

{
    package # hide from pause
        HTTP::Engine;

    sub new {
        my ($class, %args) = @_;
        unless (Scalar::Util::blessed($args{interface})) {
            if ($args{interface}->{module} ne 'MinimalCGI') {
                die "MinimalCGI is the only interface supported. Use the real HTTP::Engine for others.";
            }
            $args{interface} = HTTP::Engine::MinimalCGI->new(
                request_handler => $args{interface}->{request_handler}
            );
        }
        bless { interface => $args{interface} }, $class;
    }

    sub run { $_[0]->{interface}->run() }
}


{
    package # hide from pause
        HTTP::Engine::Response;

    sub new {
        my ($class, %args) = @_;
        bless {
            status  => 200,
            body    => '',
            headers => HTTP::Headers::Fast->new(),
            %args,
        }, $class;
    }
    sub header {
        my $self = shift;
        $self->{headers}->header(@_);
    }
    sub headers {
        my $self = shift;
        $self->{headers};
    }
    sub status {
        my $self = shift;
        $self->{status} = shift if @_;
        $self->{status};
    }
    sub body {
        my $self = shift;
        $self->{body} = shift if @_;
        $self->{body};
    }
    sub protocol       { 'HTTP/1.0' };
    sub content_length { my $self = shift; $self->{headers}->content_length(@_) };
    sub content_type   { my $self = shift; $self->{headers}->content_type(@_) };
    sub cookies        {
        my $self = shift;
        $self->{cookies} ||= do {
            if (my $header = $self->header('Cookie')) {
                +{ CGI::Simple::Cookie->parse($header) };
            } else {
                +{};
            }
        }
    }
}

{
    package # hide from pause
        HTTP::Engine::Request;

    sub new {
        my ($class, ) = @_;
        bless { }, $class;
    }

    sub hostname { $ENV{HTTP_HOST} || $ENV{SERVER_HOST} }
    sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' }
    sub method   { $ENV{REQUEST_METHOD} || 'GET' }

    sub param {
        my $self = shift;
        $self->{cs} ||= CGI::Simple->new();
        $self->{cs}->param(@_);
    }
    sub upload {
        my $self = shift;
        $self->{cs} ||= CGI::Simple->new();
        $self->{cs}->upload(@_);
    }
    sub header {
        my ($self, $key) = @_;
        $key = uc $key;
        $key =~ s/-/_/;
        $ENV{'HTTP_' . $key} || $ENV{'HTTPS_' . $key};
    }
}

1;

__END__