[catagits/Catalyst-Runtime.git] / lib / Catalyst / Engine.pm

package Catalyst::Engine;

use Moose;
with 'MooseX::Emulate::Class::Accessor::Fast';

use CGI::Simple::Cookie;
use Data::Dump qw/dump/;
use Errno 'EWOULDBLOCK';
use HTML::Entities;
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
use Scalar::Util ();

# input position and length
has read_length => (is => 'rw');
has read_position => (is => 'rw');

no Moose;

# Amount of data to read from input on each pass
our $CHUNKSIZE = 64 * 1024;

=head1 NAME

Catalyst::Engine - The Catalyst Engine

=head1 SYNOPSIS

See L<Catalyst>.

=head1 DESCRIPTION

=head1 METHODS


=head2 $self->finalize_body($c)

Finalize body.  Prints the response output.

=cut

sub finalize_body {
    my ( $self, $c ) = @_;
    my $body = $c->response->body;
    no warnings 'uninitialized';
    if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
        while ( !eof $body ) {
            read $body, my ($buffer), $CHUNKSIZE;
            last unless $self->write( $c, $buffer );
        }
        close $body;
    }
    else {
        $self->write( $c, $body );
    }
}

=head2 $self->finalize_cookies($c)

Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
response headers.

=cut

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

    my @cookies;
    my $response = $c->response;

    foreach my $name (keys %{ $response->cookies }) {

        my $val = $response->cookies->{$name};

        my $cookie = (
            Scalar::Util::blessed($val)
            ? $val
            : CGI::Simple::Cookie->new(
                -name    => $name,
                -value   => $val->{value},
                -expires => $val->{expires},
                -domain  => $val->{domain},
                -path    => $val->{path},
                -secure  => $val->{secure} || 0
            )
        );

        push @cookies, $cookie->as_string;
    }

    for my $cookie (@cookies) {
        $response->headers->push_header( 'Set-Cookie' => $cookie );
    }
}

=head2 $self->finalize_error($c)

Output an apropriate error message, called if there's an error in $c
after the dispatch has finished. Will output debug messages if Catalyst
is in debug mode, or a `please come back later` message otherwise.

=cut

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

    $c->res->content_type('text/html; charset=utf-8');
    my $name = $c->config->{name} || join(' ', split('::', ref $c));

    my ( $title, $error, $infos );
    if ( $c->debug ) {

        # For pretty dumps
        $error = join '', map {
                '<p><code class="error">'
              . encode_entities($_)
              . '</code></p>'
        } @{ $c->error };
        $error ||= 'No output';
        $error = qq{<pre wrap="">$error</pre>};
        $title = $name = "$name on Catalyst $Catalyst::VERSION";
        $name  = "<h1>$name</h1>";

        # Don't show context in the dump
        delete $c->req->{_context};
        delete $c->res->{_context};

        # Don't show body parser in the dump
        delete $c->req->{_body};

        my @infos;
        my $i = 0;
        for my $dump ( $c->dump_these ) {
            my $name  = $dump->[0];
            my $value = encode_entities( dump( $dump->[1] ));
            push @infos, sprintf <<"EOF", $name, $value;
<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
<div id="dump_$i">
    <pre wrap="">%s</pre>
</div>
EOF
            $i++;
        }
        $infos = join "\n", @infos;
    }
    else {
        $title = $name;
        $error = '';
        $infos = <<"";
<pre>
(en) Please come back later
(fr) SVP veuillez revenir plus tard
(de) Bitte versuchen sie es spaeter nocheinmal
(at) Konnten's bitt'schoen spaeter nochmal reinschauen
(no) Vennligst prov igjen senere
(dk) Venligst prov igen senere
(pl) Prosze sprobowac pozniej
</pre>

        $name = '';
    }
    $c->res->body( <<"" );
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
    <meta http-equiv="Content-Language" content="en" />
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
    <title>$title</title>
    <script type="text/javascript">
        <!--
        function toggleDump (dumpElement) {
            var e = document.getElementById( dumpElement );
            if (e.style.display == "none") {
                e.style.display = "";
            }
            else {
                e.style.display = "none";
            }
        }
        -->
    </script>
    <style type="text/css">
        body {
            font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
                         Tahoma, Arial, helvetica, sans-serif;
            color: #333;
            background-color: #eee;
            margin: 0px;
            padding: 0px;
        }
        :link, :link:hover, :visited, :visited:hover {
            color: #000;
        }
        div.box {
            position: relative;
            background-color: #ccc;
            border: 1px solid #aaa;
            padding: 4px;
            margin: 10px;
        }
        div.error {
            background-color: #cce;
            border: 1px solid #755;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
        }
        div.infos {
            background-color: #eee;
            border: 1px solid #575;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
        }
        div.name {
            background-color: #cce;
            border: 1px solid #557;
            padding: 8px;
            margin: 4px;
        }
        code.error {
            display: block;
            margin: 1em 0;
            overflow: auto;
        }
        div.name h1, div.error p {
            margin: 0;
        }
        h2 {
            margin-top: 0;
            margin-bottom: 10px;
            font-size: medium;
            font-weight: bold;
            text-decoration: underline;
        }
        h1 {
            font-size: medium;
            font-weight: normal;
        }
        /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
        /* Browser specific (not valid) styles to make preformatted text wrap */
        pre { 
            white-space: pre-wrap;       /* css-3 */
            white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
            white-space: -pre-wrap;      /* Opera 4-6 */
            white-space: -o-pre-wrap;    /* Opera 7 */
            word-wrap: break-word;       /* Internet Explorer 5.5+ */
        }
    </style>
