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

package Catalyst::Engine;

use strict;
use base 'Class::Accessor::Fast';
use CGI::Cookie;
use Data::Dumper;
use HTML::Entities;
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;

# input position and length
__PACKAGE__->mk_accessors(qw/read_position read_length/);

# Stringify to class
use overload '""' => sub { return ref shift }, fallback => 1;

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

=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;
    if ( ref $body && ($body->can('read') || 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::Cookies from $c->res->cookies, and set them as response headers.

=cut

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

    my @cookies;
    while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {

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

        push @cookies, $cookie->as_string;
    }

    for my $cookie (@cookies) {
        $c->res->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} || 'Catalyst Application';

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

        # For pretty dumps
        local $Data::Dumper::Terse = 1;
        $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};

        # Don't show response header state in dump
        delete $c->res->{_finalized_headers};

        my $req   = encode_entities Dumper $c->req;
        my $res   = encode_entities Dumper $c->res;
        my $stash = encode_entities Dumper $c->stash;

        my @infos;
        my $i = 0;
        for my $dump ( $c->dump_these ) {
            my $name  = $dump->[0];
            my $value = encode_entities( Dumper $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: #ddd;
            background-color: #eee;
            margin: 0px;
            padding: 0px;
        }
        :link, :link:hover, :visited, :visited:hover {
            color: #ddd;
        }
        div.box {
            position: relative;
            background-color: #ccc;
            border: 1px solid #aaa;
            padding: 4px;
            margin: 10px;
            -moz-border-radius: 10px;
        }
        div.error {
            background-color: #977;
            border: 1px solid #755;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
            -moz-border-radius: 10px;
        }
        div.infos {
            background-color: #797;
            border: 1px solid #575;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
            -moz-border-radius: 10px;
        }
        div.name {
            background-color: #779;
            border: 1px solid #557;
            padding: 8px;
            margin: 4px;
            -moz-border-radius: 10px;
        }
        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 {
    my ( $self, $c ) = @_;

    undef $self->{_prepared_read};
}

=head2 $self->finalize_uploads($c)

Clean up after uploads, deleting temp files.

=cut

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

    if ( keys %{ $c->request->uploads } ) {
        for my $key ( keys %{ $c->request->uploads } ) {
            my $upload = $c->request->uploads->{$key};
            unlink map { $_->tempname }
              grep     { -e $_->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 ) = @_;

    $self->read_length( $c->request->header('Content-Length') || 0 );
    my $type = $c->request->header('Content-Type');

    unless ( $c->request->{_body} ) {
        $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
        $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp} if exists $c->config->{uploadtmp};
    }

    if ( $self->read_length > 0 ) {
        while ( my $buffer = $self->read($c) ) {
            $c->prepare_body_chunk($buffer);
        }

        # paranoia against wrong Content-Length header
        my $remaining = $self->read_length - $self->read_position;
        if ($remaining > 0) {
            $self->finalize_read($c);
            Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
        }
    }
}

=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 ) = @_;
    $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::Cookie> object.

=cut

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

    if ( my $header = $c->request->header('Cookie') ) {
        $c->req->cookies( { CGI::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 ) = @_;

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

    # Merge query and body parameters
    while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
        $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
        if ( my $old_param = $c->request->parameters->{$name} ) {
            if ( ref $old_param eq 'ARRAY' ) {
                push @{ $c->request->parameters->{$name} },
                  ref $param eq 'ARRAY' ? @$param : $param;
            }
            else { $c->request->parameters->{$name} = [ $old_param, $param ] }
        }
        else { $c->request->parameters->{$name} = $param }
    }
}

=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 ) = @_;

    # replace semi-colons
    $query_string =~ s/;/&/g;

    my $u = URI->new( '', 'http' );
    $u->query($query_string);
    for my $key ( $u->query_param ) {
        my @vals = $u->query_param($key);
        $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
    }
}

=head2 $self->prepare_read($c)

prepare to read from the engine.

=cut

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

    # Reset the read position
    $self->read_position(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 $uploads = $c->request->{_body}->upload;
    for my $name ( keys %$uploads ) {
        my $files = $uploads->{$name};
        $files = ref $files eq 'ARRAY' ? $files : [$files];
        my @uploads;
        for my $upload (@$files) {
            my $u = Catalyst::Request::Upload->new;
            $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
            $u->type( $u->headers->content_type );
            $u->tempname( $upload->{tempname} );
            $u->size( $upload->{size} );
            $u->filename( $upload->{filename} );
            push @uploads, $u;
        }
        $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];

        # support access to the filename as a normal param
        my @filenames = map { $_->{filename} } @uploads;
        $c->request->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 ) = @_;

    unless ( $self->{_prepared_read} ) {
        $self->prepare_read($c);
        $self->{_prepared_read} = 1;
    }

    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. Can only be called once for a request.

=cut

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

    unless ( $self->{_prepared_write} ) {
        $self->prepare_write($c);
        $self->{_prepared_write} = 1;
    }

    print STDOUT $buffer;
}

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