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

        my @infos;
        my $i = 0;
        for my $dump ( $c->dump_these ) {
            my $name  = $dump->[0];
            my $value = encode_entities( Dumper $dump->[1] );
            push @infos, sprintf <<"EOF", $name, $value;
<div>
    <b><u>
        <a href="#" onclick="toggleDump(dump_$i); return false">%s</a>
    </u></b>
</div>
<br/>
<div id="dump_$i">
    <pre>%s</pre>
</div>
EOF
            $i++;
        }
        $infos = join "\n", @infos;
    }
    else {
        $title = $name;
        $error = '';
        $infos = <<"";
<pre>
(en) Please come back later
(de) Bitte versuchen sie es spaeter nocheinmal
(nl) Gelieve te komen later terug
(no) Vennligst prov igjen senere
(fr) Veuillez revenir plus tard
(es) Vuelto por favor mas adelante
(pt) Voltado por favor mais tarde
(it) Ritornato prego più successivamente
</pre>

        $name = '';
    }
    $c->res->body( <<"" );
<html>
<head>
    <title>$title</title>
    <script language="JavaScript">
        <!--
        function toggleDump (dumpElement) {
            if (dumpElement.style.display == "none") {
                dumpElement.style.display = "";
            }
            else {
                dumpElement.style.display = "none";
            }
        }
        -->
    </script>
    <style type="text/css">
        body {
            font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
                         Tahoma, Arial, helvetica, sans-serif;
            color: #ddd;
            background-color: #eee;
            margin: 0px;
            padding: 0px;
        }
        :link, :link:hover, :visited, :visited:hover {
            color: #ddd;
        }
        div.box {
            background-color: #ccc;
            border: 1px solid #aaa;
            padding: 4px;
            margin: 10px;
            -moz-border-radius: 10px;
        }
        div.error {
            background-color: #977;
            border: 1px solid #755;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
            -moz-border-radius: 10px;
        }
        div.infos {
            background-color: #797;
            border: 1px solid #575;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
            -moz-border-radius: 10px;
        }
        div.name {
            background-color: #779;
            border: 1px solid #557;
            padding: 8px;
            margin: 4px;
            -moz-border-radius: 10px;
        }
        code.error {
            display: block;
            margin: 1em 0;
            overflow: auto;
            white-space: pre;
        }
    </style>
</head>
<body>
    <div class="box">
        <div class="error">$error</div>
        <div class="infos">$infos</div>
        <div class="name">$name</div>
    </div>
</body>
</html>

}

=item $self->finalize_headers($c)

=cut

sub finalize_headers { }

=item $self->finalize_read($c)

=cut

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

    undef $self->{_prepared_read};
}

=item $self->finalize_uploads($c)

=cut

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

    if ( keys %{ $c->request->uploads } ) {
        for my $key ( keys %{ $c->request->uploads } ) {
            my $upload = $c->request->uploads->{$key};
            unlink map { $_->tempname }
              grep     { -e $_->tempname }
              ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
        }
    }
}

=item $self->prepare_body($c)

=cut

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

    $self->read_length( $c->request->header('Content-Length') || 0 );
    my $type = $c->request->header('Content-Type');

    unless ( $c->request->{_body} ) {
        $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
    }

    if ( $self->read_length > 0 ) {
        while ( my $buffer = $self->read($c) ) {
            $c->prepare_body_chunk($buffer);
        }
    }
}

=item $self->prepare_body_chunk($c)

=cut

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

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

=item $self->prepare_body_parameters($c)

=cut

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

=item $self->prepare_connection($c)

=cut

sub prepare_connection { }

=item $self->prepare_cookies($c)

=cut

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

    if ( my $header = $c->request->header('Cookie') ) {
        $c->req->cookies( { CGI::Cookie->parse($header) } );
    }
}

=item $self->prepare_headers($c)

=cut

sub prepare_headers { }

=item $self->prepare_parameters($c)

=cut

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

    # We copy, no references
    while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
        $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
        $c->request->parameters->{$name} = $param;
    }

    # Merge query and body parameters
    while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
        $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
        if ( my $old_param = $c->request->parameters->{$name} ) {
            if ( ref $old_param eq 'ARRAY' ) {
                push @{ $c->request->parameters->{$name} },
                  ref $param eq 'ARRAY' ? @$param : $param;
            }
            else { $c->request->parameters->{$name} = [ $old_param, $param ] }
        }
        else { $c->request->parameters->{$name} = $param }
    }
}

=item $self->prepare_path($c)

=cut

sub prepare_path { }

=item $self->prepare_request($c)

=item $self->prepare_query_parameters($c)

=cut

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

    # replace semi-colons
    $query_string =~ s/;/&/g;

    my $u = URI->new( '', 'http' );
    $u->query($query_string);
    for my $key ( $u->query_param ) {
        my @vals = $u->query_param($key);
        $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
    }
}

=item $self->prepare_read($c)

=cut

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

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

=item $self->prepare_request(@arguments)

=cut

sub prepare_request { }

=item $self->prepare_uploads($c)

=cut

sub prepare_uploads {
    my ( $self, $c ) = @_;
    my $uploads = $c->request->{_body}->upload;
    for my $name ( keys %$uploads ) {
        my $files = $uploads->{$name};
        $files = ref $files eq 'ARRAY' ? $files : [$files];
        my @uploads;
        for my $upload (@$files) {
            my $u = Catalyst::Request::Upload->new;
            $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
            $u->type( $u->headers->content_type );
            $u->tempname( $upload->{tempname} );
            $u->size( $upload->{size} );
            $u->filename( $upload->{filename} );
            push @uploads, $u;
        }
        $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];

        # support access to the filename as a normal param
        my @filenames = map { $_->{filename} } @uploads;
        $c->request->parameters->{$name} =
          @filenames > 1 ? \@filenames : $filenames[0];
    }
}

=item $self->prepare_write($c)

=cut

sub prepare_write { }

=item $self->read($c, [$maxlength])

=cut

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

    unless ( $self->{_prepared_read} ) {
        $self->prepare_read($c);
        $self->{_prepared_read} = 1;
    }

    my $remaining = $self->read_length - $self->read_position;
    $maxlength ||= $CHUNKSIZE;

    # Are we done reading?
    if ( $remaining <= 0 ) {
        $self->finalize_read($c);
        return;
    }

    my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
    my $rc = $self->read_chunk( $c, my $buffer, $readlen );
    if ( defined $rc ) {
        $self->read_position( $self->read_position + $rc );
        return $buffer;
    }
    else {
        Catalyst::Exception->throw(
            message => "Unknown error reading input: $!" );
    }
}

=item $self->read_chunk($c, $buffer, $length)

Each engine inplements read_chunk as its preferred way of reading a chunk
of data.

=cut

sub read_chunk { }

=item $self->read_length

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

=item $self->read_position

The amount of input data that has already been read.

=item $self->run($c)

=cut

sub run { }

=item $self->write($c, $buffer)

=cut

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

    unless ( $self->{_prepared_write} ) {
        $self->prepare_write($c);
        $self->{_prepared_write} = 1;
    }

    print STDOUT $buffer;
}

=back

=head1 AUTHORS

Sebastian Riedel, <sri@cpan.org>

Andy Grundman, <andy@hybridized.org>

=head1 COPYRIGHT

This program is free software, you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

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