</head>
<body>
    <div class="box">
        <div class="error">$error</div>
        <div class="infos">$infos</div>
        <div class="name">$name</div>
    </div>
</body>
</html>


    # Trick IE
    $c->res->{body} .= ( ' ' x 512 );

    # Return 500
    $c->res->status(500);
}

=head2 $self->finalize_headers($c)

Abstract method, allows engines to write headers to response

=cut

sub finalize_headers { }

=head2 $self->finalize_read($c)

=cut

sub finalize_read { }

=head2 $self->finalize_uploads($c)

Clean up after uploads, deleting temp files.

=cut

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

    my $request = $c->request;
    foreach my $key (keys %{ $request->uploads }) {
        my $upload = $request->uploads->{$key};
        unlink grep { -e $_ } map { $_->tempname }
          (ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
    }

}

=head2 $self->prepare_body($c)

sets up the L<Catalyst::Request> object body using L<HTTP::Body>

=cut

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

    if ( my $length = $self->read_length ) {
        my $request = $c->request;
        unless ( $request->{_body} ) {
            my $type = $request->header('Content-Type');
            $request->{_body} = HTTP::Body->new( $type, $length );
            $request->{_body}->{tmpdir} = $c->config->{uploadtmp}
              if exists $c->config->{uploadtmp};
        }
        
        while ( my $buffer = $self->read($c) ) {
            $c->prepare_body_chunk($buffer);
        }

        # paranoia against wrong Content-Length header
        my $remaining = $length - $self->read_position;
        if ( $remaining > 0 ) {
            $self->finalize_read($c);
            Catalyst::Exception->throw(
                "Wrong Content-Length value: $length" );
        }
    }
    else {
        # Defined but will cause all body code to be skipped
        $c->request->{_body} = 0;
    }
}

=head2 $self->prepare_body_chunk($c)

Add a chunk to the request body.

=cut

sub prepare_body_chunk {
    my ( $self, $c, $chunk ) = @_;

    $c->request->{_body}->add($chunk);
}

=head2 $self->prepare_body_parameters($c)

Sets up parameters from body. 

=cut

sub prepare_body_parameters {
    my ( $self, $c ) = @_;
    
    return unless $c->request->{_body};
    
    $c->request->body_parameters( $c->request->{_body}->param );
}

=head2 $self->prepare_connection($c)

Abstract method implemented in engines.

=cut

sub prepare_connection { }

=head2 $self->prepare_cookies($c)

Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.

=cut

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

    if ( my $header = $c->request->header('Cookie') ) {
        $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
    }
}

=head2 $self->prepare_headers($c)

=cut

sub prepare_headers { }

=head2 $self->prepare_parameters($c)

sets up parameters from query and post parameters.

=cut

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

    my $request = $c->request;
    my $parameters = $request->parameters;
    my $body_parameters = $request->body_parameters;
    my $query_parameters = $request->query_parameters;
    # We copy, no references
    foreach my $name (keys %$query_parameters) {
        my $param = $query_parameters->{$name};
        $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
    }

    # Merge query and body parameters
    foreach my $name (keys %$body_parameters) {
        my $param = $body_parameters->{$name};
        my @values = ref $param eq 'ARRAY' ? @$param : ($param);
        if ( my $existing = $parameters->{$name} ) {
          unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
        }
        $parameters->{$name} = @values > 1 ? \@values : $values[0];
    }
}

=head2 $self->prepare_path($c)

abstract method, implemented by engines.

=cut

sub prepare_path { }

=head2 $self->prepare_request($c)

=head2 $self->prepare_query_parameters($c)

process the query string and extract query parameters.

=cut

sub prepare_query_parameters {
    my ( $self, $c, $query_string ) = @_;
    
    # Check for keywords (no = signs)
    # (yes, index() is faster than a regex :))
    if ( index( $query_string, '=' ) < 0 ) {
        $c->request->query_keywords( $self->unescape_uri($query_string) );
        return;
    }

    my %query;

    # replace semi-colons
    $query_string =~ s/;/&/g;
    
    my @params = split /&/, $query_string;

    for my $item ( @params ) {
        
        my ($param, $value) 
            = map { $self->unescape_uri($_) }
              split( /=/, $item, 2 );
          
        $param = $self->unescape_uri($item) unless defined $param;
        
        if ( exists $query{$param} ) {
            if ( ref $query{$param} ) {
                push @{ $query{$param} }, $value;
            }
            else {
                $query{$param} = [ $query{$param}, $value ];
            }
        }
        else {
            $query{$param} = $value;
        }
    }

    $c->request->query_parameters( \%query );
}

