[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';
        $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
(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 {
            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>

}

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