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

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