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

        # paranoia against wrong Content-Length header
        my $remaining = $self->read_length - $self->read_position;
        if ($remaining > 0) {
            $self->finalize_read($c);
            Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
        }
    }
}

=head2 $self->prepare_body_chunk($c)

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