[catagits/Catalyst-Runtime.git] / lib / Catalyst / Engine.pm

package Catalyst::Engine;

use strict;
use base 'Class::Accessor::Fast';
use CGI::Cookie;
use Data::Dump qw/dump/;
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_body($c)

Finalize body.  Prints the response output.

=cut

sub finalize_body {
    my ( $self, $c ) = @_;
    my $body = $c->response->body;
    if ( ref $body && ( $body->can('read') || ref($body) eq 'GLOB' ) ) {
        while ( !eof $body ) {
            read $body, my ($buffer), $CHUNKSIZE;
            last unless $self->write( $c, $buffer );
        }
        close $body;
    }
    else {
        $self->write( $c, $body );
    }
}

=head2 $self->finalize_cookies($c)

Create CGI::Cookies from $c->res->cookies, and set them as response headers.

=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)

Output an apropriate error message, called if there's an error in $c
after the dispatch has finished. Will output debug messages if Catalyst
is in debug mode, or a `please come back later` message otherwise.

=cut

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

    $c->res->content_type('text/html; charset=utf-8');
    my $name = $c->config->{name} || join(' ', split('::', ref $c));

    my ( $title, $error, $infos );
    if ( $c->debug ) {

        # For pretty dumps
        $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 @infos;
        my $i = 0;
        for my $dump ( $c->dump_these ) {
            my $name  = $dump->[0];
            my $value = encode_entities( dump( $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
(fr) SVP veuillez revenir plus tard
(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: #333;
            background-color: #eee;
            margin: 0px;
            padding: 0px;
        }
        :link, :link:hover, :visited, :visited:hover {
            color: #000;
        }
        div.box {
            position: relative;
            background-color: #ccc;
            border: 1px solid #aaa;
            padding: 4px;
            margin: 10px;
        }
        div.error {
            background-color: #cce;
            border: 1px solid #755;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
        }
        div.infos {
            background-color: #eee;
            border: 1px solid #575;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
        }
        div.name {
            background-color: #cce;
            border: 1px solid #557;
            padding: 8px;
            margin: 4px;
        }
        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)

Abstract method, allows engines to write headers to response

=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)

Clean up after uploads, deleting temp files.

=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)

sets up the L<Catalyst::Request> object body using L<HTTP::Body>

=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 );
        $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
          if exists $c->config->{uploadtmp};
    }

    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)

Add a chunk to the request body.

=cut

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

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

=head2 $self->prepare_body_parameters($c)

Sets up parameters from body. 

=cut

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

=head2 $self->prepare_connection($c)

Abstract method implemented in engines.

=cut

sub prepare_connection { }

=head2 $self->prepare_cookies($c)

Parse cookies from header. Sets a L<CGI::Cookie> object.

=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)

sets up parameters from query and post parameters.

=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)

abstract method, implemented by engines.

=cut

sub prepare_path { }

=head2 $self->prepare_request($c)

=head2 $self->prepare_query_parameters($c)

process the query string and extract query parameters.

=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)

prepare to read from the engine.

=cut

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

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

=head2 $self->prepare_request(@arguments)

Populate the context object from the request object.

=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)

Abstract method. Implemented by the engines.

=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)

Start the engine. Implemented by the various engine classes.

=cut

sub run { }

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

Writes the buffer to the client. Can only be called once for a request.

=cut

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

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

    print STDOUT $buffer;
}


=head2 $self->finalize_output

<obsolete>, see finalize_body

=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;
f63c03e4	6	use Data::Dump qw/dump/;
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
cd3bb248	33
b5ecfcf0	34	=head2 $self->finalize_body($c)
06e1b616	35
fbcc39ad	36	Finalize body. Prints the response output.
06e1b616	37
	38	=cut
	39
fbcc39ad	40	sub finalize_body {
fbcc39ad	41	my ( $self, $c ) = @_;
7257e9db	42	my $body = $c->response->body;
34d28dfd	43	if ( ref $body && ( $body->can('read') \|\| ref($body) eq 'GLOB' ) ) {
7257e9db	44	while ( !eof $body ) {
4c423abf	45	read $body, my ($buffer), $CHUNKSIZE;
6484fba0	46	last unless $self->write( $c, $buffer );
f4a57de4	47	}
7257e9db	48	close $body;
f4a57de4	49	}
f4a57de4	50	else {
7257e9db	51	$self->write( $c, $body );
f4a57de4	52	}
fbcc39ad	53	}
6dc87a0f	54
b5ecfcf0	55	=head2 $self->finalize_cookies($c)
6dc87a0f	56
4ab87e27	57	Create CGI::Cookies from $c->res->cookies, and set them as response headers.
4ab87e27	58
6dc87a0f	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
4ab87e27	86	Output an apropriate error message, called if there's an error in $c
	87	after the dispatch has finished. Will output debug messages if Catalyst
	88	is in debug mode, or a `please come back later` message otherwise.
	89
