[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
(pt) Por favor volte mais tarde
</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 = grep { length $_ } 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

Catalyst Contributors, see Catalyst.pm

=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
2f381252	159	(pt) Por favor volte mais tarde
969647fd	160	</pre>
	161
	162	$name = '';
	163	}
e060fe05	164	$c->res->body( <<"" );
7299a7b4	165	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	166	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
	167	<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
969647fd	168	<head>
7299a7b4	169	<meta http-equiv="Content-Language" content="en" />
7299a7b4	170	<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
969647fd	171	<title>$title</title>
7299a7b4	172	<script type="text/javascript">
c6ef5e69	173	<!--
c6ef5e69	174	function toggleDump (dumpElement) {
7299a7b4	175	var e = document.getElementById( dumpElement );
	176	if (e.style.display == "none") {
	177	e.style.display = "";
c6ef5e69	178	}
c6ef5e69	179	else {
7299a7b4	180	e.style.display = "none";
c6ef5e69	181	}
	182	}
	183	-->
	184	</script>
969647fd	185	<style type="text/css">
	186	body {
	187	font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
	188	Tahoma, Arial, helvetica, sans-serif;
34d28dfd	189	color: #333;
969647fd	190	background-color: #eee;
	191	margin: 0px;
	192	padding: 0px;
	193	}
c6ef5e69	194	:link, :link:hover, :visited, :visited:hover {
34d28dfd	195	color: #000;
c6ef5e69	196	}
969647fd	197	div.box {
9619f23c	198	position: relative;
969647fd	199	background-color: #ccc;
	200	border: 1px solid #aaa;
	201	padding: 4px;
	202	margin: 10px;
969647fd	203	}
969647fd	204	div.error {
34d28dfd	205	background-color: #cce;
969647fd	206	border: 1px solid #755;
	207	padding: 8px;
	208	margin: 4px;
	209	margin-bottom: 10px;
969647fd	210	}
969647fd	211	div.infos {
34d28dfd	212	background-color: #eee;
969647fd	213	border: 1px solid #575;
	214	padding: 8px;
	215	margin: 4px;
	216	margin-bottom: 10px;
969647fd	217	}
969647fd	218	div.name {
34d28dfd	219	background-color: #cce;
969647fd	220	border: 1px solid #557;
	221	padding: 8px;
	222	margin: 4px;
969647fd	223	}
7f8e0078	224	code.error {
	225	display: block;
	226	margin: 1em 0;
	227	overflow: auto;
7f8e0078	228	}
9619f23c	229	div.name h1, div.error p {
	230	margin: 0;
	231	}
	232	h2 {
	233	margin-top: 0;
	234	margin-bottom: 10px;
	235	font-size: medium;
	236	font-weight: bold;
	237	text-decoration: underline;
	238	}
	239	h1 {
	240	font-size: medium;
	241	font-weight: normal;
	242	}
2666dd3b	243	/* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
2666dd3b	244	/* Browser specific (not valid) styles to make preformatted text wrap */
ac5c933b	245	pre {
2666dd3b	246	white-space: pre-wrap; /* css-3 */
	247	white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
	248	white-space: -pre-wrap; /* Opera 4-6 */
	249	white-space: -o-pre-wrap; /* Opera 7 */
	250	word-wrap: break-word; /* Internet Explorer 5.5+ */
	251	}
969647fd	252	</style>
	253	</head>
	254	<body>
	255	<div class="box">
	256	<div class="error">$error</div>
	257	<div class="infos">$infos</div>
	258	<div class="name">$name</div>
	259	</div>
	260	</body>
	261	</html>
	262
d82cc9ae	263
	264	# Trick IE
	265	$c->res->{body} .= ( ' ' x 512 );
	266
	267	# Return 500
33117422	268	$c->res->status(500);
969647fd	269	}
969647fd	270
b5ecfcf0	271	=head2 $self->finalize_headers($c)
fc7ec1d9	272
4ab87e27	273	Abstract method, allows engines to write headers to response
4ab87e27	274
fc7ec1d9	275	=cut
	276
	277	sub finalize_headers { }
	278