=head2 $self->prepare_read($c)

prepare to read from the engine.

=cut

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

    # Initialize the read position
    $self->read_position(0);
    
    # Initialize the amount of data we think we need to read
    $self->read_length( $c->request->header('Content-Length') || 0 );
}

=head2 $self->prepare_request(@arguments)

Populate the context object from the request object.

=cut

sub prepare_request { }

=head2 $self->prepare_uploads($c)

=cut

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

    my $request = $c->request;
    return unless $request->{_body};

    my $uploads = $request->{_body}->upload;
    my $parameters = $request->parameters;
    foreach my $name (keys %$uploads) {
        my $files = $uploads->{$name};
        my @uploads;
        for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
            my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
            my $u = Catalyst::Request::Upload->new
              (
               size => $upload->{size},
               type => $headers->content_type,
               headers => $headers,
               tempname => $upload->{tempname},
               filename => $upload->{filename},
              );
            push @uploads, $u;
        }
        $request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];

        # support access to the filename as a normal param
        my @filenames = map { $_->{filename} } @uploads;
        # append, if there's already params with this name
        if (exists $parameters->{$name}) {
            if (ref $parameters->{$name} eq 'ARRAY') {
                push @{ $parameters->{$name} }, @filenames;
            }
            else {
                $parameters->{$name} = [ $parameters->{$name}, @filenames ];
            }
        }
        else {
            $parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
        }
    }
}

=head2 $self->prepare_write($c)

Abstract method. Implemented by the engines.

=cut

sub prepare_write { }

=head2 $self->read($c, [$maxlength])

=cut

sub read {
    my ( $self, $c, $maxlength ) = @_;

    my $remaining = $self->read_length - $self->read_position;
    $maxlength ||= $CHUNKSIZE;

    # Are we done reading?
    if ( $remaining <= 0 ) {
        $self->finalize_read($c);
        return;
    }

    my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
    my $rc = $self->read_chunk( $c, my $buffer, $readlen );
    if ( defined $rc ) {
        $self->read_position( $self->read_position + $rc );
        return $buffer;
    }
    else {
        Catalyst::Exception->throw(
            message => "Unknown error reading input: $!" );
    }
}

=head2 $self->read_chunk($c, $buffer, $length)

Each engine inplements read_chunk as its preferred way of reading a chunk
of data.

=cut

sub read_chunk { }

=head2 $self->read_length

The length of input data to be read.  This is obtained from the Content-Length
header.

=head2 $self->read_position

The amount of input data that has already been read.

=head2 $self->run($c)

Start the engine. Implemented by the various engine classes.

=cut

sub run { }

=head2 $self->write($c, $buffer)

Writes the buffer to the client.

=cut

sub write {
    my ( $self, $c, $buffer ) = @_;

    unless ( $self->{_prepared_write} ) {
        $self->prepare_write($c);
        $self->{_prepared_write} = 1;
    }
    
    my $len   = length($buffer);
    my $wrote = syswrite STDOUT, $buffer;
    
    if ( !defined $wrote && $! == EWOULDBLOCK ) {
        # Unable to write on the first try, will retry in the loop below
        $wrote = 0;
    }
    
    if ( defined $wrote && $wrote < $len ) {
        # We didn't write the whole buffer
        while (1) {
            my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
            if ( defined $ret ) {
                $wrote += $ret;
            }
            else {
                next if $! == EWOULDBLOCK;
                return;
            }
            
            last if $wrote >= $len;
        }
    }
    
    return $wrote;
}

=head2 $self->unescape_uri($uri)

Unescapes a given URI using the most efficient method available.  Engines such
as Apache may implement this using Apache's C-based modules, for example.

=cut

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

    $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;

    return $str;
}

=head2 $self->finalize_output

<obsolete>, see finalize_body

=head1 AUTHORS

Sebastian Riedel, <sri@cpan.org>

Andy Grundman, <andy@hybridized.org>

=head1 COPYRIGHT

This program is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;
Commit	Line	Data
fc7ec1d9	1	package Catalyst::Engine;
fc7ec1d9	2
7fa2c9c1	3	use Moose;
	4	with 'MooseX::Emulate::Class::Accessor::Fast';
	5
fa32ac82	6	use CGI::Simple::Cookie;
f63c03e4	7	use Data::Dump qw/dump/;
d04b2ffd	8	use Errno 'EWOULDBLOCK';
fc7ec1d9	9	use HTML::Entities;
fbcc39ad	10	use HTTP::Body;
fc7ec1d9	11	use HTTP::Headers;
e0616220	12	use URI::QueryParam;
2832cb5d	13	use Scalar::Util ();
fbcc39ad	14
fbcc39ad	15	# input position and length
7fa2c9c1	16	has read_length => (is => 'rw');
7fa2c9c1	17	has read_position => (is => 'rw');
fbcc39ad	18
0fc2d522	19	no Moose;
0fc2d522	20
4bd82c41	21	# Amount of data to read from input on each pass
4bb8bd62	22	our $CHUNKSIZE = 64 * 1024;
4bd82c41	23
fc7ec1d9	24	=head1 NAME
	25
	26	Catalyst::Engine - The Catalyst Engine
	27
	28	=head1 SYNOPSIS
	29
	30	See L<Catalyst>.
	31
	32	=head1 DESCRIPTION
	33