969647fd	90	=cut
	91
	92	sub finalize_error {
fbcc39ad	93	my ( $self, $c ) = @_;
969647fd	94
7299a7b4	95	$c->res->content_type('text/html; charset=utf-8');
34d28dfd	96	my $name = $c->config->{name} \|\| join(' ', split('::', ref $c));
969647fd	97
	98	my ( $title, $error, $infos );
	99	if ( $c->debug ) {
62d9b030	100
62d9b030	101	# For pretty dumps
b5ecfcf0	102	$error = join '', map {
	103	'<p><code class="error">'
	104	. encode_entities($_)
	105	. '</code></p>'
	106	} @{ $c->error };
969647fd	107	$error \|\|= 'No output';
2666dd3b	108	$error = qq{<pre wrap="">$error</pre>};
969647fd	109	$title = $name = "$name on Catalyst $Catalyst::VERSION";
d82cc9ae	110	$name = "<h1>$name</h1>";
fbcc39ad	111
	112	# Don't show context in the dump
	113	delete $c->req->{_context};
	114	delete $c->res->{_context};
	115
	116	# Don't show body parser in the dump
	117	delete $c->req->{_body};
	118
	119	# Don't show response header state in dump
	120	delete $c->res->{_finalized_headers};
	121
c6ef5e69	122	my @infos;
c6ef5e69	123	my $i = 0;
c6ef5e69	124	for my $dump ( $c->dump_these ) {
c6ef5e69	125	my $name = $dump->[0];
f63c03e4	126	my $value = encode_entities( dump( $dump->[1] ));
c6ef5e69	127	push @infos, sprintf <<"EOF", $name, $value;
9619f23c	128	<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
c6ef5e69	129	<div id="dump_$i">
2666dd3b	130	<pre wrap="">%s</pre>
c6ef5e69	131	</div>
	132	EOF
	133	$i++;
	134	}
	135	$infos = join "\n", @infos;
969647fd	136	}
	137	else {
	138	$title = $name;
	139	$error = '';
	140	$infos = <<"";
	141	<pre>
	142	(en) Please come back later
0c2b4ac0	143	(fr) SVP veuillez revenir plus tard
969647fd	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;
34d28dfd	178	color: #333;
969647fd	179	background-color: #eee;
	180	margin: 0px;
	181	padding: 0px;
	182	}
c6ef5e69	183	:link, :link:hover, :visited, :visited:hover {
34d28dfd	184	color: #000;
c6ef5e69	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;
969647fd	192	}
969647fd	193	div.error {
34d28dfd	194	background-color: #cce;
969647fd	195	border: 1px solid #755;
	196	padding: 8px;
	197	margin: 4px;
	198	margin-bottom: 10px;
969647fd	199	}
969647fd	200	div.infos {
34d28dfd	201	background-color: #eee;
969647fd	202	border: 1px solid #575;
	203	padding: 8px;
	204	margin: 4px;
	205	margin-bottom: 10px;
969647fd	206	}
969647fd	207	div.name {
34d28dfd	208	background-color: #cce;
969647fd	209	border: 1px solid #557;
	210	padding: 8px;
	211	margin: 4px;
969647fd	212	}
7f8e0078	213	code.error {
	214	display: block;
	215	margin: 1em 0;
	216	overflow: auto;
7f8e0078	217	}
9619f23c	218	div.name h1, div.error p {
	219	margin: 0;
	220	}
	221	h2 {
	222	margin-top: 0;
	223	margin-bottom: 10px;
	224	font-size: medium;
	225	font-weight: bold;
	226	text-decoration: underline;
	227	}
	228	h1 {
	229	font-size: medium;
	230	font-weight: normal;
	231	}
2666dd3b	232	/* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
	233	/* Browser specific (not valid) styles to make preformatted text wrap */
	234	pre {
	235	white-space: pre-wrap; /* css-3 */
	236	white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
	237	white-space: -pre-wrap; /* Opera 4-6 */
	238	white-space: -o-pre-wrap; /* Opera 7 */
	239	word-wrap: break-word; /* Internet Explorer 5.5+ */
	240	}
969647fd	241	</style>
	242	</head>
	243	<body>
	244	<div class="box">
	245	<div class="error">$error</div>
	246	<div class="infos">$infos</div>
	247	<div class="name">$name</div>
	248	</div>
	249	</body>
	250	</html>
	251
d82cc9ae	252
	253	# Trick IE
	254	$c->res->{body} .= ( ' ' x 512 );
	255
	256	# Return 500
33117422	257	$c->res->status(500);
969647fd	258	}
969647fd	259
b5ecfcf0	260	=head2 $self->finalize_headers($c)
fc7ec1d9	261
4ab87e27	262	Abstract method, allows engines to write headers to response
4ab87e27	263
fc7ec1d9	264	=cut
	265
	266	sub finalize_headers { }
	267