b5ecfcf0	279	=head2 $self->finalize_read($c)
fc7ec1d9	280
	281	=cut
	282
878b821c	283	sub finalize_read { }
fc7ec1d9	284
b5ecfcf0	285	=head2 $self->finalize_uploads($c)
fc7ec1d9	286
4ab87e27	287	Clean up after uploads, deleting temp files.
4ab87e27	288
fc7ec1d9	289	=cut
fc7ec1d9	290
fbcc39ad	291	sub finalize_uploads {
fbcc39ad	292	my ( $self, $c ) = @_;
99fe1710	293
7fa2c9c1	294	my $request = $c->request;
91772de9	295	foreach my $key (keys %{ $request->uploads }) {
91772de9	296	my $upload = $request->uploads->{$key};
7fa2c9c1	297	unlink grep { -e $_ } map { $_->tempname }
7fa2c9c1	298	(ref $upload eq 'ARRAY' ? @{$upload} : ($upload));
c85ff642	299	}
7fa2c9c1	300
fc7ec1d9	301	}
fc7ec1d9	302
b5ecfcf0	303	=head2 $self->prepare_body($c)
fc7ec1d9	304
4ab87e27	305	sets up the L<Catalyst::Request> object body using L<HTTP::Body>
4ab87e27	306
fc7ec1d9	307	=cut
fc7ec1d9	308
fbcc39ad	309	sub prepare_body {
fbcc39ad	310	my ( $self, $c ) = @_;
99fe1710	311
878b821c	312	if ( my $length = $self->read_length ) {
7fa2c9c1	313	my $request = $c->request;
	314	unless ( $request->{_body} ) {
	315	my $type = $request->header('Content-Type');
	316	$request->{_body} = HTTP::Body->new( $type, $length );
2f381252	317	$request->{_body}->tmpdir( $c->config->{uploadtmp} )
847e3257	318	if exists $c->config->{uploadtmp};
847e3257	319	}
ac5c933b	320
4f5ebacd	321	while ( my $buffer = $self->read($c) ) {
4f5ebacd	322	$c->prepare_body_chunk($buffer);
fbcc39ad	323	}
fdb3773e	324
fdb3773e	325	# paranoia against wrong Content-Length header
847e3257	326	my $remaining = $length - $self->read_position;
34d28dfd	327	if ( $remaining > 0 ) {
fdb3773e	328	$self->finalize_read($c);
34d28dfd	329	Catalyst::Exception->throw(
847e3257	330	"Wrong Content-Length value: $length" );
fdb3773e	331	}
fc7ec1d9	332	}
847e3257	333	else {
	334	# Defined but will cause all body code to be skipped
	335	$c->request->{_body} = 0;
	336	}
fc7ec1d9	337	}
fc7ec1d9	338
b5ecfcf0	339	=head2 $self->prepare_body_chunk($c)
4bd82c41	340
4ab87e27	341	Add a chunk to the request body.
4ab87e27	342
4bd82c41	343	=cut
	344
	345	sub prepare_body_chunk {
	346	my ( $self, $c, $chunk ) = @_;
4f5ebacd	347
4f5ebacd	348	$c->request->{_body}->add($chunk);
4bd82c41	349	}
4bd82c41	350
b5ecfcf0	351	=head2 $self->prepare_body_parameters($c)
06e1b616	352
ac5c933b	353	Sets up parameters from body.
4ab87e27	354
06e1b616	355	=cut
06e1b616	356
fbcc39ad	357	sub prepare_body_parameters {
fbcc39ad	358	my ( $self, $c ) = @_;
ac5c933b	359
847e3257	360	return unless $c->request->{_body};
ac5c933b	361
fbcc39ad	362	$c->request->body_parameters( $c->request->{_body}->param );
fbcc39ad	363	}
0556eb49	364
b5ecfcf0	365	=head2 $self->prepare_connection($c)
0556eb49	366
4ab87e27	367	Abstract method implemented in engines.
4ab87e27	368
0556eb49	369	=cut
	370
	371	sub prepare_connection { }
	372