23f9d934	34	=head1 METHODS
fc7ec1d9	35
cd3bb248	36
b5ecfcf0	37	=head2 $self->finalize_body($c)
06e1b616	38
fbcc39ad	39	Finalize body. Prints the response output.
06e1b616	40
	41	=cut
	42
fbcc39ad	43	sub finalize_body {
fbcc39ad	44	my ( $self, $c ) = @_;
7257e9db	45	my $body = $c->response->body;
f9b6d612	46	no warnings 'uninitialized';
f9b6d612	47	if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
7257e9db	48	while ( !eof $body ) {
4c423abf	49	read $body, my ($buffer), $CHUNKSIZE;
6484fba0	50	last unless $self->write( $c, $buffer );
f4a57de4	51	}
7257e9db	52	close $body;
f4a57de4	53	}
f4a57de4	54	else {
7257e9db	55	$self->write( $c, $body );
f4a57de4	56	}
fbcc39ad	57	}
6dc87a0f	58
b5ecfcf0	59	=head2 $self->finalize_cookies($c)
6dc87a0f	60
fa32ac82	61	Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
fa32ac82	62	response headers.
4ab87e27	63
6dc87a0f	64	=cut
	65
	66	sub finalize_cookies {
fbcc39ad	67	my ( $self, $c ) = @_;
6dc87a0f	68
fbcc39ad	69	my @cookies;
7fa2c9c1	70	my $response = $c->response;
c82ed742	71
91772de9	72	foreach my $name (keys %{ $response->cookies }) {
	73
	74	my $val = $response->cookies->{$name};
fbcc39ad	75
2832cb5d	76	my $cookie = (
	77	Scalar::Util::blessed($val)
	78	? $val
	79	: CGI::Simple::Cookie->new(
	80	-name => $name,
	81	-value => $val->{value},
	82	-expires => $val->{expires},
	83	-domain => $val->{domain},
	84	-path => $val->{path},
	85	-secure => $val->{secure} \|\| 0
	86	)
6dc87a0f	87	);
6dc87a0f	88
fbcc39ad	89	push @cookies, $cookie->as_string;
6dc87a0f	90	}
6dc87a0f	91
b39840da	92	for my $cookie (@cookies) {
7fa2c9c1	93	$response->headers->push_header( 'Set-Cookie' => $cookie );
fbcc39ad	94	}
fbcc39ad	95	}
969647fd	96
b5ecfcf0	97	=head2 $self->finalize_error($c)
969647fd	98
4ab87e27	99	Output an apropriate error message, called if there's an error in $c
	100	after the dispatch has finished. Will output debug messages if Catalyst
	101	is in debug mode, or a `please come back later` message otherwise.
	102