b5ecfcf0	268	=head2 $self->finalize_read($c)
fc7ec1d9	269
	270	=cut
	271
fbcc39ad	272	sub finalize_read {
fbcc39ad	273	my ( $self, $c ) = @_;
4f5ebacd	274
fbcc39ad	275	undef $self->{_prepared_read};
fc7ec1d9	276	}
fc7ec1d9	277
b5ecfcf0	278	=head2 $self->finalize_uploads($c)
fc7ec1d9	279
4ab87e27	280	Clean up after uploads, deleting temp files.
4ab87e27	281
fc7ec1d9	282	=cut
fc7ec1d9	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
4ab87e27	299	sets up the L<Catalyst::Request> object body using L<HTTP::Body>
4ab87e27	300
fc7ec1d9	301	=cut
fc7ec1d9	302
fbcc39ad	303	sub prepare_body {
fbcc39ad	304	my ( $self, $c ) = @_;
99fe1710	305
fbcc39ad	306	$self->read_length( $c->request->header('Content-Length') \|\| 0 );
fbcc39ad	307	my $type = $c->request->header('Content-Type');
99fe1710	308
fbcc39ad	309	unless ( $c->request->{_body} ) {
fbcc39ad	310	$c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
34d28dfd	311	$c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
34d28dfd	312	if exists $c->config->{uploadtmp};
fc7ec1d9	313	}
4f5ebacd	314
fbcc39ad	315	if ( $self->read_length > 0 ) {
4f5ebacd	316	while ( my $buffer = $self->read($c) ) {
4f5ebacd	317	$c->prepare_body_chunk($buffer);
fbcc39ad	318	}
fdb3773e	319
	320	# paranoia against wrong Content-Length header
	321	my $remaining = $self->read_length - $self->read_position;
34d28dfd	322	if ( $remaining > 0 ) {
fdb3773e	323	$self->finalize_read($c);
34d28dfd	324	Catalyst::Exception->throw(
34d28dfd	325	"Wrong Content-Length value: " . $self->read_length );
fdb3773e	326	}
fc7ec1d9	327	}
	328	}
	329
b5ecfcf0	330	=head2 $self->prepare_body_chunk($c)
4bd82c41	331
4ab87e27	332	Add a chunk to the request body.
4ab87e27	333
4bd82c41	334	=cut
	335
	336	sub prepare_body_chunk {
	337	my ( $self, $c, $chunk ) = @_;
4f5ebacd	338
4f5ebacd	339	$c->request->{_body}->add($chunk);
4bd82c41	340	}
4bd82c41	341
b5ecfcf0	342	=head2 $self->prepare_body_parameters($c)
06e1b616	343
4ab87e27	344	Sets up parameters from body.
4ab87e27	345
06e1b616	346	=cut
06e1b616	347
fbcc39ad	348	sub prepare_body_parameters {
	349	my ( $self, $c ) = @_;
	350	$c->request->body_parameters( $c->request->{_body}->param );
	351	}
0556eb49	352
b5ecfcf0	353	=head2 $self->prepare_connection($c)
0556eb49	354
4ab87e27	355	Abstract method implemented in engines.
4ab87e27	356
0556eb49	357	=cut
	358
	359	sub prepare_connection { }
	360
