[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;
    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::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;
        $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;
34d28dfd	44	if ( ref $body && ( $body->can('read') \|\| ref($body) eq 'GLOB' ) ) {
7257e9db	45	while ( !eof $body ) {
4c423abf	46	read $body, my ($buffer), $CHUNKSIZE;
6484fba0	47	last unless $self->write( $c, $buffer );
f4a57de4	48	}
7257e9db	49	close $body;
f4a57de4	50	}
f4a57de4	51	else {
7257e9db	52	$self->write( $c, $body );
f4a57de4	53	}
fbcc39ad	54	}
6dc87a0f	55
b5ecfcf0	56	=head2 $self->finalize_cookies($c)
6dc87a0f	57
fa32ac82	58	Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
fa32ac82	59	response headers.
4ab87e27	60
6dc87a0f	61	=cut
	62
	63	sub finalize_cookies {
fbcc39ad	64	my ( $self, $c ) = @_;
6dc87a0f	65
fbcc39ad	66	my @cookies;
c82ed742	67
	68	foreach my $name ( keys %{ $c->response->cookies } ) {
	69
	70	my $val = $c->response->cookies->{$name};
fbcc39ad	71
2832cb5d	72	my $cookie = (
	73	Scalar::Util::blessed($val)
	74	? $val
	75	: CGI::Simple::Cookie->new(
	76	-name => $name,
	77	-value => $val->{value},
	78	-expires => $val->{expires},
	79	-domain => $val->{domain},
	80	-path => $val->{path},
	81	-secure => $val->{secure} \|\| 0
	82	)
6dc87a0f	83	);
6dc87a0f	84
fbcc39ad	85	push @cookies, $cookie->as_string;
6dc87a0f	86	}
6dc87a0f	87
b39840da	88	for my $cookie (@cookies) {
b39840da	89	$c->res->headers->push_header( 'Set-Cookie' => $cookie );
fbcc39ad	90	}
fbcc39ad	91	}
969647fd	92
b5ecfcf0	93	=head2 $self->finalize_error($c)
969647fd	94
4ab87e27	95	Output an apropriate error message, called if there's an error in $c
	96	after the dispatch has finished. Will output debug messages if Catalyst
	97	is in debug mode, or a `please come back later` message otherwise.
	98