969647fd	103	=cut
	104
	105	sub finalize_error {
fbcc39ad	106	my ( $self, $c ) = @_;
969647fd	107
7299a7b4	108	$c->res->content_type('text/html; charset=utf-8');
34d28dfd	109	my $name = $c->config->{name} \|\| join(' ', split('::', ref $c));
969647fd	110
	111	my ( $title, $error, $infos );
	112	if ( $c->debug ) {
62d9b030	113
62d9b030	114	# For pretty dumps
b5ecfcf0	115	$error = join '', map {
	116	'<p><code class="error">'
	117	. encode_entities($_)
	118	. '</code></p>'
	119	} @{ $c->error };
969647fd	120	$error \|\|= 'No output';
2666dd3b	121	$error = qq{<pre wrap="">$error</pre>};
969647fd	122	$title = $name = "$name on Catalyst $Catalyst::VERSION";
d82cc9ae	123	$name = "<h1>$name</h1>";
fbcc39ad	124
	125	# Don't show context in the dump
	126	delete $c->req->{_context};
	127	delete $c->res->{_context};
	128
	129	# Don't show body parser in the dump
	130	delete $c->req->{_body};
	131
c6ef5e69	132	my @infos;
c6ef5e69	133	my $i = 0;
c6ef5e69	134	for my $dump ( $c->dump_these ) {
c6ef5e69	135	my $name = $dump->[0];
f63c03e4	136	my $value = encode_entities( dump( $dump->[1] ));
c6ef5e69	137	push @infos, sprintf <<"EOF", $name, $value;
9619f23c	138	<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
c6ef5e69	139	<div id="dump_$i">
2666dd3b	140	<pre wrap="">%s</pre>
c6ef5e69	141	</div>
	142	EOF
	143	$i++;
	144	}
	145	$infos = join "\n", @infos;
969647fd	146	}
	147	else {
	148	$title = $name;
	149	$error = '';
	150	$infos = <<"";
	151	<pre>
	152	(en) Please come back later
0c2b4ac0	153	(fr) SVP veuillez revenir plus tard
969647fd	154	(de) Bitte versuchen sie es spaeter nocheinmal
d82cc9ae	155	(at) Konnten's bitt'schoen spaeter nochmal reinschauen
969647fd	156	(no) Vennligst prov igjen senere
d82cc9ae	157	(dk) Venligst prov igen senere
d82cc9ae	158	(pl) Prosze sprobowac pozniej
969647fd	159	</pre>
	160
	161	$name = '';
	162	}
e060fe05	163	$c->res->body( <<"" );
7299a7b4	164	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	165	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
	166	<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
969647fd	167	<head>
7299a7b4	168	<meta http-equiv="Content-Language" content="en" />
7299a7b4	169	<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
969647fd	170	<title>$title</title>
7299a7b4	171	<script type="text/javascript">
c6ef5e69	172	<!--
c6ef5e69	173	function toggleDump (dumpElement) {
7299a7b4	174	var e = document.getElementById( dumpElement );
	175	if (e.style.display == "none") {
	176	e.style.display = "";
c6ef5e69	177	}
c6ef5e69	178	else {
7299a7b4	179	e.style.display = "none";
c6ef5e69	180	}
	181	}
	182	-->
	183	</script>
969647fd	184	<style type="text/css">
	185	body {
	186	font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
	187	Tahoma, Arial, helvetica, sans-serif;
34d28dfd	188	color: #333;
969647fd	189	background-color: #eee;
	190	margin: 0px;
	191	padding: 0px;
	192	}
c6ef5e69	193	:link, :link:hover, :visited, :visited:hover {
34d28dfd	194	color: #000;
c6ef5e69	195	}
969647fd	196	div.box {
9619f23c	197	position: relative;
969647fd	198	background-color: #ccc;
	199	border: 1px solid #aaa;
	200	padding: 4px;
	201	margin: 10px;
969647fd	202	}
969647fd	203	div.error {
34d28dfd	204	background-color: #cce;
969647fd	205	border: 1px solid #755;
	206	padding: 8px;
	207	margin: 4px;
	208	margin-bottom: 10px;
969647fd	209	}
969647fd	210	div.infos {
34d28dfd	211	background-color: #eee;
969647fd	212	border: 1px solid #575;
	213	padding: 8px;
	214	margin: 4px;
	215	margin-bottom: 10px;
969647fd	216	}
969647fd	217	div.name {
34d28dfd	218	background-color: #cce;
969647fd	219	border: 1px solid #557;
	220	padding: 8px;
	221	margin: 4px;
969647fd	222	}
7f8e0078	223	code.error {
	224	display: block;
	225	margin: 1em 0;
	226	overflow: auto;
7f8e0078	227	}
9619f23c	228	div.name h1, div.error p {
	229	margin: 0;
	230	}
	231	h2 {
	232	margin-top: 0;
	233	margin-bottom: 10px;
	234	font-size: medium;
	235	font-weight: bold;
	236	text-decoration: underline;
	237	}
	238	h1 {
	239	font-size: medium;
	240	font-weight: normal;
	241	}
2666dd3b	242	/* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
2666dd3b	243	/* Browser specific (not valid) styles to make preformatted text wrap */
ac5c933b	244	pre {
2666dd3b	245	white-space: pre-wrap; /* css-3 */
	246	white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
	247	white-space: -pre-wrap; /* Opera 4-6 */
	248	white-space: -o-pre-wrap; /* Opera 7 */
	249	word-wrap: break-word; /* Internet Explorer 5.5+ */
	250	}
969647fd	251	</style>
	252	</head>
	253	<body>
	254	<div class="box">
	255	<div class="error">$error</div>
	256	<div class="infos">$infos</div>
	257	<div class="name">$name</div>
	258	</div>
	259	</body>
	260	</html>
	261
d82cc9ae	262
	263	# Trick IE
	264	$c->res->{body} .= ( ' ' x 512 );
	265
	266	# Return 500
33117422	267	$c->res->status(500);
969647fd	268	}
969647fd	269
b5ecfcf0	270	=head2 $self->finalize_headers($c)
fc7ec1d9	271
4ab87e27	272	Abstract method, allows engines to write headers to response
4ab87e27	273
fc7ec1d9	274	=cut
	275
	276	sub finalize_headers { }
	277
b5ecfcf0	278	=head2 $self->finalize_read($c)
fc7ec1d9	279
	280	=cut
	281
