File Coverage

blib/lib/HTTP/MessageParser.pm

Criterion	Covered	Total	%
statement	50	50	100.0
branch	20	28	71.4
condition	2	2	100.0
subroutine	9	9	100.0
pod	6	6	100.0
total	87	95	91.5

package HTTP::MessageParser;

use strict;
use warnings;

our $VERSION = 0.3;

use Carp qw[];

{
    require Sub::Exporter;

    my $exporter = sub {
        my ( $class, $method ) = @_;
        return sub { return $class->$method(@_) };
    };

    my %exports = map { $_ => $exporter } qw(
        parse_headers
        parse_request
        parse_request_line
        parse_response
        parse_response_line
        parse_version
    );

    Sub::Exporter->import( -setup => { exports => \%exports } );
}

{
    # http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2
    # http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2
    # http://lists.w3.org/Archives/Public/ietf-http-wg/2004JanMar/thread.html#50
    # http://lists.w3.org/Archives/Public/ietf-http-wg/2005AprJun/0016.html

    my $CRLF     = qr/\x0D?\x0A/;
    my $LWS      = qr/$CRLF[\x09\x20]|[\x09\x20]/;
    my $TEXT     = qr/[\x20-\xFF]/;
    my $Token    = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
    my $Header   = qr/($Token+)$LWS*:$LWS*((?:$TEXT|$LWS)*)$CRLF/;
    my $Version  = qr/HTTP\/[0-9]+\.[0-9]+/;
    my $Request  = qr/(?:$CRLF)*($Token+)[\x09\x20]+([\x21-\xFF]+)(?:[\x09\x20]+($Version))?$CRLF/;
    my $Response = qr/($Version)[\x09\x20]+([0-9]{3})[\x09\x20]+($TEXT*)$CRLF/;

    sub parse_request ($$) {
        my $class  = shift;
        my $string = ref $_[0] ? shift : \( my $copy = shift );

        my @request = $class->parse_request_line($string);
        my $version = $class->parse_version( $request[2] );
        my $headers = [];

        if ( $version >= 1000 ) {

            $headers = $class->parse_headers($string);

            $$string =~ s/^$CRLF//o
              or Carp::croak('Bad Request');
        }
        else {

            $$string eq ''
              or Carp::croak('Bad Request');
        }

        return ( @request, $headers, $string );
    }

    sub parse_request_line ($$) {
        my $class  = shift;
        my $string = ref $_[0] ? shift : \( my $copy = shift );

        $$string =~ s/^$Request//o
          or Carp::croak('Bad Request-Line');

        return ( $1, $2, $3 || 'HTTP/0.9' );
    }

    sub parse_response ($$) {
        my $class  = shift;
        my $string = ref $_[0] ? shift : \( my $copy = shift );

        my @response = $class->parse_response_line($string);
        my $headers  = $class->parse_headers($string);

        $$string =~ s/^$CRLF//o
          or Carp::croak('Bad Response');

        return ( @response, $headers, $string );
    }

    # Yes, I know it's status_line, but response_line fits better with API ;)
    sub parse_response_line ($$) {
        my $class  = shift;
        my $string = ref $_[0] ? shift : \( my $copy = shift );

        $$string =~ s/^$Response//o
          or Carp::croak('Bad Status-Line');

        return ( $1, $2, $3 );
    }

    sub parse_headers ($$) {
        my $class  = shift;
        my $string = ref $_[0] ? shift : \( my $copy = shift );

        my @headers = ();

        while ( $$string =~ s/^$Header//o ) {
            push @headers, lc $1 => $2;
        }

        foreach ( @headers ) {
            s/$LWS+/\x20/og;
            s/^$LWS//o;
            s/$LWS$//o;
        }

        return wantarray ? @headers : \@headers;
    }

    sub parse_version ($$) {
        my $class  = shift;
        my $string = shift;

        $string =~ m/^HTTP\/([0-9]+)\.([0-9]+)$/
          or Carp::croak('Bad HTTP-Version');

        my $major  = $1;
        my $minor  = $2;
        my $number = $major * 1000 + $minor;

        return wantarray ? ( $major, $minor ) : $number;
    }
}

1;

__END__