[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

=over 4

=item $self->finalize_output

<obsolete>, see finalize_body

=item $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 );
            $self->write( $c, $buffer );
        }
        $c->response->body->close();
    }
    else {
        $self->write( $c, $c->response->body );
    }
}

=item $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;
    }

    if (@cookies) {
        $c->res->headers->push_header( 'Set-Cookie' => join ',', @cookies );
    }
}

=item $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 { '<code class="error">' . encode_entities($_) . '</code>' }
          @{ $c->error };
        $error ||= 'No output';
        $title = $name = "$name on Catalyst $Catalyst::VERSION";

        # 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;
<div>
    <b><u>
        <a href="#" onclick="toggleDump('dump_$i'); return false">%s</a>
    </u></b>
</div>
<br/>
<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
(nl) Gelieve te komen later terug
(no) Vennligst prov igjen senere
(fr) Veuillez revenir plus tard
(es) Vuelto por favor mas adelante
(pt) Voltado por favor mais tarde
(it) Ritornato prego più successivamente
</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 {
            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;
            white-space: pre;
        }
    </style>
</head>
<body>
    <div class="box">
        <div class="error">$error</div>
        <div class="infos">$infos</div>
        <div class="name">$name</div>
    </div>
</body>
</html>

}

=item $self->finalize_headers($c)

=cut

sub finalize_headers { }

=item $self->finalize_read($c)

=cut

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

    undef $self->{_prepared_read};
}

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

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

=item $self->prepare_body_chunk($c)

=cut

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

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

=item $self->prepare_body_parameters($c)

=cut

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

=item $self->prepare_connection($c)

=cut

sub prepare_connection { }

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

=item $self->prepare_headers($c)

=cut

sub prepare_headers { }

=item $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 }
    }
}

=item $self->prepare_path($c)

=cut

sub prepare_path { }

=item $self->prepare_request($c)

=item $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];
    }
}

=item $self->prepare_read($c)

=cut

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

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

=item $self->prepare_request(@arguments)

=cut

sub prepare_request { }

=item $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];
    }
}

=item $self->prepare_write($c)

=cut

sub prepare_write { }

=item $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: $!" );
    }
}

=item $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 { }

=item $self->read_length

The length of input data to be read.  This is obtained from the Content-Length
header.

=item $self->read_position

The amount of input data that has already been read.

=item $self->run($c)

=cut

sub run { }

=item $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;
}

=back

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