878b821c	282	sub finalize_read { }
fc7ec1d9	283
b5ecfcf0	284	=head2 $self->finalize_uploads($c)
fc7ec1d9	285
4ab87e27	286	Clean up after uploads, deleting temp files.
4ab87e27	287
fc7ec1d9	288	=cut
fc7ec1d9	289
fbcc39ad	290	sub finalize_uploads {
fbcc39ad	291	my ( $self, $c ) = @_;
99fe1710	292
7fa2c9c1	293	my $request = $c->request;
91772de9	294	foreach my $key (keys %{ $request->uploads }) {
91772de9	295	my $upload = $request->uploads->{$key};
7fa2c9c1	296	unlink grep { -e $_ } map { $_->tempname }
7fa2c9c1	297	(ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
c85ff642	298	}
7fa2c9c1	299
fc7ec1d9	300	}
fc7ec1d9	301
b5ecfcf0	302	=head2 $self->prepare_body($c)
fc7ec1d9	303
4ab87e27	304	sets up the L<Catalyst::Request> object body using L<HTTP::Body>
4ab87e27	305
fc7ec1d9	306	=cut
fc7ec1d9	307
fbcc39ad	308	sub prepare_body {
fbcc39ad	309	my ( $self, $c ) = @_;
99fe1710	310
878b821c	311	if ( my $length = $self->read_length ) {
7fa2c9c1	312	my $request = $c->request;
	313	unless ( $request->{_body} ) {
	314	my $type = $request->header('Content-Type');
	315	$request->{_body} = HTTP::Body->new( $type, $length );
	316	$request->{_body}->{tmpdir} = $c->config->{uploadtmp}
847e3257	317	if exists $c->config->{uploadtmp};
847e3257	318	}
ac5c933b	319
4f5ebacd	320	while ( my $buffer = $self->read($c) ) {
4f5ebacd	321	$c->prepare_body_chunk($buffer);
fbcc39ad	322	}
fdb3773e	323
fdb3773e	324	# paranoia against wrong Content-Length header
847e3257	325	my $remaining = $length - $self->read_position;
34d28dfd	326	if ( $remaining > 0 ) {
fdb3773e	327	$self->finalize_read($c);
34d28dfd	328	Catalyst::Exception->throw(
847e3257	329	"Wrong Content-Length value: $length" );
fdb3773e	330	}
fc7ec1d9	331	}
847e3257	332	else {
	333	# Defined but will cause all body code to be skipped
	334	$c->request->{_body} = 0;
	335	}
fc7ec1d9	336	}
fc7ec1d9	337
b5ecfcf0	338	=head2 $self->prepare_body_chunk($c)
4bd82c41	339
4ab87e27	340	Add a chunk to the request body.
4ab87e27	341
4bd82c41	342	=cut
	343
	344	sub prepare_body_chunk {
	345	my ( $self, $c, $chunk ) = @_;
4f5ebacd	346
4f5ebacd	347	$c->request->{_body}->add($chunk);
4bd82c41	348	}
4bd82c41	349
b5ecfcf0	350	=head2 $self->prepare_body_parameters($c)
06e1b616	351
ac5c933b	352	Sets up parameters from body.
4ab87e27	353
06e1b616	354	=cut
06e1b616	355
fbcc39ad	356	sub prepare_body_parameters {
fbcc39ad	357	my ( $self, $c ) = @_;
ac5c933b	358
847e3257	359	return unless $c->request->{_body};
ac5c933b	360
fbcc39ad	361	$c->request->body_parameters( $c->request->{_body}->param );
fbcc39ad	362	}
0556eb49	363
b5ecfcf0	364	=head2 $self->prepare_connection($c)
0556eb49	365
4ab87e27	366	Abstract method implemented in engines.
4ab87e27	367
0556eb49	368	=cut
	369
	370	sub prepare_connection { }
	371
b5ecfcf0	372	=head2 $self->prepare_cookies($c)
fc7ec1d9	373
fa32ac82	374	Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
4ab87e27	375
fc7ec1d9	376	=cut
fc7ec1d9	377
6dc87a0f	378	sub prepare_cookies {
fbcc39ad	379	my ( $self, $c ) = @_;
6dc87a0f	380
6dc87a0f	381	if ( my $header = $c->request->header('Cookie') ) {
fa32ac82	382	$c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
6dc87a0f	383	}
6dc87a0f	384	}
fc7ec1d9	385
b5ecfcf0	386	=head2 $self->prepare_headers($c)
fc7ec1d9	387
	388	=cut
	389
	390	sub prepare_headers { }
	391
b5ecfcf0	392	=head2 $self->prepare_parameters($c)
fc7ec1d9	393
4ab87e27	394	sets up parameters from query and post parameters.
4ab87e27	395
fc7ec1d9	396	=cut
fc7ec1d9	397
fbcc39ad	398	sub prepare_parameters {
fbcc39ad	399	my ( $self, $c ) = @_;
fc7ec1d9	400
7fa2c9c1	401	my $request = $c->request;
	402	my $parameters = $request->parameters;
	403	my $body_parameters = $request->body_parameters;
	404	my $query_parameters = $request->query_parameters;
fbcc39ad	405	# We copy, no references
91772de9	406	foreach my $name (keys %$query_parameters) {
91772de9	407	my $param = $query_parameters->{$name};
7fa2c9c1	408	$parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
fbcc39ad	409	}
fc7ec1d9	410
fbcc39ad	411	# Merge query and body parameters
91772de9	412	foreach my $name (keys %$body_parameters) {
91772de9	413	my $param = $body_parameters->{$name};
7fa2c9c1	414	my @values = ref $param eq 'ARRAY' ? @$param : ($param);
	415	if ( my $existing = $parameters->{$name} ) {
	416	unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
fbcc39ad	417	}
7fa2c9c1	418	$parameters->{$name} = @values > 1 ? \@values : $values[0];
fbcc39ad	419	}
	420	}
	421
b5ecfcf0	422	=head2 $self->prepare_path($c)
fc7ec1d9	423
4ab87e27	424	abstract method, implemented by engines.
4ab87e27	425
fc7ec1d9	426	=cut
	427
	428	sub prepare_path { }
	429
b5ecfcf0	430	=head2 $self->prepare_request($c)
fc7ec1d9	431
b5ecfcf0	432	=head2 $self->prepare_query_parameters($c)
fc7ec1d9	433
4ab87e27	434	process the query string and extract query parameters.
4ab87e27	435
fc7ec1d9	436	=cut
fc7ec1d9	437
e0616220	438	sub prepare_query_parameters {
e0616220	439	my ( $self, $c, $query_string ) = @_;
ac5c933b	440
3b4d1251	441	# Check for keywords (no = signs)
3b4d1251	442	# (yes, index() is faster than a regex :))
933ba403	443	if ( index( $query_string, '=' ) < 0 ) {
3b4d1251	444	$c->request->query_keywords( $self->unescape_uri($query_string) );
933ba403	445	return;
	446	}
	447
	448	my %query;
e0616220	449
	450	# replace semi-colons
	451	$query_string =~ s/;/&/g;
ac5c933b	452
933ba403	453	my @params = split /&/, $query_string;
e0616220	454
933ba403	455	for my $item ( @params ) {
ac5c933b	456
ac5c933b	457	my ($param, $value)
933ba403	458	= map { $self->unescape_uri($_) }
e5542b70	459	split( /=/, $item, 2 );
ac5c933b	460
933ba403	461	$param = $self->unescape_uri($item) unless defined $param;
ac5c933b	462
933ba403	463	if ( exists $query{$param} ) {
	464	if ( ref $query{$param} ) {
	465	push @{ $query{$param} }, $value;
	466	}
	467	else {
	468	$query{$param} = [ $query{$param}, $value ];
	469	}
	470	}
	471	else {
	472	$query{$param} = $value;
	473	}
e0616220	474	}
933ba403	475
933ba403	476	$c->request->query_parameters( \%query );
e0616220	477	}
fbcc39ad	478
b5ecfcf0	479	=head2 $self->prepare_read($c)
fbcc39ad	480
4ab87e27	481	prepare to read from the engine.
4ab87e27	482
fbcc39ad	483	=cut
fc7ec1d9	484
fbcc39ad	485	sub prepare_read {
fbcc39ad	486	my ( $self, $c ) = @_;
4f5ebacd	487
878b821c	488	# Initialize the read position
4f5ebacd	489	$self->read_position(0);
ac5c933b	490
878b821c	491	# Initialize the amount of data we think we need to read
878b821c	492	$self->read_length( $c->request->header('Content-Length') \|\| 0 );
fbcc39ad	493	}
fc7ec1d9	494
b5ecfcf0	495	=head2 $self->prepare_request(@arguments)
fc7ec1d9	496
4ab87e27	497	Populate the context object from the request object.
4ab87e27	498
fc7ec1d9	499	=cut
fc7ec1d9	500
fbcc39ad	501	sub prepare_request { }
fc7ec1d9	502
b5ecfcf0	503	=head2 $self->prepare_uploads($c)
c9afa5fc	504
fbcc39ad	505	=cut
	506
	507	sub prepare_uploads {
	508	my ( $self, $c ) = @_;
7fa2c9c1	509
	510	my $request = $c->request;
	511	return unless $request->{_body};
	512
	513	my $uploads = $request->{_body}->upload;
	514	my $parameters = $request->parameters;
91772de9	515	foreach my $name (keys %$uploads) {
91772de9	516	my $files = $uploads->{$name};
fbcc39ad	517	my @uploads;
7fa2c9c1	518	for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
	519	my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
	520	my $u = Catalyst::Request::Upload->new
	521	(
	522	size => $upload->{size},
	523	type => $headers->content_type,
	524	headers => $headers,
	525	tempname => $upload->{tempname},
	526	filename => $upload->{filename},
	527	);
fbcc39ad	528	push @uploads, $u;
fbcc39ad	529	}
7fa2c9c1	530	$request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
f4a57de4	531
c4bed79a	532	# support access to the filename as a normal param
c4bed79a	533	my @filenames = map { $_->{filename} } @uploads;
a7e05d9d	534	# append, if there's already params with this name
7fa2c9c1	535	if (exists $parameters->{$name}) {
	536	if (ref $parameters->{$name} eq 'ARRAY') {
	537	push @{ $parameters->{$name} }, @filenames;
a7e05d9d	538	}
a7e05d9d	539	else {
7fa2c9c1	540	$parameters->{$name} = [ $parameters->{$name}, @filenames ];
a7e05d9d	541	}
	542	}
	543	else {
7fa2c9c1	544	$parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
a7e05d9d	545	}
fbcc39ad	546	}
	547	}
	548
