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