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

package Catalyst::Engine;

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

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

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

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

=head1 NAME

Catalyst::Engine - The Catalyst Engine

=head1 SYNOPSIS

See L<Catalyst>.

=head1 DESCRIPTION

=head1 METHODS

=head2 $self->finalize_output

<obsolete>, see finalize_body

=head2 $self->finalize_body($c)

Finalize body.  Prints the response output.

=cut

sub finalize_body {
    my ( $self, $c ) = @_;
    if ( ref $c->response->body && $c->response->body->can('read') ) {
        while ( !$c->response->body->eof() ) {
            $c->response->body->read( my $buffer, $CHUNKSIZE );
            last unless $self->write( $c, $buffer );
        }
        $c->response->body->close();
    }
    else {
        $self->write( $c, $c->response->body );
    }
}

=head2 $self->finalize_cookies($c)

=cut

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

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

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

        push @cookies, $cookie->as_string;
    }

    for my $cookie (@cookies) {
        $c->res->headers->push_header( 'Set-Cookie' => $cookie );
    }
}

=head2 $self->finalize_error($c)

=cut

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

    $c->res->content_type('text/html; charset=utf-8');
    my $name = $c->config->{name} || 'Catalyst Application';

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

        # For pretty dumps
        local $Data::Dumper::Terse = 1;
        $error = join '', map {
                '<p><code class="error">'
              . encode_entities($_)
              . '</code></p>'
        } @{ $c->error };
        $error ||= 'No output';
        $error = "<pre>$error</pre>";
        $title = $name = "$name on Catalyst $Catalyst::VERSION";
        $name  = "<h1>$name</h1>";

        # Don't show context in the dump
        delete $c->req->{_context};
        delete $c->res->{_context};

        # Don't show body parser in the dump
        delete $c->req->{_body};

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

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

        my @infos;
        my $i = 0;
        for my $dump ( $c->dump_these ) {
            my $name  = $dump->[0];
            my $value = encode_entities( Dumper $dump->[1] );
            push @infos, sprintf <<"EOF", $name, $value;
<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
<div id="dump_$i">
    <pre>%s</pre>
</div>
EOF
            $i++;
        }
        $infos = join "\n", @infos;
    }
    else {
        $title = $name;
        $error = '';
        $infos = <<"";
<pre>
(en) Please come back later
(de) Bitte versuchen sie es spaeter nocheinmal
(at) Konnten's bitt'schoen spaeter nochmal reinschauen
(no) Vennligst prov igjen senere
(dk) Venligst prov igen senere
(pl) Prosze sprobowac pozniej
</pre>

        $name = '';
    }
    $c->res->body( <<"" );
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
    <meta http-equiv="Content-Language" content="en" />
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
    <title>$title</title>
    <script type="text/javascript">
        <!--
        function toggleDump (dumpElement) {
            var e = document.getElementById( dumpElement );
            if (e.style.display == "none") {
                e.style.display = "";
            }
            else {
                e.style.display = "none";
            }
        }
        -->
    </script>
    <style type="text/css">
        body {
            font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
                         Tahoma, Arial, helvetica, sans-serif;
            color: #ddd;
            background-color: #eee;
            margin: 0px;
            padding: 0px;
        }
        :link, :link:hover, :visited, :visited:hover {
            color: #ddd;
        }
        div.box {
            position: relative;
            background-color: #ccc;
            border: 1px solid #aaa;
            padding: 4px;
            margin: 10px;
            -moz-border-radius: 10px;
        }
        div.error {
            background-color: #977;
            border: 1px solid #755;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
            -moz-border-radius: 10px;
        }
        div.infos {
            background-color: #797;
            border: 1px solid #575;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
            -moz-border-radius: 10px;
        }
        div.name {
            background-color: #779;
            border: 1px solid #557;
            padding: 8px;
            margin: 4px;
            -moz-border-radius: 10px;
        }
        code.error {
            display: block;
            margin: 1em 0;
            overflow: auto;
        }
        div.name h1, div.error p {
            margin: 0;
        }
        h2 {
            margin-top: 0;
            margin-bottom: 10px;
            font-size: medium;
            font-weight: bold;
            text-decoration: underline;
        }
        h1 {
            font-size: medium;
            font-weight: normal;
        }
    </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)

=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)

=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)

=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 );
    }

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

=head2 $self->prepare_body_chunk($c)

=cut

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

    $c->request->{_body}->add($chunk);
}

=head2 $self->prepare_body_parameters($c)

=cut

sub prepare_body_parameters {
    my ( $self, $c ) = @_;
    $c->request->body_parameters( $c->request->{_body}->param );
}

=head2 $self->prepare_connection($c)

=cut

sub prepare_connection { }

=head2 $self->prepare_cookies($c)

=cut

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

    if ( my $header = $c->request->header('Cookie') ) {
        $c->req->cookies( { CGI::Cookie->parse($header) } );
    }
}

=head2 $self->prepare_headers($c)

=cut

sub prepare_headers { }

=head2 $self->prepare_parameters($c)

=cut

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

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

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

=head2 $self->prepare_path($c)

=cut

sub prepare_path { }

=head2 $self->prepare_request($c)

=head2 $self->prepare_query_parameters($c)

=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)

=cut

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

    # Reset the read position
    $self->read_position(0);
}

=head2 $self->prepare_request(@arguments)

=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)

=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)

=cut

sub run { }

=head2 $self->write($c, $buffer)

=cut

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

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

    print STDOUT $buffer;
}

=head1 AUTHORS

Sebastian Riedel, <sri@cpan.org>

Andy Grundman, <andy@hybridized.org>

=head1 COPYRIGHT

This program is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

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