b5ecfcf0	373	=head2 $self->prepare_cookies($c)
fc7ec1d9	374
fa32ac82	375	Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
4ab87e27	376
fc7ec1d9	377	=cut
fc7ec1d9	378
6dc87a0f	379	sub prepare_cookies {
fbcc39ad	380	my ( $self, $c ) = @_;
6dc87a0f	381
6dc87a0f	382	if ( my $header = $c->request->header('Cookie') ) {
fa32ac82	383	$c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
6dc87a0f	384	}
6dc87a0f	385	}
fc7ec1d9	386
b5ecfcf0	387	=head2 $self->prepare_headers($c)
fc7ec1d9	388
	389	=cut
	390
	391	sub prepare_headers { }
	392
b5ecfcf0	393	=head2 $self->prepare_parameters($c)
fc7ec1d9	394
4ab87e27	395	sets up parameters from query and post parameters.
4ab87e27	396
fc7ec1d9	397	=cut
fc7ec1d9	398
fbcc39ad	399	sub prepare_parameters {
fbcc39ad	400	my ( $self, $c ) = @_;
fc7ec1d9	401
7fa2c9c1	402	my $request = $c->request;
	403	my $parameters = $request->parameters;
	404	my $body_parameters = $request->body_parameters;
	405	my $query_parameters = $request->query_parameters;
fbcc39ad	406	# We copy, no references
91772de9	407	foreach my $name (keys %$query_parameters) {
91772de9	408	my $param = $query_parameters->{$name};
7fa2c9c1	409	$parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
fbcc39ad	410	}
fc7ec1d9	411
fbcc39ad	412	# Merge query and body parameters
91772de9	413	foreach my $name (keys %$body_parameters) {
91772de9	414	my $param = $body_parameters->{$name};
7fa2c9c1	415	my @values = ref $param eq 'ARRAY' ? @$param : ($param);
	416	if ( my $existing = $parameters->{$name} ) {
	417	unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
fbcc39ad	418	}
7fa2c9c1	419	$parameters->{$name} = @values > 1 ? \@values : $values[0];
fbcc39ad	420	}
	421	}
	422
b5ecfcf0	423	=head2 $self->prepare_path($c)
fc7ec1d9	424
4ab87e27	425	abstract method, implemented by engines.
4ab87e27	426
fc7ec1d9	427	=cut
	428
	429	sub prepare_path { }
	430
