Changeset 17154

Show
Ignore:
Timestamp:
08/06/08 15:40:50 (6 years ago)
Author:
yappo
Message:

svk smerge branches/lazy_request trunk

Location:
lang/perl/HTTP-Engine/trunk
Files:
19 added
1 removed
15 modified

Legend:

Unmodified
Added
Removed
  • lang/perl/HTTP-Engine/trunk/Makefile.PL

    r16882 r17154  
    33{ 
    44    eval {  
     5        die "not testing mod_perl" unless $ENV{TEST_MODPERL}; 
    56        require mod_perl2; 
    67        require Apache::Test; 
     
    7778    tests('t/*.t t/*/*.t t/modperl/basic.t'); 
    7879} else { 
    79     tests('t/*.t t/*/*.t'); 
     80    tests('t/*.t t/*/*.t '); 
    8081} 
    8182 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine.pm

    r16877 r17154  
    4848 
    4949    if ($pkg->meta->has_method('wrap')) { 
     50        HTTP::Engine::RequestProcessor->meta->make_mutable; 
    5051        HTTP::Engine::RequestProcessor->meta->add_around_method_modifier( 
    5152            call_handler => $pkg->meta->get_method('wrap')->body 
    5253        ); 
     54        HTTP::Engine::RequestProcessor->meta->make_immutable; 
    5355    } 
    5456} 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Interface/Standalone.pm

    r11845 r17154  
    33with 'HTTP::Engine::Role::Interface'; 
    44 
    5 use Errno 'EWOULDBLOCK'; 
    65use Socket qw(:all); 
    76use IO::Socket::INET (); 
     
    2827); 
    2928 
     29# fixme add preforking support using Parallel::Prefork 
    3030has fork => ( 
    3131    is      => 'ro', 
     
    4646); 
    4747 
    48  
    49 use HTTP::Engine::ResponseWriter; 
    50 HTTP::Engine::RequestBuilder->meta->add_method( _read_chunk  => sub { 
    51     shift; 
    52     # support for non-blocking IO 
    53     my $rin = ''; 
    54     vec($rin, *STDIN->fileno, 1) = 1; 
    55  
    56     READ: 
    57     { 
    58         select($rin, undef, undef, undef); ## no critic. 
    59         my $rc = *STDIN->sysread(@_); 
    60         if (defined $rc) { 
    61            return $rc; 
    62        } else { 
    63             next READ if $! == EWOULDBLOCK; 
    64             return; 
    65         } 
    66     } 
    67 }); 
    68  
    69 HTTP::Engine::RequestBuilder->meta->add_before_method_modifier( _prepare_read => sub { 
    70     my $self = shift; 
    71     # Set the input handle to non-blocking 
    72     *STDIN->blocking(0); 
    73 }); 
    74  
    75 use HTTP::Engine::ResponseWriter; 
    76 my $is_keepalive; 
    77 HTTP::Engine::ResponseWriter->meta->add_before_method_modifier( finalize => sub { 
    78     my($self, $c) = @_; 
    79  
    80     $c->res->headers->date(time); 
    81     $c->res->headers->header( 
    82         Connection => $is_keepalive ? 'keep-alive' : 'close' 
    83     ); 
    84 }); 
    85  
    8648sub run { 
    87     my($self, ) = @_; 
    88  
    89     $is_keepalive = sub { $self->keepalive }; 
     49    my ( $self ) = @_; 
     50 
     51    $self->response_writer->keepalive( $self->fork && $self->keepalive ); 
    9052 
    9153    my $host = $self->host; 
     
    11981    my $pid    = undef; 
    12082    local $SIG{CHLD} = 'IGNORE'; 
    121     while (accept(Remote, $daemon)) { 
     83 
     84    while (my $remote = $daemon->accept) { 
    12285        # TODO (Catalyst): get while ( my $remote = $daemon->accept ) to work 
    12386        delete $self->{_sigpipe}; 
    124         select Remote; 
    125  
    126         # Request data 
    127         Remote->blocking(1); 
    128  
    129         next unless my($method, $uri, $protocol) = $self->_parse_request_line(\*Remote); 
     87 
     88        next unless my($method, $uri, $protocol) = $self->_parse_request_line($remote); 
    13089        unless (uc $method eq 'RESTART') { 
    13190            # Fork 
    13291            next if $self->fork && ($pid = fork); 
    133             $self->_handler($port, $method, $uri, $protocol); 
     92            $self->_handler($remote, $port, $method, $uri, $protocol); 
    13493            $daemon->close if defined $pid; 
    13594        } else { 
    136             my $sockdata = $self->_socket_data(\*Remote); 
     95            my $sockdata = $self->_socket_data($remote); 
    13796            my $ipaddr   = _inet_addr($sockdata->{peeraddr}); 
    13897            my $ready    = 0; 
     
    149108        exit if defined $pid; 
    150109    } continue { 
    151         close Remote; 
     110        close $remote; 
    152111    } 
    153112    $daemon->close; 
     
    163122 
    164123sub _handler { 
    165     my($self, $port, $method, $uri, $protocol) = @_; 
     124    my($self, $remote, $port, $method, $uri, $protocol) = @_; 
    166125 
    167126    # Ignore broken pipes as an HTTP server should 
    168     local $SIG{PIPE} = sub { $self->{_sigpipe} = 1; close Remote }; 
    169  
    170     local *STDIN  = \*Remote; 
    171     local *STDOUT = \*Remote; 
     127    local $SIG{PIPE} = sub { $self->{_sigpipe} = 1; close $remote }; 
    172128 
    173129    # We better be careful and just use 1.0 
    174130    $protocol = '1.0'; 
    175131 
    176     my $sockdata    = $self->_socket_data(\*Remote); 
    177     my %copy_of_env = %ENV; 
     132    my $sockdata    = $self->_socket_data($remote); 
    178133 
    179134    my $sel = IO::Select->new; 
    180     $sel->add(\*STDIN); 
     135    $sel->add($remote); 
     136 
     137    $remote->autoflush(1); 
    181138 
    182139    while (1) { 
     140        # FIXME refactor an HTTP push parser 
    183141        my($path, $query_string) = split /\?/, $uri, 2; 
    184142 
    185         # Initialize CGI environment 
    186         local %ENV = ( 
    187             PATH_INFO       => $path         || '', 
    188             QUERY_STRING    => $query_string || '', 
    189             REMOTE_ADDR     => $sockdata->{peeraddr}, 
    190             REMOTE_HOST     => $sockdata->{peername}, 
    191             REQUEST_METHOD  => $method || '', 
    192             SERVER_NAME     => $sockdata->{localname}, 
    193             SERVER_PORT     => $port, 
    194             SERVER_PROTOCOL => "HTTP/$protocol", 
    195             %copy_of_env, 
    196         ); 
     143        my $headers; 
    197144 
    198145        # Parse headers 
     146        # taken from HTTP::Message, which is unfortunately not really reusable 
    199147        if ($protocol >= 1) { 
    200             while (1) { 
    201                 my $line = $self->_get_line(\*STDIN); 
    202                 last if $line eq ''; 
    203                 next unless my ( $name, $value ) = $line =~ m/\A(\w(?:-?\w+)*):\s(.+)\z/; 
    204  
    205                 $name = uc $name; 
    206                 $name = 'COOKIE' if $name eq 'COOKIES'; 
    207                 $name =~ tr/-/_/; 
    208                 $name = 'HTTP_' . $name unless $name =~ m/\A(?:CONTENT_(?:LENGTH|TYPE)|COOKIE)\z/; 
    209                 if (exists $ENV{$name}) { 
    210                     $ENV{$name} .= "; $value"; 
     148            my @hdr; 
     149            while ( length(my $line = $self->_get_line($remote)) ) { 
     150                if ($line =~ s/^([^\s:]+)[ \t]*: ?(.*)//) { 
     151                    push(@hdr, $1, $2); 
     152                } 
     153                elsif (@hdr && $line =~ s/^([ \t].*)//) { 
     154                    $hdr[-1] .= "\n$1"; 
    211155                } else { 
    212                     $ENV{$name} = $value; 
     156                    last; 
    213157                } 
    214158            } 
     159            $headers = HTTP::Headers->new(@hdr); 
     160        } else { 
     161            $headers = HTTP::Headers->new; 
    215162        } 
     163 
    216164        # Pass flow control to HTTP::Engine 
    217         $self->handle_request; 
    218  
    219         my $connection = lc $ENV{HTTP_CONNECTION}; 
     165        $self->handle_request( 
     166            uri            => URI::WithBase->new($uri), 
     167            headers        => $headers, 
     168            method         => $method, 
     169            address        => $sockdata->{peeraddr}, 
     170            port           => $port, 
     171            protocol       => "HTTP/$protocol", 
     172            user           => undef, 
     173            https_info     => undef, 
     174            _connection => { 
     175                input_handle  => $remote, 
     176                output_handle => $remote, 
     177                env           => {}, # no more env than what we provide 
     178            }, 
     179        ); 
     180 
     181        my $connection = $headers->header("Connection"); 
     182 
    220183        last 
    221           unless $self->keepalive 
     184          unless $self->fork && $self->keepalive 
    222185          && index($connection, 'keep-alive') > -1 
    223186          && index($connection, 'te') == -1          # opera stuff 
    224187          && $sel->can_read(5); 
    225188 
    226         last unless ($method, $uri, $protocol) = $self->_parse_request_line(\*STDIN, 1); 
    227     } 
    228  
    229     sysread(Remote, my $buf, 4096) if $sel->can_read(0); # IE bk 
    230     close Remote; 
     189        last unless ($method, $uri, $protocol) = $self->_parse_request_line($remote, 1); 
     190    } 
     191 
     192    $self->request_builder->_io_read($remote, my $buf, 4096) if $sel->can_read(0); # IE bk 
     193    close $remote; 
    231194} 
    232195 
     
    254217 
    255218    my $data = { 
    256         peername => gethostbyaddr($iaddr, AF_INET) || "localhost", 
    257219        peeraddr => inet_ntoa($iaddr) || "127.0.0.1", 
    258         localname => gethostbyaddr($localiaddr, AF_INET) || "localhost", 
    259220        localaddr => inet_ntoa($localiaddr) || "127.0.0.1", 
    260221    }; 
     
    266227    my($self, $handle) = @_; 
    267228 
     229    # FIXME use bufferred but nonblocking IO? this is a lot of calls =( 
    268230    my $line = ''; 
    269     while (sysread($handle, my $byte, 1)) { 
     231    while ($self->request_builder->_io_read($handle, my $byte, 1)) { 
    270232        last if $byte eq "\012";    # eol 
    271233        $line .= $byte; 
    272234    } 
    273     1 while $line =~ s/\s\z//; 
     235 
     236    # strip \r, \n was already stripped 
     237    $line =~ s/\015$//s; 
    274238 
    275239    $line; 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Interface/Test.pm

    r11836 r17154  
    33with 'HTTP::Engine::Role::Interface'; 
    44 
    5 use HTTP::Request::AsCGI; 
     5use URI::WithBase; 
    66 
    77use constant should_write_response_line => 0; 
    88 
    99sub run { 
    10     my($self, $request, $env) = @_; 
     10    my ( $self, $request, $env ) = @_; 
    1111    $env ||= \%ENV; 
    1212 
    13     my $cgi = HTTP::Request::AsCGI->new( $request, %$env )->setup; 
     13    $self->handle_request( 
     14        request_args => { 
     15            uri        => URI::WithBase->new( $request->uri ), 
     16            base       => do { 
     17                my $base = $request->uri->clone; 
     18                $base->path_query('/'); 
     19                $base; 
     20            }, 
     21            headers    => $request->headers, 
     22            raw_body   => $request->content, 
     23            method     => $request->method, 
     24            address    => "127.0.0.1", 
     25            port       => "80", 
     26            protocol   => "HTTP/1.0", 
     27            user       => undef, 
     28            https_info => undef, 
     29            _builder_params => { 
     30                request => $request, 
     31            }, 
     32        }, 
     33        response_args => { 
     34        }, 
     35    ); 
    1436 
    15     $self->handle_request; 
    16  
    17     $cgi->restore->response; 
     37    $self->response_writer->get_response; # FIXME yuck, should be a ret from handle_request 
    1838} 
    1939 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Request.pm

    r16842 r17154  
    77use HTTP::Engine::Types::Core qw( Uri Header ); 
    88use HTTP::Request; 
    9 use IO::Socket qw[AF_INET inet_aton]; 
    109use URI::QueryParam; 
    11  
    12 # the IP address of the client 
    13 has address => ( 
    14     is  => 'rw', 
    15     isa => 'Str', 
    16 ); 
     10use URI::QueryParam; 
     11 
     12# Moose role merging is borked with attributes 
     13#with qw(HTTP::Engine::Request); 
     14 
     15# this object constructs all our lazy fields for us 
     16has request_builder => ( 
     17    does => "HTTP::Engine::Role::RequestBuilder", 
     18    is   => "rw", 
     19    # handles ... 
     20    # takes_self => 1, # add this to Moose 
     21    default => sub { # FIXME deprecate the default 
     22        require HTTP::Engine::RequestBuilder::Dummy; 
     23        HTTP::Engine::RequestBuilder::Dummy->new; 
     24    } 
     25); 
     26 
     27sub BUILD { 
     28    my ( $self, $param ) = @_; 
     29 
     30    foreach my $field qw(base path) { 
     31        if ( my $val = $param->{$field} ) { 
     32            $self->$field($val); 
     33        } 
     34    } 
     35} 
     36 
     37has _builder_params => ( 
     38    is => "ro", 
     39    isa => "HashRef", 
     40    default => sub { {} }, 
     41); 
     42 
     43has _connection => ( 
     44    is => "ro", 
     45    lazy_build => 1, 
     46); 
     47 
     48sub _build__connection { 
     49    my $self = shift; 
     50    $self->request_builder->_build_connection($self); 
     51} 
     52 
     53has "_read_state" => ( 
     54    is => "rw", 
     55    lazy_build => 1, 
     56); 
     57 
     58sub _build__read_state { 
     59    my $self = shift; 
     60    $self->request_builder->_build_read_state($self); 
     61} 
     62 
     63has connection_info => ( 
     64    is => "rw", 
     65    isa => "HashRef", 
     66    lazy_build => 1, 
     67); 
     68 
     69sub _build_connection_info { 
     70    my $self = shift; 
     71    $self->request_builder->_build_connection_info($self); 
     72} 
    1773 
    1874has context => ( 
     
    2581    is      => 'rw', 
    2682    isa     => 'HashRef', 
    27     default => sub { {} }, 
    28 ); 
    29  
    30 has method => ( 
    31     is  => 'rw', 
    32     # isa => 'Str', 
    33 ); 
    34  
    35 has protocol => ( 
    36     is  => 'rw', 
    37     # isa => 'Str', 
    38 ); 
    39  
     83    lazy_build => 1, 
     84); 
     85 
     86sub _build_cookies { 
     87    my $self = shift; 
     88    $self->request_builder->_build_cookies($self); 
     89} 
     90 
     91foreach my $attr qw(address method protocol user port https_info) { 
     92    has $attr => ( 
     93        is => 'rw', 
     94        # isa => "Str", 
     95        lazy => 1, 
     96        default => sub { shift->connection_info->{$attr} }, 
     97    ); 
     98} 
    4099has query_parameters => ( 
    41100    is      => 'rw', 
    42101    isa     => 'HashRef', 
    43     default => sub { {} }, 
    44 ); 
     102    lazy_build => 1, 
     103); 
     104 
     105sub _build_query_parameters { 
     106    my $self = shift; 
     107    $self->uri->query_form_hash; 
     108} 
    45109 
    46110# https or not? 
     
    48112    is      => 'rw', 
    49113    isa     => 'Bool', 
    50     default => 0, 
    51 ); 
     114    lazy_build => 1, 
     115); 
     116 
     117sub _build_secure { 
     118    my $self = shift; 
     119 
     120    if ( my $https = $self->https_info ) { 
     121        return 1 if uc($https) eq 'ON'; 
     122    } 
     123 
     124    if ( my $port = $self->port ) { 
     125        return 1 if $port == 443; 
     126    } 
     127 
     128    return 0; 
     129} 
    52130 
    53131has uri => ( 
     
    55133    isa    => Uri, 
    56134    coerce => 1, 
    57 ); 
    58  
    59 has user => ( is => 'rw', ); 
     135    lazy_build => 1, 
     136    handles => [qw(base path)], 
     137); 
     138 
     139sub _build_uri { 
     140    my $self = shift; 
     141    $self->request_builder->_build_uri($self); 
     142} 
    60143 
    61144has raw_body => ( 
    62145    is      => 'rw', 
    63146    isa     => 'Str', 
    64     default => '', 
    65 ); 
     147    lazy_build => 1, 
     148); 
     149 
     150sub _build_raw_body { 
     151    my $self = shift; 
     152    $self->request_builder->_build_raw_body($self); 
     153} 
    66154 
    67155has headers => ( 
     
    69157    isa     => Header, 
    70158    coerce  => 1, 
    71     default => sub { HTTP::Headers->new }, 
     159    lazy_build => 1, 
    72160    handles => [ qw(content_encoding content_length content_type header referer user_agent) ], 
    73161); 
     162 
     163sub _build_headers { 
     164    my $self = shift; 
     165    $self->request_builder->_build_headers($self); 
     166} 
    74167 
    75168# Contains the URI base. This will always have a trailing slash. 
    76169# If your application was queried with the URI C<http://localhost:3000/some/path> then C<base> is C<http://localhost:3000/>. 
    77 has base => ( 
    78     is      => 'rw', 
    79     isa     => Uri, 
    80     trigger => sub { 
    81         my $self = shift; 
    82  
    83         if ( $self->uri ) { 
    84             $self->path; # clear cache. 
    85         } 
    86     }, 
    87 ); 
    88170 
    89171has hostname => ( 
    90172    is      => 'rw', 
    91173    isa     => 'Str', 
    92     lazy    => 1, 
    93     default => sub { 
    94         my $self = shift; 
    95         $ENV{REMOTE_HOST} || gethostbyaddr( inet_aton( $self->address ), AF_INET ); 
    96     }, 
    97 ); 
     174    lazy_build => 1, 
     175); 
     176 
     177sub _build_hostname { 
     178    my $self = shift; 
     179    $self->request_builder->_build_hostname; 
     180} 
    98181 
    99182has http_body => ( 
    100     is      => 'rw', 
    101     isa     => 'HTTP::Body', 
     183    is         => 'rw', 
     184    isa        => 'HTTP::Body', 
     185    lazy_build => 1, 
    102186    handles => { 
    103187        body_parameters => 'param', 
     
    106190); 
    107191 
     192sub _build_http_body { 
     193    my $self = shift; 
     194    $self->request_builder->_build_http_body($self); 
     195} 
     196 
    108197# contains body_params and query_params 
    109198has parameters => ( 
    110199    is      => 'rw', 
    111200    isa     => 'HashRef', 
    112     default => sub { +{} }, 
    113 ); 
     201    lazy_build => 1, 
     202); 
     203 
     204sub _build_parameters { 
     205    my $self = shift; 
     206 
     207    my $query = $self->query_parameters; 
     208    my $body = $self->body_parameters; 
     209 
     210    my %merged; 
     211 
     212    foreach my $hash ( $query, $body ) { 
     213        foreach my $name ( keys %$hash ) { 
     214            my $param = $hash->{$name}; 
     215            push( @{ $merged{$name} ||= [] }, ( ref $param ? @$param : $param ) ); 
     216        } 
     217    } 
     218 
     219    foreach my $param ( values %merged ) { 
     220        $param = $param->[0] if @$param == 1; 
     221    } 
     222 
     223    return \%merged; 
     224} 
    114225 
    115226has uploads => ( 
     
    162273        $self->parameters->{$field} = [@_]; 
    163274    } 
    164 } 
    165  
    166  
    167 sub path { 
    168     my ($self, $params) = @_; 
    169  
    170     if ($params) { 
    171         $self->uri->path($params); 
    172     } else { 
    173         return $self->{path} if $self->{path}; 
    174     } 
    175  
    176     my $path     = $self->uri->path; 
    177     my $location = $self->base->path; 
    178     $path =~ s/^(\Q$location\E)?//; 
    179     $path =~ s/^\///; 
    180     $self->{path} = $path; 
    181  
    182     return $path; 
    183275} 
    184276 
     
    248340 
    249341    unless ($location =~ m!^https?://!) { 
    250         my $base = $self->base; 
    251         my $url = sprintf '%s://%s', $base->scheme, $base->host; 
    252         unless (($base->scheme eq 'http' && $base->port eq '80') || 
    253                ($base->scheme eq 'https' && $base->port eq '443')) { 
    254             $url .= ':' . $base->port; 
    255         } 
    256         $url .= $base->path; 
    257         $location = URI->new_abs($location, $url); 
    258     } 
    259     $location; 
     342        return URI->new( $location )->abs( $self->base ); 
     343    } else { 
     344        return $location; 
     345    } 
    260346} 
    261347 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Request/Upload.pm

    r11693 r17154  
    6363    binmode( $handle, $layer ); 
    6464 
    65     while ( $handle->sysread( my $buffer, 8192 ) ) { 
     65    while ( $handle->read( my $buffer, 8192 ) ) { 
    6666        $content .= $buffer; 
    6767    } 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/RequestBuilder.pm

    r11689 r17154  
    33use CGI::Simple::Cookie; 
    44 
    5 # tempolary file path for upload file. 
    6 has upload_tmp => ( 
    7     is => 'rw', 
     5with qw( 
     6    HTTP::Engine::Role::RequestBuilder::ParseEnv 
     7    HTTP::Engine::Role::RequestBuilder::HTTPBody 
    88); 
    99 
    10 has chunk_size => ( 
    11     is      => 'ro', 
    12     isa     => 'Int', 
    13     default => 4096, 
    14 ); 
    1510 
    16 has read_length => ( 
    17     is  => 'rw', 
    18     isa => 'Int', 
    19 ); 
    20  
    21 has read_position => ( 
    22     is  => 'rw', 
    23     isa => 'Int', 
    24 ); 
    25  
    26 no Moose; 
    27  
    28 sub prepare { 
    29     my ($self, $context) = @_; 
    30  
    31     # init. 
    32     delete $self->{_prepared_read}; 
    33  
    34     # do build. 
    35     for my $method (qw( connection query_parameters headers cookie path body parameters uploads )) { 
    36         my $method = "_prepare_$method"; 
    37         $self->$method($context); 
     11sub _build_connection { 
     12    return { 
     13        env           => \%ENV, 
     14        input_handle  => \*STDIN, 
     15        output_handle => \*STDOUT, 
    3816    } 
    3917} 
    4018 
    41 sub _prepare_connection { 
    42     my($self, $c) = @_; 
    43  
    44     my $req = $c->req; 
    45     $req->address($ENV{REMOTE_ADDR}) unless $req->address; 
    46  
    47     $req->protocol($ENV{SERVER_PROTOCOL}); 
    48     $req->user($ENV{REMOTE_USER}); 
    49     $req->method($ENV{REQUEST_METHOD}); 
    50  
    51     $req->secure(1) if $ENV{HTTPS} && uc $ENV{HTTPS} eq 'ON'; 
    52     $req->secure(1) if $ENV{SERVER_PORT} == 443; 
    53 } 
    54  
    55 sub _prepare_query_parameters  { 
    56     my($self, $c) = @_; 
    57     my $query_string = $ENV{QUERY_STRING}; 
    58     return unless  
    59         defined $query_string && length($query_string); 
    60  
    61     # replace semi-colons 
    62     $query_string =~ s/;/&/g; 
    63  
    64     my $uri = URI->new('', 'http'); 
    65     $uri->query($query_string); 
    66     for my $key ( $uri->query_param ) { 
    67         my @vals = $uri->query_param($key); 
    68         $c->req->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0]; 
    69     } 
    70 } 
    71  
    72 sub _prepare_headers  { 
    73     my($self, $c) = @_; 
    74  
    75     # Read headers from env 
    76     for my $header (keys %ENV) { 
    77         next unless $header =~ /^(?:HTTP|CONTENT|COOKIE)/i; 
    78         (my $field = $header) =~ s/^HTTPS?_//; 
    79         $c->req->headers->header($field => $ENV{$header}); 
    80     } 
    81 } 
    82  
    83 sub _prepare_cookie  { 
    84     my($self, $c) = @_; 
    85  
    86     if (my $header = $c->req->header('Cookie')) { 
    87         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } ); 
    88     } 
    89 } 
    90  
    91 sub _prepare_path  { 
    92     my($self, $c) = @_; 
    93  
    94     my $req    = $c->req; 
    95  
    96     my $scheme = $req->secure ? 'https' : 'http'; 
    97     my $host   = $ENV{HTTP_HOST}   || $ENV{SERVER_NAME}; 
    98     my $port   = $ENV{SERVER_PORT} || ( $req->secure ? 443 : 80 ); 
    99  
    100     my $base_path; 
    101     if (exists $ENV{REDIRECT_URL}) { 
    102         $base_path = $ENV{REDIRECT_URL}; 
    103         $base_path =~ s/$ENV{PATH_INFO}$//; 
    104     } else { 
    105         $base_path = $ENV{SCRIPT_NAME} || '/'; 
    106     } 
    107  
    108     my $path = $base_path . ($ENV{PATH_INFO} || ''); 
    109     $path =~ s{^/+}{}; 
    110  
    111     my $uri = URI->new; 
    112     $uri->scheme($scheme); 
    113     $uri->host($host); 
    114     $uri->port($port); 
    115     $uri->path($path); 
    116     $uri->query($ENV{QUERY_STRING}) if $ENV{QUERY_STRING}; 
    117  
    118     # sanitize the URI 
    119     $uri = $uri->canonical; 
    120     $req->uri($uri); 
    121  
    122     # set the base URI 
    123     # base must end in a slash 
    124     $base_path .= '/' unless $base_path =~ /\/$/; 
    125     my $base = $uri->clone; 
    126     $base->path_query($base_path); 
    127     $c->req->base($base); 
    128 } 
    129  
    130 sub _prepare_body  { 
    131     my($self, $c) = @_; 
    132  
    133     my $req = $c->req; 
    134  
    135     # TODO: catalyst のように prepare フェーズで処理せず、遅延評価できるようにする  
    136     $self->read_length($req->header('Content-Length') || 0); 
    137     my $type = $req->header('Content-Type'); 
    138  
    139     $req->http_body( HTTP::Body->new($type, $self->read_length) ); 
    140     $req->http_body->{tmpdir} = $self->upload_tmp if $self->upload_tmp; 
    141  
    142     if ($self->read_length > 0) { 
    143         while (my $buffer = $self->_read) { 
    144             $self->_prepare_body_chunk($c, $buffer); 
    145         } 
    146  
    147         # paranoia against wrong Content-Length header 
    148         my $remaining = $self->read_length - $self->read_position; 
    149         if ($remaining > 0) { 
    150             $self->_finalize_read; 
    151             die "Wrong Content-Length value: " . $self->read_length; 
    152         } 
    153     } 
    154 } 
    155  
    156 sub _prepare_body_chunk { 
    157     my($self, $c, $chunk) = @_; 
    158  
    159     my $req = $c->req; 
    160     $req->raw_body($req->raw_body . $chunk); 
    161     $req->http_body->add($chunk); 
    162 } 
    163  
    164 sub _prepare_parameters  { 
    165     my ($self, $c) = @_; 
    166  
    167     my $req = $c->req; 
    168     my $parameters = $req->parameters; 
    169  
    170     # We copy, no references 
    171     for my $name (keys %{ $req->query_parameters }) { 
    172         my $param = $req->query_parameters->{$name}; 
    173         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; 
    174         $parameters->{$name} = $param; 
    175     } 
    176  
    177     # Merge query and body parameters 
    178     for my $name (keys %{ $req->body_parameters }) { 
    179         my $param = $req->body_parameters->{$name}; 
    180         $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; 
    181         if ( my $old_param = $parameters->{$name} ) { 
    182             if ( ref $old_param eq 'ARRAY' ) { 
    183                 push @{ $parameters->{$name} }, 
    184                   ref $param eq 'ARRAY' ? @$param : $param; 
    185             } else { 
    186                 $parameters->{$name} = [ $old_param, $param ]; 
    187             } 
    188         } else { 
    189             $parameters->{$name} = $param; 
    190         } 
    191     } 
    192 } 
    193  
    194 sub _prepare_uploads  { 
    195     my($self, $c) = @_; 
    196  
    197     my $req     = $c->req; 
    198     my $uploads = $req->http_body->upload; 
    199     for my $name (keys %{ $uploads }) { 
    200         my $files = $uploads->{$name}; 
    201         $files = ref $files eq 'ARRAY' ? $files : [$files]; 
    202  
    203         my @uploads; 
    204         for my $upload (@{ $files }) { 
    205             my $u = HTTP::Engine::Request::Upload->new; 
    206             $u->headers(HTTP::Headers->new(%{ $upload->{headers} })); 
    207             $u->type($u->headers->content_type); 
    208             $u->tempname($upload->{tempname}); 
    209             $u->size($upload->{size}); 
    210             $u->filename($upload->{filename}); 
    211             push @uploads, $u; 
    212         } 
    213         $req->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0]; 
    214  
    215         # support access to the filename as a normal param 
    216         my @filenames = map { $_->{filename} } @uploads; 
    217         $req->parameters->{$name} =  @filenames > 1 ? \@filenames : $filenames[0]; 
    218     } 
    219 } 
    220  
    221 sub _prepare_read { 
    222     my $self = shift; 
    223     $self->read_position(0); 
    224 } 
    225  
    226 sub _read { 
    227     my ($self, $maxlength) = @_; 
    228  
    229     unless ($self->{_prepared_read}) { 
    230         $self->_prepare_read; 
    231         $self->{_prepared_read} = 1; 
    232     } 
    233  
    234     my $remaining = $self->read_length - $self->read_position; 
    235     $maxlength ||= $self->chunk_size; 
    236  
    237     # Are we done reading? 
    238     if ($remaining <= 0) { 
    239         $self->_finalize_read; 
    240         return; 
    241     } 
    242  
    243     my $readlen = ($remaining > $maxlength) ? $maxlength : $remaining; 
    244     my $rc = $self->_read_chunk(my $buffer, $readlen); 
    245     if (defined $rc) { 
    246         $self->read_position($self->read_position + $rc); 
    247         return $buffer; 
    248     } else { 
    249         die "Unknown error reading input: $!"; 
    250     } 
    251 } 
    252  
    253 sub _read_chunk { 
    254     my $self = shift; 
    255  
    256     if (blessed(*STDIN)) { 
    257         *STDIN->sysread(@_); 
    258     } else { 
    259         STDIN->sysread(@_); 
    260     } 
    261 } 
    262  
    263 sub _finalize_read { undef shift->{_prepared_read} } 
     19__PACKAGE__->meta->make_immutable; 
     20no Moose; 
    26421 
    265221; 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/RequestProcessor.pm

    r13596 r17154  
    1010use HTTP::Engine::RequestBuilder; 
    1111use HTTP::Engine::ResponseWriter; 
     12 
     13with qw(HTTP::Engine::Role::RequestProcessor); 
    1214 
    1315 
     
    3739 
    3840has request_builder => ( 
    39     is      => 'ro', 
    40     isa     => 'HTTP::Engine::RequestBuilder', 
    41     lazy    => 1, 
    42     default => sub { 
    43         HTTP::Engine::RequestBuilder->new(); 
    44     }, 
     41    is       => 'ro', 
     42    does     => 'HTTP::Engine::Role::RequestBuilder', 
     43    required => 1, 
    4544); 
    4645 
    4746has response_writer => ( 
    4847    is       => 'ro', 
    49     isa      => 'HTTP::Engine::ResponseWriter', 
     48    does     => 'HTTP::Engine::Role::ResponseWriter', 
    5049    required => 1, 
    5150); 
     
    5756); 
    5857 
     58__PACKAGE__->meta->make_immutable; 
    5959no Moose; 
    6060 
    6161my $rp; 
    6262sub handle_request { 
    63     my $self = shift; 
     63    my ( $self, %args ) = @_; 
    6464 
    6565    my $context = $self->context_class->new( 
    66         req    => $self->request_class->new(), 
    67         res    => $self->response_class->new(), 
     66        req => $args{req} || $self->request_class->new( 
     67            request_builder => $self->request_builder, 
     68            ($args{request_args} ? %{ $args{request_args} } : ()), 
     69        ), 
     70        res => $args{res} || $self->response_class->new( 
     71            ($args{response_args} ? %{ $args{response_args} } : ()), 
     72        ), 
     73        %args, 
    6874    ); 
    6975 
    70     eval { 
    71         $self->request_builder->prepare($context); 
    72     }; 
    73     if (my $e = $@) { 
    74         print STDERR $e; 
    75  
    76         $context->res->status(500); 
    77         $context->res->body('internal server error'); 
    78     } 
    79  
    8076    my $ret = eval { 
    81         local *STDOUT; 
    82         local *STDIN; 
    8377        $rp = sub { $self }; 
    8478        call_handler($context); 
     
    8680    if (my $e = $@) { 
    8781        print STDERR $e; 
     82        $context->res->status(500); 
     83        $context->res->body('internal server error'); 
    8884    } 
     85 
    8986    $self->response_writer->finalize($context); 
    9087 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Response.pm

    r13975 r17154  
    66use HTTP::Engine::Types::Core qw( Header ); 
    77use File::stat; 
     8 
     9# Moose role merging is borked with attributes 
     10#with qw(HTTP::Engine::Response); 
    811 
    912has body => ( 
     
    134137} 
    135138 
     139sub as_http_response { 
     140    my $self = shift; 
     141 
     142    require HTTP::Response; 
     143    HTTP::Response->new( 
     144        $self->status, 
     145        '', 
     146        $self->headers->clone, 
     147        $self->body, # FIXME slurp file handles 
     148    ); 
     149} 
     150 
    136151__PACKAGE__->meta->make_immutable; 
    137152 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/ResponseWriter.pm

    r11743 r17154  
    44use Carp; 
    55use HTTP::Status (); 
     6 
     7with qw(HTTP::Engine::Role::ResponseWriter); 
    68 
    79has 'should_write_response_line' => ( 
     
    1719); 
    1820 
     21__PACKAGE__->meta->make_immutable; 
    1922no Moose; 
    2023 
     
    2326sub finalize { 
    2427    my($self, $c) = @_; 
     28 
     29    local *STDOUT = $c->req->_connection->{output_handle}; 
    2530    croak "argument missing" unless $c; 
    2631 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Role/Interface.pm

    r13358 r17154  
    1414); 
    1515 
     16sub request_processor_class { 
     17    my $self = shift; 
     18    $self->_default_class("RequestProcessor"); 
     19} 
     20 
     21sub request_processor_traits { 
     22    my $self = shift; 
     23    $self->_default_trait("RequestProcessor"); 
     24} 
     25 
    1626has request_processor => ( 
    1727    is         => 'ro', 
    18     isa        => 'HTTP::Engine::RequestProcessor', 
     28    does       => 'HTTP::Engine::Role::RequestProcessor', 
    1929    lazy_build => 1, 
    2030    handles    => [qw/handle_request load_plugins/], 
     
    2434    my $self = shift; 
    2535 
    26     HTTP::Engine::RequestProcessor->new( 
     36    $self->_class_with_roles("request_processor")->new( 
    2737        handler                    => $self->request_handler, 
    28         response_writer            => HTTP::Engine::ResponseWriter->new( 
    29             should_write_response_line => $self->should_write_response_line, 
    30         ), 
     38        request_builder            => $self->request_builder, 
     39        response_writer            => $self->response_writer, 
    3140    ); 
     41} 
     42 
     43 
     44sub request_builder_class { 
     45    my $self = shift; 
     46    $self->_default_class("RequestBuilder"); 
     47} 
     48 
     49sub request_builder_traits { 
     50    my $self = shift; 
     51    $self->_default_trait("RequestBuilder"); 
     52} 
     53 
     54has request_builder => ( 
     55    is         => 'ro', 
     56    does       => 'HTTP::Engine::Role::RequestBuilder', 
     57    lazy_build => 1, 
     58); 
     59 
     60sub _build_request_builder { 
     61    my $self = shift; 
     62 
     63    $self->_class_with_roles("request_builder")->new; 
     64} 
     65 
     66 
     67sub response_writer_class { 
     68    my $self = shift; 
     69    $self->_default_class("ResponseWriter"); 
     70} 
     71 
     72sub response_writer_traits { 
     73    my $self = shift; 
     74    $self->_default_trait("ResponseWriter"); 
     75} 
     76 
     77has response_writer => ( 
     78    is         => 'ro', 
     79    does       => 'HTTP::Engine::Role::ResponseWriter', 
     80    lazy_build => 1, 
     81); 
     82 
     83sub _build_response_writer { 
     84    my $self = shift; 
     85 
     86    $self->_class_with_roles("response_writer")->new( 
     87        should_write_response_line => $self->should_write_response_line, 
     88    ); 
     89} 
     90 
     91sub _default_class { 
     92    my ( $self, $category ) = @_; 
     93 
     94    if ( my $class = $self->_default_package($category) ) { 
     95        if ( $class->meta->isa("Moose::Meta::Class") ) { 
     96            return $class; 
     97        } 
     98    } 
     99 
     100    return "HTTP::Engine::$category"; 
     101} 
     102 
     103sub _default_trait { 
     104    my ( $self, $category ) = @_; 
     105 
     106    grep { $_->meta->isa("Moose::Meta::Role") } $self->_default_package($category); 
     107} 
     108 
     109sub _default_package { 
     110    my ( $self, $category ) = @_; 
     111 
     112    my $name = join( "::", $self->meta->name, $category ); 
     113 
     114    my $e; 
     115 
     116    # don't overwrite external $@ 
     117    { 
     118        local $@; 
     119        if ( eval { Class::MOP::load_class($name) } ) { 
     120            return $name; 
     121        } else { 
     122            ( my $file = "$name.pm" ) =~ s{::}{/}g; 
     123            if ( $@ =~ /Can't locate \Q$file\E in \@INC/ ) { 
     124                return; 
     125            } else { 
     126                $e = $@; 
     127            } 
     128        } 
     129    } 
     130 
     131    die $e; 
     132} 
     133 
     134my %anon_classes; 
     135sub _class_with_roles { 
     136    my ( $self, $type ) = @_; 
     137 
     138    my $m_class  = "${type}_class"; 
     139    my $m_traits = "${type}_traits"; 
     140 
     141    my $class = $self->$m_class; 
     142 
     143    if ( my @roles = $self->$m_traits ) { 
     144        my $class_key = join("\0", $class, sort @roles); 
     145 
     146        my $metaclass = $anon_classes{$class_key} ||= $self->_create_anon_class($class, @roles); 
     147 
     148        return $metaclass->name; 
     149    } else { 
     150        return $class; 
     151    } 
     152} 
     153 
     154sub _create_anon_class { 
     155    my ( $self, $class, @roles ) = @_; 
     156 
     157    # create an anonymous subclass 
     158    my $anon = $class->meta->create_anon_class( 
     159        superclasses => [ $class ], 
     160    ); 
     161 
     162    # apply the roles to the class 
     163    Moose::Util::apply_all_roles( $anon->name, @roles ); 
     164 
     165    return $anon; 
    32166} 
    33167 
  • lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine/Types/Core.pm

    r13357 r17154  
    88use Class::MOP; 
    99use URI; 
     10use URI::WithBase; 
     11use URI::QueryParam; 
    1012use HTTP::Headers; 
    1113 
     
    2729}; 
    2830 
    29 class_type Uri, { class => "URI" }; 
     31class_type Uri, { class => "URI::WithBase" }; 
    3032 
    31 coerce Uri, from Str => via { URI->new($_) }; 
     33coerce Uri, from Str => via { URI::WithBase->new($_) }; 
    3234 
    3335class_type Header, { class => "HTTP::Headers" }; 
  • lang/perl/HTTP-Engine/trunk/t/020_interface/test.t

    r17075 r17154  
    1919            request_handler => sub { 
    2020                my $c = shift; 
     21                eval $block->code; 
     22                die $@ if $@; 
    2123                $c->res->header( 'X-Req-Test' => "ping" ); 
    2224                $c->res->body('OK!'); 
     
    3941 
    4042=== 
     43--- code 
    4144--- response 
    4245Content-Length: 3 
     
    4649 
    4750OK! 
     51 
     52=== $c->req->base 
     53--- code 
     54$c->res->header('X-Req-Base' => $c->req->base); 
     55--- response 
     56Content-Length: 3 
     57Content-Type: text/html 
     58Status: 200 
     59X-Req-Base: http://localhost/ 
     60X-Req-Test: ping 
     61 
     62OK! 
     63 
  • lang/perl/HTTP-Engine/trunk/t/020_interface/test_upload.t

    r16873 r17154  
    3636            request_handler => sub { 
    3737                my $c = shift; 
    38                 $c->res->header( 'X-Req-Base' => $c->req->base ); 
    3938                $c->res->body('OK!'); 
    4039                return unless $body; 
     
    9897Content-Type: text/html 
    9998Status: 200 
    100 X-Req-Base: http://localhost/ 
    10199 
    102100OK! 
     
    107105Content-Type: text/html 
    108106Status: 200 
    109 X-Req-Base: http://localhost/ 
    110107 
    111108OK! 
  • lang/perl/HTTP-Engine/trunk/tools/benchmark.pl

    r13342 r17154  
    11use strict; 
    22use warnings; 
    3 use Benchmark qw/timethese timeit timestr/; 
     3use Benchmark qw/countit timethese timeit timestr/; 
    44use HTTP::Engine; 
    55use IO::Scalar; 
     
    2323 
    2424tie *STDOUT, 'IO::Scalar', \my $out; 
    25 my $t = timeit 10_000 => sub { 
     25my $t = countit 2 => sub { 
    2626    $engine->run; 
    2727};