969647fd	99	=cut
	100
	101	sub finalize_error {
fbcc39ad	102	my ( $self, $c ) = @_;
969647fd	103
7299a7b4	104	$c->res->content_type('text/html; charset=utf-8');
34d28dfd	105	my $name = $c->config->{name} \|\| join(' ', split('::', ref $c));
969647fd	106
	107	my ( $title, $error, $infos );
	108	if ( $c->debug ) {
62d9b030	109
62d9b030	110	# For pretty dumps
b5ecfcf0	111	$error = join '', map {
	112	'<p><code class="error">'
	113	. encode_entities($_)
	114	. '</code></p>'
	115	} @{ $c->error };
969647fd	116	$error \|\|= 'No output';
2666dd3b	117	$error = qq{<pre wrap="">$error</pre>};
969647fd	118	$title = $name = "$name on Catalyst $Catalyst::VERSION";
d82cc9ae	119	$name = "<h1>$name</h1>";
fbcc39ad	120
	121	# Don't show context in the dump
	122	delete $c->req->{_context};
	123	delete $c->res->{_context};
	124
	125	# Don't show body parser in the dump
	126	delete $c->req->{_body};
	127
	128	# Don't show response header state in dump
	129	delete $c->res->{_finalized_headers};
	130
c6ef5e69	131	my @infos;
c6ef5e69	132	my $i = 0;
c6ef5e69	133	for my $dump ( $c->dump_these ) {
c6ef5e69	134	my $name = $dump->[0];
f63c03e4	135	my $value = encode_entities( dump( $dump->[1] ));
c6ef5e69	136	push @infos, sprintf <<"EOF", $name, $value;
9619f23c	137	<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
c6ef5e69	138	<div id="dump_$i">
2666dd3b	139	<pre wrap="">%s</pre>
c6ef5e69	140	</div>
	141	EOF
	142	$i++;
	143	}
	144	$infos = join "\n", @infos;
969647fd	145	}
	146	else {
	147	$title = $name;
	148	$error = '';
	149	$infos = <<"";
	150	<pre>
	151	(en) Please come back later
0c2b4ac0	152	(fr) SVP veuillez revenir plus tard
969647fd	153	(de) Bitte versuchen sie es spaeter nocheinmal
d82cc9ae	154	(at) Konnten's bitt'schoen spaeter nochmal reinschauen
969647fd	155	(no) Vennligst prov igjen senere
d82cc9ae	156	(dk) Venligst prov igen senere
d82cc9ae	157	(pl) Prosze sprobowac pozniej
969647fd	158	</pre>
	159
	160	$name = '';
	161	}
e060fe05	162	$c->res->body( <<"" );
7299a7b4	163	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	164	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
	165	<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
969647fd	166	<head>
7299a7b4	167	<meta http-equiv="Content-Language" content="en" />
7299a7b4	168	<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
969647fd	169	<title>$title</title>
7299a7b4	170	<script type="text/javascript">
c6ef5e69	171	<!--
c6ef5e69	172	function toggleDump (dumpElement) {
7299a7b4	173	var e = document.getElementById( dumpElement );
	174	if (e.style.display == "none") {
	175	e.style.display = "";
c6ef5e69	176	}
c6ef5e69	177	else {
7299a7b4	178	e.style.display = "none";
c6ef5e69	179	}
	180	}
	181	-->
	182	</script>
969647fd	183	<style type="text/css">
	184	body {
	185	font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
	186	Tahoma, Arial, helvetica, sans-serif;
34d28dfd	187	color: #333;
969647fd	188	background-color: #eee;
	189	margin: 0px;
	190	padding: 0px;
	191	}
c6ef5e69	192	:link, :link:hover, :visited, :visited:hover {
34d28dfd	193	color: #000;
c6ef5e69	194	}
969647fd	195	div.box {
9619f23c	196	position: relative;
969647fd	197	background-color: #ccc;
	198	border: 1px solid #aaa;
	199	padding: 4px;
	200	margin: 10px;
969647fd	201	}
969647fd	202	div.error {
34d28dfd	203	background-color: #cce;
969647fd	204	border: 1px solid #755;
	205	padding: 8px;
	206	margin: 4px;
	207	margin-bottom: 10px;
969647fd	208	}
969647fd	209	div.infos {
34d28dfd	210	background-color: #eee;
969647fd	211	border: 1px solid #575;
	212	padding: 8px;
	213	margin: 4px;
	214	margin-bottom: 10px;
969647fd	215	}
969647fd	216	div.name {
34d28dfd	217	background-color: #cce;
969647fd	218	border: 1px solid #557;
	219	padding: 8px;
	220	margin: 4px;
969647fd	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 );
34d28dfd	320	$c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
34d28dfd	321	if exists $c->config->{uploadtmp};
fc7ec1d9	322	}
4f5ebacd	323
fbcc39ad	324	if ( $self->read_length > 0 ) {
4f5ebacd	325	while ( my $buffer = $self->read($c) ) {
4f5ebacd	326	$c->prepare_body_chunk($buffer);
fbcc39ad	327	}
fdb3773e	328
	329	# paranoia against wrong Content-Length header
	330	my $remaining = $self->read_length - $self->read_position;
34d28dfd	331	if ( $remaining > 0 ) {
fdb3773e	332	$self->finalize_read($c);
34d28dfd	333	Catalyst::Exception->throw(
34d28dfd	334	"Wrong Content-Length value: " . $self->read_length );
fdb3773e	335	}
fc7ec1d9	336	}
	337	}
	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
4ab87e27	353	Sets up parameters from body.
4ab87e27	354
06e1b616	355	=cut
06e1b616	356
fbcc39ad	357	sub prepare_body_parameters {
	358	my ( $self, $c ) = @_;
	359	$c->request->body_parameters( $c->request->{_body}->param );
	360	}
0556eb49	361
b5ecfcf0	362	=head2 $self->prepare_connection($c)
0556eb49	363
4ab87e27	364	Abstract method implemented in engines.
4ab87e27	365
0556eb49	366	=cut
	367
	368	sub prepare_connection { }
	369
b5ecfcf0	370	=head2 $self->prepare_cookies($c)
fc7ec1d9	371
fa32ac82	372	Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
4ab87e27	373
fc7ec1d9	374	=cut
fc7ec1d9	375
6dc87a0f	376	sub prepare_cookies {
fbcc39ad	377	my ( $self, $c ) = @_;
6dc87a0f	378
6dc87a0f	379	if ( my $header = $c->request->header('Cookie') ) {
fa32ac82	380	$c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
6dc87a0f	381	}
6dc87a0f	382	}
fc7ec1d9	383
b5ecfcf0	384	=head2 $self->prepare_headers($c)
fc7ec1d9	385
	386	=cut
	387
	388	sub prepare_headers { }
	389