b5ecfcf0	431	=head2 $self->prepare_request($c)
fc7ec1d9	432
b5ecfcf0	433	=head2 $self->prepare_query_parameters($c)
fc7ec1d9	434
4ab87e27	435	process the query string and extract query parameters.
4ab87e27	436
fc7ec1d9	437	=cut
fc7ec1d9	438
e0616220	439	sub prepare_query_parameters {
e0616220	440	my ( $self, $c, $query_string ) = @_;
ac5c933b	441
3b4d1251	442	# Check for keywords (no = signs)
3b4d1251	443	# (yes, index() is faster than a regex :))
933ba403	444	if ( index( $query_string, '=' ) < 0 ) {
3b4d1251	445	$c->request->query_keywords( $self->unescape_uri($query_string) );
933ba403	446	return;
	447	}
	448
	449	my %query;
e0616220	450
	451	# replace semi-colons
	452	$query_string =~ s/;/&/g;
ac5c933b	453
2f381252	454	my @params = grep { length $_ } split /&/, $query_string;
e0616220	455
933ba403	456	for my $item ( @params ) {
ac5c933b	457
ac5c933b	458	my ($param, $value)
933ba403	459	= map { $self->unescape_uri($_) }
e5542b70	460	split( /=/, $item, 2 );
ac5c933b	461
933ba403	462	$param = $self->unescape_uri($item) unless defined $param;
ac5c933b	463
933ba403	464	if ( exists $query{$param} ) {
	465	if ( ref $query{$param} ) {
	466	push @{ $query{$param} }, $value;
	467	}
	468	else {
	469	$query{$param} = [ $query{$param}, $value ];
	470	}
	471	}
	472	else {
	473	$query{$param} = $value;
	474	}
e0616220	475	}
933ba403	476
933ba403	477	$c->request->query_parameters( \%query );
e0616220	478	}
fbcc39ad	479
b5ecfcf0	480	=head2 $self->prepare_read($c)
fbcc39ad	481
4ab87e27	482	prepare to read from the engine.
4ab87e27	483
fbcc39ad	484	=cut
fc7ec1d9	485
fbcc39ad	486	sub prepare_read {
fbcc39ad	487	my ( $self, $c ) = @_;
4f5ebacd	488
878b821c	489	# Initialize the read position
4f5ebacd	490	$self->read_position(0);
ac5c933b	491
878b821c	492	# Initialize the amount of data we think we need to read
878b821c	493	$self->read_length( $c->request->header('Content-Length') \|\| 0 );
fbcc39ad	494	}
fc7ec1d9	495
b5ecfcf0	496	=head2 $self->prepare_request(@arguments)
fc7ec1d9	497
4ab87e27	498	Populate the context object from the request object.
4ab87e27	499
fc7ec1d9	500	=cut
fc7ec1d9	501
fbcc39ad	502	sub prepare_request { }
fc7ec1d9	503
b5ecfcf0	504	=head2 $self->prepare_uploads($c)
c9afa5fc	505
fbcc39ad	506	=cut
	507
	508	sub prepare_uploads {
	509	my ( $self, $c ) = @_;
7fa2c9c1	510
	511	my $request = $c->request;
	512	return unless $request->{_body};
	513
	514	my $uploads = $request->{_body}->upload;
	515	my $parameters = $request->parameters;
91772de9	516	foreach my $name (keys %$uploads) {
91772de9	517	my $files = $uploads->{$name};
fbcc39ad	518	my @uploads;
7fa2c9c1	519	for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
	520	my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
	521	my $u = Catalyst::Request::Upload->new
	522	(
	523	size => $upload->{size},
	524	type => $headers->content_type,
	525	headers => $headers,
	526	tempname => $upload->{tempname},
	527	filename => $upload->{filename},
	528	);
fbcc39ad	529	push @uploads, $u;
fbcc39ad	530	}
7fa2c9c1	531	$request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
f4a57de4	532
c4bed79a	533	# support access to the filename as a normal param
c4bed79a	534	my @filenames = map { $_->{filename} } @uploads;
a7e05d9d	535	# append, if there's already params with this name
7fa2c9c1	536	if (exists $parameters->{$name}) {
	537	if (ref $parameters->{$name} eq 'ARRAY') {
	538	push @{ $parameters->{$name} }, @filenames;
a7e05d9d	539	}
a7e05d9d	540	else {
7fa2c9c1	541	$parameters->{$name} = [ $parameters->{$name}, @filenames ];
a7e05d9d	542	}
	543	}
	544	else {
7fa2c9c1	545	$parameters->{$name} = @filenames > 1 ? \@filenames : $filenames[0];
a7e05d9d	546	}
fbcc39ad	547	}
	548	}
	549