b5ecfcf0	361	=head2 $self->prepare_cookies($c)
fc7ec1d9	362
4ab87e27	363	Parse cookies from header. Sets a L<CGI::Cookie> object.
4ab87e27	364
fc7ec1d9	365	=cut
fc7ec1d9	366
6dc87a0f	367	sub prepare_cookies {
fbcc39ad	368	my ( $self, $c ) = @_;
6dc87a0f	369
	370	if ( my $header = $c->request->header('Cookie') ) {
	371	$c->req->cookies( { CGI::Cookie->parse($header) } );
	372	}
	373	}
fc7ec1d9	374
b5ecfcf0	375	=head2 $self->prepare_headers($c)
fc7ec1d9	376
	377	=cut
	378
	379	sub prepare_headers { }
	380
b5ecfcf0	381	=head2 $self->prepare_parameters($c)
fc7ec1d9	382
4ab87e27	383	sets up parameters from query and post parameters.
4ab87e27	384
fc7ec1d9	385	=cut
fc7ec1d9	386
fbcc39ad	387	sub prepare_parameters {
fbcc39ad	388	my ( $self, $c ) = @_;
fc7ec1d9	389
fbcc39ad	390	# We copy, no references
	391	while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
	392	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	393	$c->request->parameters->{$name} = $param;
	394	}
fc7ec1d9	395
fbcc39ad	396	# Merge query and body parameters
	397	while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
	398	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	399	if ( my $old_param = $c->request->parameters->{$name} ) {
	400	if ( ref $old_param eq 'ARRAY' ) {
	401	push @{ $c->request->parameters->{$name} },
	402	ref $param eq 'ARRAY' ? @$param : $param;
	403	}
	404	else { $c->request->parameters->{$name} = [ $old_param, $param ] }
	405	}
	406	else { $c->request->parameters->{$name} = $param }
	407	}
	408	}
	409
b5ecfcf0	410	=head2 $self->prepare_path($c)
fc7ec1d9	411
4ab87e27	412	abstract method, implemented by engines.
4ab87e27	413
fc7ec1d9	414	=cut
	415
	416	sub prepare_path { }
	417
b5ecfcf0	418	=head2 $self->prepare_request($c)
fc7ec1d9	419
b5ecfcf0	420	=head2 $self->prepare_query_parameters($c)
fc7ec1d9	421
4ab87e27	422	process the query string and extract query parameters.
4ab87e27	423
fc7ec1d9	424	=cut
fc7ec1d9	425
e0616220	426	sub prepare_query_parameters {
	427	my ( $self, $c, $query_string ) = @_;
	428
	429	# replace semi-colons
	430	$query_string =~ s/;/&/g;
	431
	432	my $u = URI->new( '', 'http' );
f4a57de4	433	$u->query($query_string);
	434	for my $key ( $u->query_param ) {
	435	my @vals = $u->query_param($key);
	436	$c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
e0616220	437	}
e0616220	438	}
fbcc39ad	439
b5ecfcf0	440	=head2 $self->prepare_read($c)
fbcc39ad	441
4ab87e27	442	prepare to read from the engine.
4ab87e27	443
fbcc39ad	444	=cut
fc7ec1d9	445
fbcc39ad	446	sub prepare_read {
fbcc39ad	447	my ( $self, $c ) = @_;
4f5ebacd	448
fbcc39ad	449	# Reset the read position
4f5ebacd	450	$self->read_position(0);
fbcc39ad	451	}
fc7ec1d9	452
b5ecfcf0	453	=head2 $self->prepare_request(@arguments)
fc7ec1d9	454
4ab87e27	455	Populate the context object from the request object.
4ab87e27	456
fc7ec1d9	457	=cut
fc7ec1d9	458
fbcc39ad	459	sub prepare_request { }
fc7ec1d9	460
b5ecfcf0	461	=head2 $self->prepare_uploads($c)
c9afa5fc	462
fbcc39ad	463	=cut
	464
	465	sub prepare_uploads {
	466	my ( $self, $c ) = @_;
	467	my $uploads = $c->request->{_body}->upload;
	468	for my $name ( keys %$uploads ) {
	469	my $files = $uploads->{$name};
	470	$files = ref $files eq 'ARRAY' ? $files : [$files];
	471	my @uploads;
	472	for my $upload (@$files) {
	473	my $u = Catalyst::Request::Upload->new;
	474	$u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
	475	$u->type( $u->headers->content_type );
	476	$u->tempname( $upload->{tempname} );
	477	$u->size( $upload->{size} );
	478	$u->filename( $upload->{filename} );
	479	push @uploads, $u;
	480	}
	481	$c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
f4a57de4	482
c4bed79a	483	# support access to the filename as a normal param
c4bed79a	484	my @filenames = map { $_->{filename} } @uploads;
f4a57de4	485	$c->request->parameters->{$name} =
f4a57de4	486	@filenames > 1 ? \@filenames : $filenames[0];
fbcc39ad	487	}
	488	}
	489