b5ecfcf0	390	=head2 $self->prepare_parameters($c)
fc7ec1d9	391
4ab87e27	392	sets up parameters from query and post parameters.
4ab87e27	393
fc7ec1d9	394	=cut
fc7ec1d9	395
fbcc39ad	396	sub prepare_parameters {
fbcc39ad	397	my ( $self, $c ) = @_;
fc7ec1d9	398
fbcc39ad	399	# We copy, no references
c82ed742	400	foreach my $name ( keys %{ $c->request->query_parameters } ) {
c82ed742	401	my $param = $c->request->query_parameters->{$name};
fbcc39ad	402	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	403	$c->request->parameters->{$name} = $param;
	404	}
fc7ec1d9	405
fbcc39ad	406	# Merge query and body parameters
c82ed742	407	foreach my $name ( keys %{ $c->request->body_parameters } ) {
c82ed742	408	my $param = $c->request->body_parameters->{$name};
fbcc39ad	409	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	410	if ( my $old_param = $c->request->parameters->{$name} ) {
	411	if ( ref $old_param eq 'ARRAY' ) {
	412	push @{ $c->request->parameters->{$name} },
	413	ref $param eq 'ARRAY' ? @$param : $param;
	414	}
	415	else { $c->request->parameters->{$name} = [ $old_param, $param ] }
	416	}
	417	else { $c->request->parameters->{$name} = $param }
	418	}
	419	}
	420
b5ecfcf0	421	=head2 $self->prepare_path($c)
fc7ec1d9	422
4ab87e27	423	abstract method, implemented by engines.
4ab87e27	424
fc7ec1d9	425	=cut
	426
	427	sub prepare_path { }
	428
b5ecfcf0	429	=head2 $self->prepare_request($c)
fc7ec1d9	430
b5ecfcf0	431	=head2 $self->prepare_query_parameters($c)
fc7ec1d9	432
4ab87e27	433	process the query string and extract query parameters.
4ab87e27	434
fc7ec1d9	435	=cut
fc7ec1d9	436
e0616220	437	sub prepare_query_parameters {
	438	my ( $self, $c, $query_string ) = @_;
	439
	440	# replace semi-colons
	441	$query_string =~ s/;/&/g;
	442
	443	my $u = URI->new( '', 'http' );
f4a57de4	444	$u->query($query_string);
	445	for my $key ( $u->query_param ) {
	446	my @vals = $u->query_param($key);
	447	$c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
e0616220	448	}
e0616220	449	}
fbcc39ad	450
b5ecfcf0	451	=head2 $self->prepare_read($c)
fbcc39ad	452
4ab87e27	453	prepare to read from the engine.
4ab87e27	454
fbcc39ad	455	=cut
fc7ec1d9	456
fbcc39ad	457	sub prepare_read {
fbcc39ad	458	my ( $self, $c ) = @_;
4f5ebacd	459
fbcc39ad	460	# Reset the read position
4f5ebacd	461	$self->read_position(0);
fbcc39ad	462	}
fc7ec1d9	463
b5ecfcf0	464	=head2 $self->prepare_request(@arguments)
fc7ec1d9	465
4ab87e27	466	Populate the context object from the request object.
4ab87e27	467
fc7ec1d9	468	=cut
fc7ec1d9	469
fbcc39ad	470	sub prepare_request { }
fc7ec1d9	471
b5ecfcf0	472	=head2 $self->prepare_uploads($c)
c9afa5fc	473
fbcc39ad	474	=cut
	475
	476	sub prepare_uploads {
	477	my ( $self, $c ) = @_;
	478	my $uploads = $c->request->{_body}->upload;
	479	for my $name ( keys %$uploads ) {
	480	my $files = $uploads->{$name};
	481	$files = ref $files eq 'ARRAY' ? $files : [$files];
	482	my @uploads;
	483	for my $upload (@$files) {
	484	my $u = Catalyst::Request::Upload->new;
	485	$u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
	486	$u->type( $u->headers->content_type );
	487	$u->tempname( $upload->{tempname} );
	488	$u->size( $upload->{size} );
	489	$u->filename( $upload->{filename} );
	490	push @uploads, $u;
	491	}
	492	$c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
f4a57de4	493
c4bed79a	494	# support access to the filename as a normal param
c4bed79a	495	my @filenames = map { $_->{filename} } @uploads;
f4a57de4	496	$c->request->parameters->{$name} =
f4a57de4	497	@filenames > 1 ? \@filenames : $filenames[0];
fbcc39ad	498	}
	499	}
	500