b5ecfcf0	549	=head2 $self->prepare_write($c)
c9afa5fc	550
4ab87e27	551	Abstract method. Implemented by the engines.
4ab87e27	552
c9afa5fc	553	=cut
c9afa5fc	554
fbcc39ad	555	sub prepare_write { }
fbcc39ad	556
b5ecfcf0	557	=head2 $self->read($c, [$maxlength])
fbcc39ad	558
	559	=cut
	560
	561	sub read {
	562	my ( $self, $c, $maxlength ) = @_;
4f5ebacd	563
fbcc39ad	564	my $remaining = $self->read_length - $self->read_position;
4bd82c41	565	$maxlength \|\|= $CHUNKSIZE;
4f5ebacd	566
fbcc39ad	567	# Are we done reading?
fbcc39ad	568	if ( $remaining <= 0 ) {
4f5ebacd	569	$self->finalize_read($c);
fbcc39ad	570	return;
fbcc39ad	571	}
c9afa5fc	572
fbcc39ad	573	my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
	574	my $rc = $self->read_chunk( $c, my $buffer, $readlen );
	575	if ( defined $rc ) {
	576	$self->read_position( $self->read_position + $rc );
	577	return $buffer;
	578	}
	579	else {
4f5ebacd	580	Catalyst::Exception->throw(
4f5ebacd	581	message => "Unknown error reading input: $!" );
fbcc39ad	582	}
fbcc39ad	583	}
fc7ec1d9	584
b5ecfcf0	585	=head2 $self->read_chunk($c, $buffer, $length)
23f9d934	586
fbcc39ad	587	Each engine inplements read_chunk as its preferred way of reading a chunk
fbcc39ad	588	of data.
fc7ec1d9	589
fbcc39ad	590	=cut
61b1e958	591
fbcc39ad	592	sub read_chunk { }
61b1e958	593
b5ecfcf0	594	=head2 $self->read_length
ca39d576	595
fbcc39ad	596	The length of input data to be read. This is obtained from the Content-Length
fbcc39ad	597	header.
fc7ec1d9	598
b5ecfcf0	599	=head2 $self->read_position
fc7ec1d9	600
fbcc39ad	601	The amount of input data that has already been read.
63b763c5	602
b5ecfcf0	603	=head2 $self->run($c)
63b763c5	604
4ab87e27	605	Start the engine. Implemented by the various engine classes.
4ab87e27	606
fbcc39ad	607	=cut
fc7ec1d9	608
fbcc39ad	609	sub run { }
fc7ec1d9	610
b5ecfcf0	611	=head2 $self->write($c, $buffer)
fc7ec1d9	612
e512dd24	613	Writes the buffer to the client.
4ab87e27	614
fc7ec1d9	615	=cut
fc7ec1d9	616
fbcc39ad	617	sub write {
fbcc39ad	618	my ( $self, $c, $buffer ) = @_;
4f5ebacd	619
fbcc39ad	620	unless ( $self->{_prepared_write} ) {
4f5ebacd	621	$self->prepare_write($c);
fbcc39ad	622	$self->{_prepared_write} = 1;
fc7ec1d9	623	}
ac5c933b	624
d04b2ffd	625	my $len = length($buffer);
d04b2ffd	626	my $wrote = syswrite STDOUT, $buffer;
ac5c933b	627
d04b2ffd	628	if ( !defined $wrote && $! == EWOULDBLOCK ) {
	629	# Unable to write on the first try, will retry in the loop below
	630	$wrote = 0;
	631	}
ac5c933b	632
d04b2ffd	633	if ( defined $wrote && $wrote < $len ) {
	634	# We didn't write the whole buffer
	635	while (1) {
	636	my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
	637	if ( defined $ret ) {
	638	$wrote += $ret;
	639	}
	640	else {
	641	next if $! == EWOULDBLOCK;
	642	return;
	643	}
ac5c933b	644
d04b2ffd	645	last if $wrote >= $len;
e2b0ddd3	646	}
e512dd24	647	}
ac5c933b	648
e512dd24	649	return $wrote;
fc7ec1d9	650	}
fc7ec1d9	651
933ba403	652	=head2 $self->unescape_uri($uri)
933ba403	653
6a44fe01	654	Unescapes a given URI using the most efficient method available. Engines such
6a44fe01	655	as Apache may implement this using Apache's C-based modules, for example.
933ba403	656
	657	=cut
	658
	659	sub unescape_uri {
8c7d83e1	660	my ( $self, $str ) = @_;
7d22a537	661
	662	$str =~ s/(?:%([0-9A-Fa-f]{2})\|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
	663
8c7d83e1	664	return $str;
933ba403	665	}
34d28dfd	666
4ab87e27	667	=head2 $self->finalize_output
	668
	669	<obsolete>, see finalize_body
	670
fbcc39ad	671	=head1 AUTHORS
	672
	673	Sebastian Riedel, <sri@cpan.org>
fc7ec1d9	674
fbcc39ad	675	Andy Grundman, <andy@hybridized.org>
fc7ec1d9	676
	677	=head1 COPYRIGHT
	678
	679	This program is free software, you can redistribute it and/or modify it under
	680	the same terms as Perl itself.
	681
	682	=cut
	683
	684	1;