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

package Catalyst::Engine;

use strict;
use base 'Class::Accessor::Fast';
use CGI::Simple::Cookie;
use Data::Dump qw/dump/;
use HTML::Entities;
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
use Scalar::Util ();

# 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;
    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;

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

        my $val = $c->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) {
        $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} || 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};

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

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

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

    # Merge query and body parameters
    foreach my $name ( keys %{ $c->request->body_parameters } ) {
        my $param = $c->request->body_parameters->{$name};
        $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;
        # append, if there's already params with this name
        if (exists $c->request->parameters->{$name}) {
            if (ref $c->request->parameters->{$name} eq 'ARRAY') {
                push @{ $c->request->parameters->{$name} }, @filenames;
            }
            else {
                $c->request->parameters->{$name} = 
                    [ $c->request->parameters->{$name}, @filenames ];
            }
        }
        else {
            $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';
fa32ac82	5	use CGI::Simple::Cookie;
f63c03e4	6	use Data::Dump qw/dump/;
fc7ec1d9	7	use HTML::Entities;
fbcc39ad	8	use HTTP::Body;
fc7ec1d9	9	use HTTP::Headers;
e0616220	10	use URI::QueryParam;
2832cb5d	11	use Scalar::Util ();
fbcc39ad	12
fbcc39ad	13	# input position and length
4f5ebacd	14	__PACKAGE__->mk_accessors(qw/read_position read_length/);
fbcc39ad	15
	16	# Stringify to class
	17	use overload '""' => sub { return ref shift }, fallback => 1;
fc7ec1d9	18
4bd82c41	19	# Amount of data to read from input on each pass
	20	our $CHUNKSIZE = 4096;
	21
fc7ec1d9	22	=head1 NAME
	23
	24	Catalyst::Engine - The Catalyst Engine
	25
	26	=head1 SYNOPSIS
	27
	28	See L<Catalyst>.
	29
	30	=head1 DESCRIPTION
	31
23f9d934	32	=head1 METHODS
fc7ec1d9	33
cd3bb248	34
b5ecfcf0	35	=head2 $self->finalize_body($c)
06e1b616	36
fbcc39ad	37	Finalize body. Prints the response output.
06e1b616	38
	39	=cut
	40
fbcc39ad	41	sub finalize_body {
fbcc39ad	42	my ( $self, $c ) = @_;
7257e9db	43	my $body = $c->response->body;
f9b6d612	44	no warnings 'uninitialized';
f9b6d612	45	if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
7257e9db	46	while ( !eof $body ) {
4c423abf	47	read $body, my ($buffer), $CHUNKSIZE;
6484fba0	48	last unless $self->write( $c, $buffer );
f4a57de4	49	}
7257e9db	50	close $body;
f4a57de4	51	}
f4a57de4	52	else {
7257e9db	53	$self->write( $c, $body );
f4a57de4	54	}
fbcc39ad	55	}
6dc87a0f	56
b5ecfcf0	57	=head2 $self->finalize_cookies($c)
6dc87a0f	58
fa32ac82	59	Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
fa32ac82	60	response headers.
4ab87e27	61
6dc87a0f	62	=cut
	63
	64	sub finalize_cookies {
fbcc39ad	65	my ( $self, $c ) = @_;
6dc87a0f	66
fbcc39ad	67	my @cookies;
c82ed742	68
	69	foreach my $name ( keys %{ $c->response->cookies } ) {
	70
	71	my $val = $c->response->cookies->{$name};
fbcc39ad	72
2832cb5d	73	my $cookie = (
	74	Scalar::Util::blessed($val)
	75	? $val
	76	: CGI::Simple::Cookie->new(
	77	-name => $name,
	78	-value => $val->{value},
	79	-expires => $val->{expires},
	80	-domain => $val->{domain},
	81	-path => $val->{path},
	82	-secure => $val->{secure} \|\| 0
	83	)
6dc87a0f	84	);
6dc87a0f	85
fbcc39ad	86	push @cookies, $cookie->as_string;
6dc87a0f	87	}
6dc87a0f	88
b39840da	89	for my $cookie (@cookies) {
b39840da	90	$c->res->headers->push_header( 'Set-Cookie' => $cookie );
fbcc39ad	91	}
fbcc39ad	92	}
969647fd	93
b5ecfcf0	94	=head2 $self->finalize_error($c)
969647fd	95
4ab87e27	96	Output an apropriate error message, called if there's an error in $c
	97	after the dispatch has finished. Will output debug messages if Catalyst
	98	is in debug mode, or a `please come back later` message otherwise.
	99
969647fd	100	=cut
	101
	102	sub finalize_error {
fbcc39ad	103	my ( $self, $c ) = @_;
969647fd	104
7299a7b4	105	$c->res->content_type('text/html; charset=utf-8');
34d28dfd	106	my $name = $c->config->{name} \|\| join(' ', split('::', ref $c));
969647fd	107
	108	my ( $title, $error, $infos );
	109	if ( $c->debug ) {
62d9b030	110
62d9b030	111	# For pretty dumps
b5ecfcf0	112	$error = join '', map {
	113	'<p><code class="error">'
	114	. encode_entities($_)
	115	. '</code></p>'
	116	} @{ $c->error };
969647fd	117	$error \|\|= 'No output';
2666dd3b	118	$error = qq{<pre wrap="">$error</pre>};
969647fd	119	$title = $name = "$name on Catalyst $Catalyst::VERSION";
d82cc9ae	120	$name = "<h1>$name</h1>";
fbcc39ad	121
	122	# Don't show context in the dump
	123	delete $c->req->{_context};
	124	delete $c->res->{_context};
	125
	126	# Don't show body parser in the dump
	127	delete $c->req->{_body};
	128
	129	# Don't show response header state in dump
	130	delete $c->res->{_finalized_headers};
	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 */
	243	/* Browser specific (not valid) styles to make preformatted text wrap */
	244	pre {
	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
fbcc39ad	282	sub finalize_read {
fbcc39ad	283	my ( $self, $c ) = @_;
4f5ebacd	284
fbcc39ad	285	undef $self->{_prepared_read};
fc7ec1d9	286	}
fc7ec1d9	287
b5ecfcf0	288	=head2 $self->finalize_uploads($c)
fc7ec1d9	289
4ab87e27	290	Clean up after uploads, deleting temp files.
4ab87e27	291
fc7ec1d9	292	=cut
fc7ec1d9	293
fbcc39ad	294	sub finalize_uploads {
fbcc39ad	295	my ( $self, $c ) = @_;
99fe1710	296
fbcc39ad	297	if ( keys %{ $c->request->uploads } ) {
	298	for my $key ( keys %{ $c->request->uploads } ) {
	299	my $upload = $c->request->uploads->{$key};
	300	unlink map { $_->tempname }
	301	grep { -e $_->tempname }
	302	ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
c85ff642	303	}
c85ff642	304	}
fc7ec1d9	305	}
fc7ec1d9	306
b5ecfcf0	307	=head2 $self->prepare_body($c)
fc7ec1d9	308
4ab87e27	309	sets up the L<Catalyst::Request> object body using L<HTTP::Body>
4ab87e27	310
fc7ec1d9	311	=cut
fc7ec1d9	312
fbcc39ad	313	sub prepare_body {
fbcc39ad	314	my ( $self, $c ) = @_;
99fe1710	315
fbcc39ad	316	$self->read_length( $c->request->header('Content-Length') \|\| 0 );
fbcc39ad	317	my $type = $c->request->header('Content-Type');
99fe1710	318
fbcc39ad	319	unless ( $c->request->{_body} ) {
fbcc39ad	320	$c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
34d28dfd	321	$c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
34d28dfd	322	if exists $c->config->{uploadtmp};
fc7ec1d9	323	}
4f5ebacd	324
fbcc39ad	325	if ( $self->read_length > 0 ) {
4f5ebacd	326	while ( my $buffer = $self->read($c) ) {
4f5ebacd	327	$c->prepare_body_chunk($buffer);
fbcc39ad	328	}
fdb3773e	329
	330	# paranoia against wrong Content-Length header
	331	my $remaining = $self->read_length - $self->read_position;
34d28dfd	332	if ( $remaining > 0 ) {
fdb3773e	333	$self->finalize_read($c);
34d28dfd	334	Catalyst::Exception->throw(
34d28dfd	335	"Wrong Content-Length value: " . $self->read_length );
fdb3773e	336	}
fc7ec1d9	337	}
	338	}
	339
b5ecfcf0	340	=head2 $self->prepare_body_chunk($c)
4bd82c41	341
4ab87e27	342	Add a chunk to the request body.
4ab87e27	343
4bd82c41	344	=cut
	345
	346	sub prepare_body_chunk {
	347	my ( $self, $c, $chunk ) = @_;
4f5ebacd	348
4f5ebacd	349	$c->request->{_body}->add($chunk);
4bd82c41	350	}
4bd82c41	351
b5ecfcf0	352	=head2 $self->prepare_body_parameters($c)
06e1b616	353
4ab87e27	354	Sets up parameters from body.
4ab87e27	355
06e1b616	356	=cut
06e1b616	357
fbcc39ad	358	sub prepare_body_parameters {
	359	my ( $self, $c ) = @_;
	360	$c->request->body_parameters( $c->request->{_body}->param );
	361	}
0556eb49	362
b5ecfcf0	363	=head2 $self->prepare_connection($c)
0556eb49	364
4ab87e27	365	Abstract method implemented in engines.
4ab87e27	366
0556eb49	367	=cut
	368
	369	sub prepare_connection { }
	370
b5ecfcf0	371	=head2 $self->prepare_cookies($c)
fc7ec1d9	372
fa32ac82	373	Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
4ab87e27	374
fc7ec1d9	375	=cut
fc7ec1d9	376
6dc87a0f	377	sub prepare_cookies {
fbcc39ad	378	my ( $self, $c ) = @_;
6dc87a0f	379
6dc87a0f	380	if ( my $header = $c->request->header('Cookie') ) {
fa32ac82	381	$c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
6dc87a0f	382	}
6dc87a0f	383	}
fc7ec1d9	384
b5ecfcf0	385	=head2 $self->prepare_headers($c)
fc7ec1d9	386
	387	=cut
	388
	389	sub prepare_headers { }
	390
b5ecfcf0	391	=head2 $self->prepare_parameters($c)
fc7ec1d9	392
4ab87e27	393	sets up parameters from query and post parameters.
4ab87e27	394
fc7ec1d9	395	=cut
fc7ec1d9	396
fbcc39ad	397	sub prepare_parameters {
fbcc39ad	398	my ( $self, $c ) = @_;
fc7ec1d9	399
fbcc39ad	400	# We copy, no references
c82ed742	401	foreach my $name ( keys %{ $c->request->query_parameters } ) {
c82ed742	402	my $param = $c->request->query_parameters->{$name};
fbcc39ad	403	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	404	$c->request->parameters->{$name} = $param;
	405	}
fc7ec1d9	406
fbcc39ad	407	# Merge query and body parameters
c82ed742	408	foreach my $name ( keys %{ $c->request->body_parameters } ) {
c82ed742	409	my $param = $c->request->body_parameters->{$name};
fbcc39ad	410	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	411	if ( my $old_param = $c->request->parameters->{$name} ) {
	412	if ( ref $old_param eq 'ARRAY' ) {
	413	push @{ $c->request->parameters->{$name} },
	414	ref $param eq 'ARRAY' ? @$param : $param;
	415	}
	416	else { $c->request->parameters->{$name} = [ $old_param, $param ] }
	417	}
	418	else { $c->request->parameters->{$name} = $param }
	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 {
	439	my ( $self, $c, $query_string ) = @_;
	440
	441	# replace semi-colons
	442	$query_string =~ s/;/&/g;
	443
	444	my $u = URI->new( '', 'http' );
f4a57de4	445	$u->query($query_string);
	446	for my $key ( $u->query_param ) {
	447	my @vals = $u->query_param($key);
	448	$c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
e0616220	449	}
e0616220	450	}
fbcc39ad	451
b5ecfcf0	452	=head2 $self->prepare_read($c)
fbcc39ad	453
4ab87e27	454	prepare to read from the engine.
4ab87e27	455
fbcc39ad	456	=cut
fc7ec1d9	457
fbcc39ad	458	sub prepare_read {
fbcc39ad	459	my ( $self, $c ) = @_;
4f5ebacd	460
fbcc39ad	461	# Reset the read position
4f5ebacd	462	$self->read_position(0);
fbcc39ad	463	}
fc7ec1d9	464
b5ecfcf0	465	=head2 $self->prepare_request(@arguments)
fc7ec1d9	466
4ab87e27	467	Populate the context object from the request object.
4ab87e27	468
fc7ec1d9	469	=cut
fc7ec1d9	470
fbcc39ad	471	sub prepare_request { }
fc7ec1d9	472
b5ecfcf0	473	=head2 $self->prepare_uploads($c)
c9afa5fc	474
fbcc39ad	475	=cut
	476
	477	sub prepare_uploads {
	478	my ( $self, $c ) = @_;
	479	my $uploads = $c->request->{_body}->upload;
	480	for my $name ( keys %$uploads ) {
	481	my $files = $uploads->{$name};
	482	$files = ref $files eq 'ARRAY' ? $files : [$files];
	483	my @uploads;
	484	for my $upload (@$files) {
	485	my $u = Catalyst::Request::Upload->new;
	486	$u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
	487	$u->type( $u->headers->content_type );
	488	$u->tempname( $upload->{tempname} );
	489	$u->size( $upload->{size} );
	490	$u->filename( $upload->{filename} );
	491	push @uploads, $u;
	492	}
	493	$c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
f4a57de4	494
c4bed79a	495	# support access to the filename as a normal param
c4bed79a	496	my @filenames = map { $_->{filename} } @uploads;
a7e05d9d	497	# append, if there's already params with this name
	498	if (exists $c->request->parameters->{$name}) {
	499	if (ref $c->request->parameters->{$name} eq 'ARRAY') {
	500	push @{ $c->request->parameters->{$name} }, @filenames;
	501	}
	502	else {
	503	$c->request->parameters->{$name} =
	504	[ $c->request->parameters->{$name}, @filenames ];
	505	}
	506	}
	507	else {
	508	$c->request->parameters->{$name} =
	509	@filenames > 1 ? \@filenames : $filenames[0];
	510	}
fbcc39ad	511	}
	512	}
	513
b5ecfcf0	514	=head2 $self->prepare_write($c)
c9afa5fc	515
4ab87e27	516	Abstract method. Implemented by the engines.
4ab87e27	517
c9afa5fc	518	=cut
c9afa5fc	519
fbcc39ad	520	sub prepare_write { }
fbcc39ad	521
b5ecfcf0	522	=head2 $self->read($c, [$maxlength])
fbcc39ad	523
	524	=cut
	525
	526	sub read {
	527	my ( $self, $c, $maxlength ) = @_;
4f5ebacd	528
fbcc39ad	529	unless ( $self->{_prepared_read} ) {
4f5ebacd	530	$self->prepare_read($c);
fbcc39ad	531	$self->{_prepared_read} = 1;
fbcc39ad	532	}
4f5ebacd	533
fbcc39ad	534	my $remaining = $self->read_length - $self->read_position;
4bd82c41	535	$maxlength \|\|= $CHUNKSIZE;
4f5ebacd	536
fbcc39ad	537	# Are we done reading?
fbcc39ad	538	if ( $remaining <= 0 ) {
4f5ebacd	539	$self->finalize_read($c);
fbcc39ad	540	return;
fbcc39ad	541	}
c9afa5fc	542
fbcc39ad	543	my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
	544	my $rc = $self->read_chunk( $c, my $buffer, $readlen );
	545	if ( defined $rc ) {
	546	$self->read_position( $self->read_position + $rc );
	547	return $buffer;
	548	}
	549	else {
4f5ebacd	550	Catalyst::Exception->throw(
4f5ebacd	551	message => "Unknown error reading input: $!" );
fbcc39ad	552	}
fbcc39ad	553	}
fc7ec1d9	554
b5ecfcf0	555	=head2 $self->read_chunk($c, $buffer, $length)
23f9d934	556
fbcc39ad	557	Each engine inplements read_chunk as its preferred way of reading a chunk
fbcc39ad	558	of data.
fc7ec1d9	559
fbcc39ad	560	=cut
61b1e958	561
fbcc39ad	562	sub read_chunk { }
61b1e958	563
b5ecfcf0	564	=head2 $self->read_length
ca39d576	565
fbcc39ad	566	The length of input data to be read. This is obtained from the Content-Length
fbcc39ad	567	header.
fc7ec1d9	568
b5ecfcf0	569	=head2 $self->read_position
fc7ec1d9	570
fbcc39ad	571	The amount of input data that has already been read.
63b763c5	572
b5ecfcf0	573	=head2 $self->run($c)
63b763c5	574
4ab87e27	575	Start the engine. Implemented by the various engine classes.
4ab87e27	576
fbcc39ad	577	=cut
fc7ec1d9	578
fbcc39ad	579	sub run { }
fc7ec1d9	580
b5ecfcf0	581	=head2 $self->write($c, $buffer)
fc7ec1d9	582
4ab87e27	583	Writes the buffer to the client. Can only be called once for a request.
4ab87e27	584
fc7ec1d9	585	=cut
fc7ec1d9	586
fbcc39ad	587	sub write {
fbcc39ad	588	my ( $self, $c, $buffer ) = @_;
4f5ebacd	589
fbcc39ad	590	unless ( $self->{_prepared_write} ) {
4f5ebacd	591	$self->prepare_write($c);
fbcc39ad	592	$self->{_prepared_write} = 1;
fc7ec1d9	593	}
4f5ebacd	594
4f5ebacd	595	print STDOUT $buffer;
fc7ec1d9	596	}
fc7ec1d9	597
34d28dfd	598
4ab87e27	599	=head2 $self->finalize_output
	600
	601	<obsolete>, see finalize_body
	602
fbcc39ad	603	=head1 AUTHORS
	604
	605	Sebastian Riedel, <sri@cpan.org>
fc7ec1d9	606
fbcc39ad	607	Andy Grundman, <andy@hybridized.org>
fc7ec1d9	608
	609	=head1 COPYRIGHT
	610
	611	This program is free software, you can redistribute it and/or modify it under
	612	the same terms as Perl itself.
	613
	614	=cut
	615
	616	1;