[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 = 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 $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 wrap="">%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;
        }
        /* 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)

=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';
2666dd3b	105	$error = qq{<pre wrap="">$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">
2666dd3b	131	<pre wrap="">%s</pre>
c6ef5e69	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	}
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
	266	=cut
	267
	268	sub finalize_headers { }
	269
b5ecfcf0	270	=head2 $self->finalize_read($c)
fc7ec1d9	271
	272	=cut
	273
fbcc39ad	274	sub finalize_read {
fbcc39ad	275	my ( $self, $c ) = @_;
4f5ebacd	276
fbcc39ad	277	undef $self->{_prepared_read};
fc7ec1d9	278	}
fc7ec1d9	279
b5ecfcf0	280	=head2 $self->finalize_uploads($c)
fc7ec1d9	281
	282	=cut
	283
fbcc39ad	284	sub finalize_uploads {
fbcc39ad	285	my ( $self, $c ) = @_;
99fe1710	286
fbcc39ad	287	if ( keys %{ $c->request->uploads } ) {
	288	for my $key ( keys %{ $c->request->uploads } ) {
	289	my $upload = $c->request->uploads->{$key};
	290	unlink map { $_->tempname }
	291	grep { -e $_->tempname }
	292	ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
c85ff642	293	}
c85ff642	294	}
fc7ec1d9	295	}
fc7ec1d9	296
b5ecfcf0	297	=head2 $self->prepare_body($c)
fc7ec1d9	298
	299	=cut
	300
fbcc39ad	301	sub prepare_body {
fbcc39ad	302	my ( $self, $c ) = @_;
99fe1710	303
fbcc39ad	304	$self->read_length( $c->request->header('Content-Length') \|\| 0 );
fbcc39ad	305	my $type = $c->request->header('Content-Type');
99fe1710	306
fbcc39ad	307	unless ( $c->request->{_body} ) {
fbcc39ad	308	$c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
fc7ec1d9	309	}
4f5ebacd	310
fbcc39ad	311	if ( $self->read_length > 0 ) {
4f5ebacd	312	while ( my $buffer = $self->read($c) ) {
4f5ebacd	313	$c->prepare_body_chunk($buffer);
fbcc39ad	314	}
fc7ec1d9	315	}
	316	}
	317
b5ecfcf0	318	=head2 $self->prepare_body_chunk($c)
4bd82c41	319
	320	=cut
	321
	322	sub prepare_body_chunk {
	323	my ( $self, $c, $chunk ) = @_;
4f5ebacd	324
4f5ebacd	325	$c->request->{_body}->add($chunk);
4bd82c41	326	}
4bd82c41	327
b5ecfcf0	328	=head2 $self->prepare_body_parameters($c)
06e1b616	329
	330	=cut
	331
fbcc39ad	332	sub prepare_body_parameters {
	333	my ( $self, $c ) = @_;
	334	$c->request->body_parameters( $c->request->{_body}->param );
	335	}
0556eb49	336
b5ecfcf0	337	=head2 $self->prepare_connection($c)
0556eb49	338
	339	=cut
	340
	341	sub prepare_connection { }
	342
b5ecfcf0	343	=head2 $self->prepare_cookies($c)
fc7ec1d9	344
	345	=cut
	346
6dc87a0f	347	sub prepare_cookies {
fbcc39ad	348	my ( $self, $c ) = @_;
6dc87a0f	349
	350	if ( my $header = $c->request->header('Cookie') ) {
	351	$c->req->cookies( { CGI::Cookie->parse($header) } );
	352	}
	353	}
fc7ec1d9	354
b5ecfcf0	355	=head2 $self->prepare_headers($c)
fc7ec1d9	356
	357	=cut
	358
	359	sub prepare_headers { }
	360
b5ecfcf0	361	=head2 $self->prepare_parameters($c)
fc7ec1d9	362
	363	=cut
	364
fbcc39ad	365	sub prepare_parameters {
fbcc39ad	366	my ( $self, $c ) = @_;
fc7ec1d9	367
fbcc39ad	368	# We copy, no references
	369	while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
	370	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	371	$c->request->parameters->{$name} = $param;
	372	}
fc7ec1d9	373
fbcc39ad	374	# Merge query and body parameters
	375	while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
	376	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	377	if ( my $old_param = $c->request->parameters->{$name} ) {
	378	if ( ref $old_param eq 'ARRAY' ) {
	379	push @{ $c->request->parameters->{$name} },
	380	ref $param eq 'ARRAY' ? @$param : $param;
	381	}
	382	else { $c->request->parameters->{$name} = [ $old_param, $param ] }
	383	}
	384	else { $c->request->parameters->{$name} = $param }
	385	}
	386	}
	387
b5ecfcf0	388	=head2 $self->prepare_path($c)
fc7ec1d9	389
	390	=cut
	391
	392	sub prepare_path { }
	393
b5ecfcf0	394	=head2 $self->prepare_request($c)
fc7ec1d9	395
b5ecfcf0	396	=head2 $self->prepare_query_parameters($c)
fc7ec1d9	397
	398	=cut
	399
e0616220	400	sub prepare_query_parameters {
	401	my ( $self, $c, $query_string ) = @_;
	402
	403	# replace semi-colons
	404	$query_string =~ s/;/&/g;
	405
	406	my $u = URI->new( '', 'http' );
f4a57de4	407	$u->query($query_string);
	408	for my $key ( $u->query_param ) {
	409	my @vals = $u->query_param($key);
	410	$c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
e0616220	411	}
e0616220	412	}
fbcc39ad	413
b5ecfcf0	414	=head2 $self->prepare_read($c)
fbcc39ad	415
fbcc39ad	416	=cut
fc7ec1d9	417
fbcc39ad	418	sub prepare_read {
fbcc39ad	419	my ( $self, $c ) = @_;
4f5ebacd	420
fbcc39ad	421	# Reset the read position
4f5ebacd	422	$self->read_position(0);
fbcc39ad	423	}
fc7ec1d9	424
b5ecfcf0	425	=head2 $self->prepare_request(@arguments)
fc7ec1d9	426
	427	=cut
	428
fbcc39ad	429	sub prepare_request { }
fc7ec1d9	430
b5ecfcf0	431	=head2 $self->prepare_uploads($c)
c9afa5fc	432
fbcc39ad	433	=cut
	434
	435	sub prepare_uploads {
	436	my ( $self, $c ) = @_;
	437	my $uploads = $c->request->{_body}->upload;
	438	for my $name ( keys %$uploads ) {
	439	my $files = $uploads->{$name};
	440	$files = ref $files eq 'ARRAY' ? $files : [$files];
	441	my @uploads;
	442	for my $upload (@$files) {
	443	my $u = Catalyst::Request::Upload->new;
	444	$u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
	445	$u->type( $u->headers->content_type );
	446	$u->tempname( $upload->{tempname} );
	447	$u->size( $upload->{size} );
	448	$u->filename( $upload->{filename} );
	449	push @uploads, $u;
	450	}
	451	$c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
f4a57de4	452
c4bed79a	453	# support access to the filename as a normal param
c4bed79a	454	my @filenames = map { $_->{filename} } @uploads;
f4a57de4	455	$c->request->parameters->{$name} =
f4a57de4	456	@filenames > 1 ? \@filenames : $filenames[0];
fbcc39ad	457	}
	458	}
	459
b5ecfcf0	460	=head2 $self->prepare_write($c)
c9afa5fc	461
	462	=cut
	463
fbcc39ad	464	sub prepare_write { }
fbcc39ad	465
b5ecfcf0	466	=head2 $self->read($c, [$maxlength])
fbcc39ad	467
	468	=cut
	469
	470	sub read {
	471	my ( $self, $c, $maxlength ) = @_;
4f5ebacd	472
fbcc39ad	473	unless ( $self->{_prepared_read} ) {
4f5ebacd	474	$self->prepare_read($c);
fbcc39ad	475	$self->{_prepared_read} = 1;
fbcc39ad	476	}
4f5ebacd	477
fbcc39ad	478	my $remaining = $self->read_length - $self->read_position;
4bd82c41	479	$maxlength \|\|= $CHUNKSIZE;
4f5ebacd	480
fbcc39ad	481	# Are we done reading?
fbcc39ad	482	if ( $remaining <= 0 ) {
4f5ebacd	483	$self->finalize_read($c);
fbcc39ad	484	return;
fbcc39ad	485	}
c9afa5fc	486
fbcc39ad	487	my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
	488	my $rc = $self->read_chunk( $c, my $buffer, $readlen );
	489	if ( defined $rc ) {
	490	$self->read_position( $self->read_position + $rc );
	491	return $buffer;
	492	}
	493	else {
4f5ebacd	494	Catalyst::Exception->throw(
4f5ebacd	495	message => "Unknown error reading input: $!" );
fbcc39ad	496	}
fbcc39ad	497	}
fc7ec1d9	498
b5ecfcf0	499	=head2 $self->read_chunk($c, $buffer, $length)
23f9d934	500
fbcc39ad	501	Each engine inplements read_chunk as its preferred way of reading a chunk
fbcc39ad	502	of data.
fc7ec1d9	503
fbcc39ad	504	=cut
61b1e958	505
fbcc39ad	506	sub read_chunk { }
61b1e958	507
b5ecfcf0	508	=head2 $self->read_length
ca39d576	509
fbcc39ad	510	The length of input data to be read. This is obtained from the Content-Length
fbcc39ad	511	header.
fc7ec1d9	512
b5ecfcf0	513	=head2 $self->read_position
fc7ec1d9	514
fbcc39ad	515	The amount of input data that has already been read.
63b763c5	516
b5ecfcf0	517	=head2 $self->run($c)
63b763c5	518
fbcc39ad	519	=cut
fc7ec1d9	520
fbcc39ad	521	sub run { }
fc7ec1d9	522
b5ecfcf0	523	=head2 $self->write($c, $buffer)
fc7ec1d9	524
	525	=cut
	526
fbcc39ad	527	sub write {
fbcc39ad	528	my ( $self, $c, $buffer ) = @_;
4f5ebacd	529
fbcc39ad	530	unless ( $self->{_prepared_write} ) {
4f5ebacd	531	$self->prepare_write($c);
fbcc39ad	532	$self->{_prepared_write} = 1;
fc7ec1d9	533	}
4f5ebacd	534
4f5ebacd	535	print STDOUT $buffer;
fc7ec1d9	536	}
fc7ec1d9	537
fbcc39ad	538	=head1 AUTHORS
	539
	540	Sebastian Riedel, <sri@cpan.org>
fc7ec1d9	541
fbcc39ad	542	Andy Grundman, <andy@hybridized.org>
fc7ec1d9	543
	544	=head1 COPYRIGHT
	545
	546	This program is free software, you can redistribute it and/or modify it under
	547	the same terms as Perl itself.
	548
	549	=cut
	550
	551	1;