[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->headers->content_type('text/html');
    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;

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