b5ecfcf0	490	=head2 $self->prepare_write($c)
c9afa5fc	491
4ab87e27	492	Abstract method. Implemented by the engines.
4ab87e27	493
c9afa5fc	494	=cut
c9afa5fc	495
fbcc39ad	496	sub prepare_write { }
fbcc39ad	497
b5ecfcf0	498	=head2 $self->read($c, [$maxlength])
fbcc39ad	499
	500	=cut
	501
	502	sub read {
	503	my ( $self, $c, $maxlength ) = @_;
4f5ebacd	504
fbcc39ad	505	unless ( $self->{_prepared_read} ) {
4f5ebacd	506	$self->prepare_read($c);
fbcc39ad	507	$self->{_prepared_read} = 1;
fbcc39ad	508	}
4f5ebacd	509
fbcc39ad	510	my $remaining = $self->read_length - $self->read_position;
4bd82c41	511	$maxlength \|\|= $CHUNKSIZE;
4f5ebacd	512
fbcc39ad	513	# Are we done reading?
fbcc39ad	514	if ( $remaining <= 0 ) {
4f5ebacd	515	$self->finalize_read($c);
fbcc39ad	516	return;
fbcc39ad	517	}
c9afa5fc	518
fbcc39ad	519	my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
	520	my $rc = $self->read_chunk( $c, my $buffer, $readlen );
	521	if ( defined $rc ) {
	522	$self->read_position( $self->read_position + $rc );
	523	return $buffer;
	524	}
	525	else {
4f5ebacd	526	Catalyst::Exception->throw(
4f5ebacd	527	message => "Unknown error reading input: $!" );
fbcc39ad	528	}
fbcc39ad	529	}
fc7ec1d9	530
b5ecfcf0	531	=head2 $self->read_chunk($c, $buffer, $length)
23f9d934	532
fbcc39ad	533	Each engine inplements read_chunk as its preferred way of reading a chunk
fbcc39ad	534	of data.
fc7ec1d9	535
fbcc39ad	536	=cut
61b1e958	537
fbcc39ad	538	sub read_chunk { }
61b1e958	539
b5ecfcf0	540	=head2 $self->read_length
ca39d576	541
fbcc39ad	542	The length of input data to be read. This is obtained from the Content-Length
fbcc39ad	543	header.
fc7ec1d9	544
b5ecfcf0	545	=head2 $self->read_position
fc7ec1d9	546
fbcc39ad	547	The amount of input data that has already been read.
63b763c5	548
b5ecfcf0	549	=head2 $self->run($c)
63b763c5	550
4ab87e27	551	Start the engine. Implemented by the various engine classes.
4ab87e27	552
fbcc39ad	553	=cut
fc7ec1d9	554
fbcc39ad	555	sub run { }
fc7ec1d9	556
b5ecfcf0	557	=head2 $self->write($c, $buffer)
fc7ec1d9	558
4ab87e27	559	Writes the buffer to the client. Can only be called once for a request.
4ab87e27	560
fc7ec1d9	561	=cut
fc7ec1d9	562
fbcc39ad	563	sub write {
fbcc39ad	564	my ( $self, $c, $buffer ) = @_;
4f5ebacd	565
fbcc39ad	566	unless ( $self->{_prepared_write} ) {
4f5ebacd	567	$self->prepare_write($c);
fbcc39ad	568	$self->{_prepared_write} = 1;
fc7ec1d9	569	}
4f5ebacd	570
4f5ebacd	571	print STDOUT $buffer;
fc7ec1d9	572	}
fc7ec1d9	573
34d28dfd	574
4ab87e27	575	=head2 $self->finalize_output
	576
	577	<obsolete>, see finalize_body
	578
fbcc39ad	579	=head1 AUTHORS
	580
	581	Sebastian Riedel, <sri@cpan.org>
fc7ec1d9	582
fbcc39ad	583	Andy Grundman, <andy@hybridized.org>
fc7ec1d9	584
	585	=head1 COPYRIGHT
	586
	587	This program is free software, you can redistribute it and/or modify it under
	588	the same terms as Perl itself.
	589
	590	=cut
	591
	592	1;