b5ecfcf0	550	=head2 $self->prepare_write($c)
c9afa5fc	551
4ab87e27	552	Abstract method. Implemented by the engines.
4ab87e27	553
c9afa5fc	554	=cut
c9afa5fc	555
fbcc39ad	556	sub prepare_write { }
fbcc39ad	557
b5ecfcf0	558	=head2 $self->read($c, [$maxlength])
fbcc39ad	559
	560	=cut
	561
	562	sub read {
	563	my ( $self, $c, $maxlength ) = @_;
4f5ebacd	564
fbcc39ad	565	my $remaining = $self->read_length - $self->read_position;
4bd82c41	566	$maxlength \|\|= $CHUNKSIZE;
4f5ebacd	567
fbcc39ad	568	# Are we done reading?
fbcc39ad	569	if ( $remaining <= 0 ) {
4f5ebacd	570	$self->finalize_read($c);
fbcc39ad	571	return;
fbcc39ad	572	}
c9afa5fc	573
fbcc39ad	574	my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
	575	my $rc = $self->read_chunk( $c, my $buffer, $readlen );
	576	if ( defined $rc ) {
	577	$self->read_position( $self->read_position + $rc );
	578	return $buffer;
	579	}
	580	else {
4f5ebacd	581	Catalyst::Exception->throw(
4f5ebacd	582	message => "Unknown error reading input: $!" );
fbcc39ad	583	}
fbcc39ad	584	}
fc7ec1d9	585
b5ecfcf0	586	=head2 $self->read_chunk($c, $buffer, $length)
23f9d934	587
fbcc39ad	588	Each engine inplements read_chunk as its preferred way of reading a chunk
fbcc39ad	589	of data.
fc7ec1d9	590
fbcc39ad	591	=cut
61b1e958	592
fbcc39ad	593	sub read_chunk { }
61b1e958	594
b5ecfcf0	595	=head2 $self->read_length
ca39d576	596
fbcc39ad	597	The length of input data to be read. This is obtained from the Content-Length
fbcc39ad	598	header.
fc7ec1d9	599
b5ecfcf0	600	=head2 $self->read_position
fc7ec1d9	601
fbcc39ad	602	The amount of input data that has already been read.
63b763c5	603
b5ecfcf0	604	=head2 $self->run($c)
63b763c5	605
4ab87e27	606	Start the engine. Implemented by the various engine classes.
4ab87e27	607
fbcc39ad	608	=cut
fc7ec1d9	609
fbcc39ad	610	sub run { }
fc7ec1d9	611
b5ecfcf0	612	=head2 $self->write($c, $buffer)
fc7ec1d9	613
e512dd24	614	Writes the buffer to the client.
4ab87e27	615
fc7ec1d9	616	=cut
fc7ec1d9	617
fbcc39ad	618	sub write {
fbcc39ad	619	my ( $self, $c, $buffer ) = @_;
4f5ebacd	620
fbcc39ad	621	unless ( $self->{_prepared_write} ) {
4f5ebacd	622	$self->prepare_write($c);
fbcc39ad	623	$self->{_prepared_write} = 1;
fc7ec1d9	624	}
ac5c933b	625
d04b2ffd	626	my $len = length($buffer);
d04b2ffd	627	my $wrote = syswrite STDOUT, $buffer;
ac5c933b	628
d04b2ffd	629	if ( !defined $wrote && $! == EWOULDBLOCK ) {
	630	# Unable to write on the first try, will retry in the loop below
	631	$wrote = 0;
	632	}
ac5c933b	633
d04b2ffd	634	if ( defined $wrote && $wrote < $len ) {
	635	# We didn't write the whole buffer
	636	while (1) {
	637	my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
	638	if ( defined $ret ) {
	639	$wrote += $ret;
	640	}
	641	else {
	642	next if $! == EWOULDBLOCK;
	643	return;
	644	}
ac5c933b	645
d04b2ffd	646	last if $wrote >= $len;
e2b0ddd3	647	}
e512dd24	648	}
ac5c933b	649
e512dd24	650	return $wrote;
fc7ec1d9	651	}
fc7ec1d9	652
933ba403	653	=head2 $self->unescape_uri($uri)
933ba403	654
6a44fe01	655	Unescapes a given URI using the most efficient method available. Engines such
6a44fe01	656	as Apache may implement this using Apache's C-based modules, for example.
933ba403	657
	658	=cut
	659
	660	sub unescape_uri {
8c7d83e1	661	my ( $self, $str ) = @_;
7d22a537	662
	663	$str =~ s/(?:%([0-9A-Fa-f]{2})\|\+)/defined $1 ? chr(hex($1)) : ' '/eg;
	664
8c7d83e1	665	return $str;
933ba403	666	}
34d28dfd	667
4ab87e27	668	=head2 $self->finalize_output
	669
	670	<obsolete>, see finalize_body
	671
fbcc39ad	672	=head1 AUTHORS
fbcc39ad	673
2f381252	674	Catalyst Contributors, see Catalyst.pm
fc7ec1d9	675
	676	=head1 COPYRIGHT
	677
	678	This program is free software, you can redistribute it and/or modify it under
	679	the same terms as Perl itself.
	680
	681	=cut
	682
	683	1;