b5ecfcf0	501	=head2 $self->prepare_write($c)
c9afa5fc	502
4ab87e27	503	Abstract method. Implemented by the engines.
4ab87e27	504
c9afa5fc	505	=cut
c9afa5fc	506
fbcc39ad	507	sub prepare_write { }
fbcc39ad	508
b5ecfcf0	509	=head2 $self->read($c, [$maxlength])
fbcc39ad	510
	511	=cut
	512
	513	sub read {
	514	my ( $self, $c, $maxlength ) = @_;
4f5ebacd	515
fbcc39ad	516	unless ( $self->{_prepared_read} ) {
4f5ebacd	517	$self->prepare_read($c);
fbcc39ad	518	$self->{_prepared_read} = 1;
fbcc39ad	519	}
4f5ebacd	520
fbcc39ad	521	my $remaining = $self->read_length - $self->read_position;
4bd82c41	522	$maxlength \|\|= $CHUNKSIZE;
4f5ebacd	523
fbcc39ad	524	# Are we done reading?
fbcc39ad	525	if ( $remaining <= 0 ) {
4f5ebacd	526	$self->finalize_read($c);
fbcc39ad	527	return;
fbcc39ad	528	}
c9afa5fc	529
fbcc39ad	530	my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
	531	my $rc = $self->read_chunk( $c, my $buffer, $readlen );
	532	if ( defined $rc ) {
	533	$self->read_position( $self->read_position + $rc );
	534	return $buffer;
	535	}
	536	else {
4f5ebacd	537	Catalyst::Exception->throw(
4f5ebacd	538	message => "Unknown error reading input: $!" );
fbcc39ad	539	}
fbcc39ad	540	}
fc7ec1d9	541
b5ecfcf0	542	=head2 $self->read_chunk($c, $buffer, $length)
23f9d934	543
fbcc39ad	544	Each engine inplements read_chunk as its preferred way of reading a chunk
fbcc39ad	545	of data.
fc7ec1d9	546
fbcc39ad	547	=cut
61b1e958	548
fbcc39ad	549	sub read_chunk { }
61b1e958	550
b5ecfcf0	551	=head2 $self->read_length
ca39d576	552
fbcc39ad	553	The length of input data to be read. This is obtained from the Content-Length
fbcc39ad	554	header.
fc7ec1d9	555
b5ecfcf0	556	=head2 $self->read_position
fc7ec1d9	557
fbcc39ad	558	The amount of input data that has already been read.
63b763c5	559
b5ecfcf0	560	=head2 $self->run($c)
63b763c5	561
4ab87e27	562	Start the engine. Implemented by the various engine classes.
4ab87e27	563
fbcc39ad	564	=cut
fc7ec1d9	565
fbcc39ad	566	sub run { }
fc7ec1d9	567
b5ecfcf0	568	=head2 $self->write($c, $buffer)
fc7ec1d9	569
4ab87e27	570	Writes the buffer to the client. Can only be called once for a request.
4ab87e27	571
fc7ec1d9	572	=cut
fc7ec1d9	573
fbcc39ad	574	sub write {
fbcc39ad	575	my ( $self, $c, $buffer ) = @_;
4f5ebacd	576
fbcc39ad	577	unless ( $self->{_prepared_write} ) {
4f5ebacd	578	$self->prepare_write($c);
fbcc39ad	579	$self->{_prepared_write} = 1;
fc7ec1d9	580	}
4f5ebacd	581
4f5ebacd	582	print STDOUT $buffer;
fc7ec1d9	583	}
fc7ec1d9	584
34d28dfd	585
4ab87e27	586	=head2 $self->finalize_output
	587
	588	<obsolete>, see finalize_body
	589
fbcc39ad	590	=head1 AUTHORS
	591
	592	Sebastian Riedel, <sri@cpan.org>
fc7ec1d9	593
fbcc39ad	594	Andy Grundman, <andy@hybridized.org>
fc7ec1d9	595
	596	=head1 COPYRIGHT
	597
	598	This program is free software, you can redistribute it and/or modify it under
	599	the same terms as Perl itself.
	600
	601	=cut
	602
	603	1;