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

package Catalyst::Engine;

use strict;
use base 'Class::Accessor::Fast';
use CGI::Cookie;
use Data::Dumper;
use HTML::Entities;
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;

# input position and length
__PACKAGE__->mk_accessors(qw/read_position read_length/);

# Stringify to class
use overload '""' => sub { return ref shift }, fallback => 1;

# Amount of data to read from input on each pass
our $CHUNKSIZE = 4096;

=head1 NAME

Catalyst::Engine - The Catalyst Engine

=head1 SYNOPSIS

See L<Catalyst>.

=head1 DESCRIPTION

=head1 METHODS


=head2 $self->finalize_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} || 'Catalyst Application';

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

        # For pretty dumps
        local $Data::Dumper::Terse = 1;
        $error = join '', map {
                '<p><code class="error">'
              . encode_entities($_)
              . '</code></p>'
        } @{ $c->error };
        $error ||= 'No output';
        $error = qq{<pre wrap="">$error</pre>};
        $title = $name = "$name on Catalyst $Catalyst::VERSION";
        $name  = "<h1>$name</h1>";

        # Don't show context in the dump
        delete $c->req->{_context};
        delete $c->res->{_context};

        # Don't show body parser in the dump
        delete $c->req->{_body};

        # Don't show response header state in dump
        delete $c->res->{_finalized_headers};

        my $req   = encode_entities Dumper $c->req;
        my $res   = encode_entities Dumper $c->res;
        my $stash = encode_entities Dumper $c->stash;

        my @infos;
        my $i = 0;
        for my $dump ( $c->dump_these ) {
            my $name  = $dump->[0];
            my $value = encode_entities( Dumper $dump->[1] );
            push @infos, sprintf <<"EOF", $name, $value;
<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
<div id="dump_$i">
    <pre wrap="">%s</pre>
</div>
EOF
            $i++;
        }
        $infos = join "\n", @infos;
    }
    else {
        $title = $name;
        $error = '';
        $infos = <<"";
<pre>
(en) Please come back later
(de) Bitte versuchen sie es spaeter nocheinmal
(at) Konnten's bitt'schoen spaeter nochmal reinschauen
(no) Vennligst prov igjen senere
(dk) Venligst prov igen senere
(pl) Prosze sprobowac pozniej
</pre>

        $name = '';
    }
    $c->res->body( <<"" );
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
    <meta http-equiv="Content-Language" content="en" />
    <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
    <title>$title</title>
    <script type="text/javascript">
        <!--
        function toggleDump (dumpElement) {
            var e = document.getElementById( dumpElement );
            if (e.style.display == "none") {
                e.style.display = "";
            }
            else {
                e.style.display = "none";
            }
        }
        -->
    </script>
    <style type="text/css">
        body {
            font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
                         Tahoma, Arial, helvetica, sans-serif;
            color: #ddd;
            background-color: #eee;
            margin: 0px;
            padding: 0px;
        }
        :link, :link:hover, :visited, :visited:hover {
            color: #ddd;
        }
        div.box {
            position: relative;
            background-color: #ccc;
            border: 1px solid #aaa;
            padding: 4px;
            margin: 10px;
            -moz-border-radius: 10px;
        }
        div.error {
            background-color: #977;
            border: 1px solid #755;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
            -moz-border-radius: 10px;
        }
        div.infos {
            background-color: #797;
            border: 1px solid #575;
            padding: 8px;
            margin: 4px;
            margin-bottom: 10px;
            -moz-border-radius: 10px;
        }
        div.name {
            background-color: #779;
            border: 1px solid #557;
            padding: 8px;
            margin: 4px;
            -moz-border-radius: 10px;
        }
        code.error {
            display: block;
            margin: 1em 0;
            overflow: auto;
        }
        div.name h1, div.error p {
            margin: 0;
        }
        h2 {
            margin-top: 0;
            margin-bottom: 10px;
            font-size: medium;
            font-weight: bold;
            text-decoration: underline;
        }
        h1 {
            font-size: medium;
            font-weight: normal;
        }
        /* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
        /* Browser specific (not valid) styles to make preformatted text wrap */
        pre { 
            white-space: pre-wrap;       /* css-3 */
            white-space: -moz-pre-wrap;  /* Mozilla, since 1999 */
            white-space: -pre-wrap;      /* Opera 4-6 */
            white-space: -o-pre-wrap;    /* Opera 7 */
            word-wrap: break-word;       /* Internet Explorer 5.5+ */
        }
    </style>
</head>
<body>
    <div class="box">
        <div class="error">$error</div>
        <div class="infos">$infos</div>
        <div class="name">$name</div>
    </div>
</body>
</html>


    # Trick IE
    $c->res->{body} .= ( ' ' x 512 );

    # Return 500
    $c->res->status(500);
}

=head2 $self->finalize_headers($c)

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;
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
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;
	43	if ( ref $body && ($body->can('read') \|\| ref($body) eq 'GLOB') ) {
	44	while ( !eof $body ) {
	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');
969647fd	96	my $name = $c->config->{name} \|\| 'Catalyst Application';
	97
	98	my ( $title, $error, $infos );
	99	if ( $c->debug ) {
62d9b030	100
	101	# For pretty dumps
	102	local $Data::Dumper::Terse = 1;
b5ecfcf0	103	$error = join '', map {
	104	'<p><code class="error">'
	105	. encode_entities($_)
	106	. '</code></p>'
	107	} @{ $c->error };
969647fd	108	$error \|\|= 'No output';
2666dd3b	109	$error = qq{<pre wrap="">$error</pre>};
969647fd	110	$title = $name = "$name on Catalyst $Catalyst::VERSION";
d82cc9ae	111	$name = "<h1>$name</h1>";
fbcc39ad	112
	113	# Don't show context in the dump
	114	delete $c->req->{_context};
	115	delete $c->res->{_context};
	116
	117	# Don't show body parser in the dump
	118	delete $c->req->{_body};
	119
	120	# Don't show response header state in dump
	121	delete $c->res->{_finalized_headers};
	122
969647fd	123	my $req = encode_entities Dumper $c->req;
	124	my $res = encode_entities Dumper $c->res;
	125	my $stash = encode_entities Dumper $c->stash;
969647fd	126
c6ef5e69	127	my @infos;
c6ef5e69	128	my $i = 0;
c6ef5e69	129	for my $dump ( $c->dump_these ) {
c6ef5e69	130	my $name = $dump->[0];
	131	my $value = encode_entities( Dumper $dump->[1] );
	132	push @infos, sprintf <<"EOF", $name, $value;
9619f23c	133	<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
c6ef5e69	134	<div id="dump_$i">
2666dd3b	135	<pre wrap="">%s</pre>
c6ef5e69	136	</div>
	137	EOF
	138	$i++;
	139	}
	140	$infos = join "\n", @infos;
969647fd	141	}
	142	else {
	143	$title = $name;
	144	$error = '';
	145	$infos = <<"";
	146	<pre>
	147	(en) Please come back later
	148	(de) Bitte versuchen sie es spaeter nocheinmal
d82cc9ae	149	(at) Konnten's bitt'schoen spaeter nochmal reinschauen
969647fd	150	(no) Vennligst prov igjen senere
d82cc9ae	151	(dk) Venligst prov igen senere
d82cc9ae	152	(pl) Prosze sprobowac pozniej
969647fd	153	</pre>
	154
	155	$name = '';
	156	}
e060fe05	157	$c->res->body( <<"" );
7299a7b4	158	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	159	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
	160	<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
969647fd	161	<head>
7299a7b4	162	<meta http-equiv="Content-Language" content="en" />
7299a7b4	163	<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
969647fd	164	<title>$title</title>
7299a7b4	165	<script type="text/javascript">
c6ef5e69	166	<!--
c6ef5e69	167	function toggleDump (dumpElement) {
7299a7b4	168	var e = document.getElementById( dumpElement );
	169	if (e.style.display == "none") {
	170	e.style.display = "";
c6ef5e69	171	}
c6ef5e69	172	else {
7299a7b4	173	e.style.display = "none";
c6ef5e69	174	}
	175	}
	176	-->
	177	</script>
969647fd	178	<style type="text/css">
	179	body {
	180	font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
	181	Tahoma, Arial, helvetica, sans-serif;
	182	color: #ddd;
	183	background-color: #eee;
	184	margin: 0px;
	185	padding: 0px;
	186	}
c6ef5e69	187	:link, :link:hover, :visited, :visited:hover {
	188	color: #ddd;
	189	}
969647fd	190	div.box {
9619f23c	191	position: relative;
969647fd	192	background-color: #ccc;
	193	border: 1px solid #aaa;
	194	padding: 4px;
	195	margin: 10px;
	196	-moz-border-radius: 10px;
	197	}
	198	div.error {
	199	background-color: #977;
	200	border: 1px solid #755;
	201	padding: 8px;
	202	margin: 4px;
	203	margin-bottom: 10px;
	204	-moz-border-radius: 10px;
	205	}
	206	div.infos {
	207	background-color: #797;
	208	border: 1px solid #575;
	209	padding: 8px;
	210	margin: 4px;
	211	margin-bottom: 10px;
	212	-moz-border-radius: 10px;
	213	}
	214	div.name {
	215	background-color: #779;
	216	border: 1px solid #557;
	217	padding: 8px;
	218	margin: 4px;
	219	-moz-border-radius: 10px;
	220	}
7f8e0078	221	code.error {
	222	display: block;
	223	margin: 1em 0;
	224	overflow: auto;
7f8e0078	225	}
9619f23c	226	div.name h1, div.error p {
	227	margin: 0;
	228	}
	229	h2 {
	230	margin-top: 0;
	231	margin-bottom: 10px;
	232	font-size: medium;
	233	font-weight: bold;
	234	text-decoration: underline;
	235	}
	236	h1 {
	237	font-size: medium;
	238	font-weight: normal;
	239	}
2666dd3b	240	/* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
	241	/* Browser specific (not valid) styles to make preformatted text wrap */
	242	pre {
	243	white-space: pre-wrap; /* css-3 */
	244	white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
	245	white-space: -pre-wrap; /* Opera 4-6 */
	246	white-space: -o-pre-wrap; /* Opera 7 */
	247	word-wrap: break-word; /* Internet Explorer 5.5+ */
	248	}
969647fd	249	</style>
	250	</head>
	251	<body>
	252	<div class="box">
	253	<div class="error">$error</div>
	254	<div class="infos">$infos</div>
	255	<div class="name">$name</div>
	256	</div>
	257	</body>
	258	</html>
	259
d82cc9ae	260
	261	# Trick IE
	262	$c->res->{body} .= ( ' ' x 512 );
	263
	264	# Return 500
33117422	265	$c->res->status(500);
969647fd	266	}
969647fd	267
b5ecfcf0	268	=head2 $self->finalize_headers($c)
fc7ec1d9	269
4ab87e27	270	Abstract method, allows engines to write headers to response
4ab87e27	271
fc7ec1d9	272	=cut
	273
	274	sub finalize_headers { }
	275
b5ecfcf0	276	=head2 $self->finalize_read($c)
fc7ec1d9	277
	278	=cut
	279
fbcc39ad	280	sub finalize_read {
fbcc39ad	281	my ( $self, $c ) = @_;
4f5ebacd	282
fbcc39ad	283	undef $self->{_prepared_read};
fc7ec1d9	284	}
fc7ec1d9	285
b5ecfcf0	286	=head2 $self->finalize_uploads($c)
fc7ec1d9	287
4ab87e27	288	Clean up after uploads, deleting temp files.
4ab87e27	289
fc7ec1d9	290	=cut
fc7ec1d9	291
fbcc39ad	292	sub finalize_uploads {
fbcc39ad	293	my ( $self, $c ) = @_;
99fe1710	294
fbcc39ad	295	if ( keys %{ $c->request->uploads } ) {
	296	for my $key ( keys %{ $c->request->uploads } ) {
	297	my $upload = $c->request->uploads->{$key};
	298	unlink map { $_->tempname }
	299	grep { -e $_->tempname }
	300	ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
c85ff642	301	}
c85ff642	302	}
fc7ec1d9	303	}
fc7ec1d9	304
b5ecfcf0	305	=head2 $self->prepare_body($c)
fc7ec1d9	306
4ab87e27	307	sets up the L<Catalyst::Request> object body using L<HTTP::Body>
4ab87e27	308
fc7ec1d9	309	=cut
fc7ec1d9	310
fbcc39ad	311	sub prepare_body {
fbcc39ad	312	my ( $self, $c ) = @_;
99fe1710	313
fbcc39ad	314	$self->read_length( $c->request->header('Content-Length') \|\| 0 );
fbcc39ad	315	my $type = $c->request->header('Content-Type');
99fe1710	316
fbcc39ad	317	unless ( $c->request->{_body} ) {
fbcc39ad	318	$c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
7257e9db	319	$c->request->{_body}->{tmpdir} = $c->config->{uploadtmp} if exists $c->config->{uploadtmp};
fc7ec1d9	320	}
4f5ebacd	321
fbcc39ad	322	if ( $self->read_length > 0 ) {
4f5ebacd	323	while ( my $buffer = $self->read($c) ) {
4f5ebacd	324	$c->prepare_body_chunk($buffer);
fbcc39ad	325	}
fdb3773e	326
	327	# paranoia against wrong Content-Length header
	328	my $remaining = $self->read_length - $self->read_position;
	329	if ($remaining > 0) {
	330	$self->finalize_read($c);
	331	Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
	332	}
fc7ec1d9	333	}
	334	}
	335
b5ecfcf0	336	=head2 $self->prepare_body_chunk($c)
4bd82c41	337
4ab87e27	338	Add a chunk to the request body.
4ab87e27	339
4bd82c41	340	=cut
	341
	342	sub prepare_body_chunk {
	343	my ( $self, $c, $chunk ) = @_;
4f5ebacd	344
4f5ebacd	345	$c->request->{_body}->add($chunk);
4bd82c41	346	}
4bd82c41	347
b5ecfcf0	348	=head2 $self->prepare_body_parameters($c)
06e1b616	349
4ab87e27	350	Sets up parameters from body.
4ab87e27	351
06e1b616	352	=cut
06e1b616	353
fbcc39ad	354	sub prepare_body_parameters {
	355	my ( $self, $c ) = @_;
	356	$c->request->body_parameters( $c->request->{_body}->param );
	357	}
0556eb49	358
b5ecfcf0	359	=head2 $self->prepare_connection($c)
0556eb49	360
4ab87e27	361	Abstract method implemented in engines.
4ab87e27	362
0556eb49	363	=cut
	364
	365	sub prepare_connection { }
	366
b5ecfcf0	367	=head2 $self->prepare_cookies($c)
fc7ec1d9	368
4ab87e27	369	Parse cookies from header. Sets a L<CGI::Cookie> object.
4ab87e27	370
fc7ec1d9	371	=cut
fc7ec1d9	372
6dc87a0f	373	sub prepare_cookies {
fbcc39ad	374	my ( $self, $c ) = @_;
6dc87a0f	375
	376	if ( my $header = $c->request->header('Cookie') ) {
	377	$c->req->cookies( { CGI::Cookie->parse($header) } );
	378	}
	379	}
fc7ec1d9	380
b5ecfcf0	381	=head2 $self->prepare_headers($c)
fc7ec1d9	382
	383	=cut
	384
	385	sub prepare_headers { }
	386
b5ecfcf0	387	=head2 $self->prepare_parameters($c)
fc7ec1d9	388
4ab87e27	389	sets up parameters from query and post parameters.
4ab87e27	390
fc7ec1d9	391	=cut
fc7ec1d9	392
fbcc39ad	393	sub prepare_parameters {
fbcc39ad	394	my ( $self, $c ) = @_;
fc7ec1d9	395
fbcc39ad	396	# We copy, no references
	397	while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
	398	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	399	$c->request->parameters->{$name} = $param;
	400	}
fc7ec1d9	401
fbcc39ad	402	# Merge query and body parameters
	403	while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
	404	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	405	if ( my $old_param = $c->request->parameters->{$name} ) {
	406	if ( ref $old_param eq 'ARRAY' ) {
	407	push @{ $c->request->parameters->{$name} },
	408	ref $param eq 'ARRAY' ? @$param : $param;
	409	}
	410	else { $c->request->parameters->{$name} = [ $old_param, $param ] }
	411	}
	412	else { $c->request->parameters->{$name} = $param }
	413	}
	414	}
	415
b5ecfcf0	416	=head2 $self->prepare_path($c)
fc7ec1d9	417
4ab87e27	418	abstract method, implemented by engines.
4ab87e27	419
fc7ec1d9	420	=cut
	421
	422	sub prepare_path { }
	423
b5ecfcf0	424	=head2 $self->prepare_request($c)
fc7ec1d9	425
b5ecfcf0	426	=head2 $self->prepare_query_parameters($c)
fc7ec1d9	427
4ab87e27	428	process the query string and extract query parameters.
4ab87e27	429
fc7ec1d9	430	=cut
fc7ec1d9	431
e0616220	432	sub prepare_query_parameters {
	433	my ( $self, $c, $query_string ) = @_;
	434
	435	# replace semi-colons
	436	$query_string =~ s/;/&/g;
	437
	438	my $u = URI->new( '', 'http' );
f4a57de4	439	$u->query($query_string);
	440	for my $key ( $u->query_param ) {
	441	my @vals = $u->query_param($key);
	442	$c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
e0616220	443	}
e0616220	444	}
fbcc39ad	445
b5ecfcf0	446	=head2 $self->prepare_read($c)
fbcc39ad	447
4ab87e27	448	prepare to read from the engine.
4ab87e27	449
fbcc39ad	450	=cut
fc7ec1d9	451
fbcc39ad	452	sub prepare_read {
fbcc39ad	453	my ( $self, $c ) = @_;
4f5ebacd	454
fbcc39ad	455	# Reset the read position
4f5ebacd	456	$self->read_position(0);
fbcc39ad	457	}
fc7ec1d9	458
b5ecfcf0	459	=head2 $self->prepare_request(@arguments)
fc7ec1d9	460
4ab87e27	461	Populate the context object from the request object.
4ab87e27	462
fc7ec1d9	463	=cut
fc7ec1d9	464
fbcc39ad	465	sub prepare_request { }
fc7ec1d9	466
b5ecfcf0	467	=head2 $self->prepare_uploads($c)
c9afa5fc	468
fbcc39ad	469	=cut
	470
	471	sub prepare_uploads {
	472	my ( $self, $c ) = @_;
	473	my $uploads = $c->request->{_body}->upload;
	474	for my $name ( keys %$uploads ) {
	475	my $files = $uploads->{$name};
	476	$files = ref $files eq 'ARRAY' ? $files : [$files];
	477	my @uploads;
	478	for my $upload (@$files) {
	479	my $u = Catalyst::Request::Upload->new;
	480	$u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
	481	$u->type( $u->headers->content_type );
	482	$u->tempname( $upload->{tempname} );
	483	$u->size( $upload->{size} );
	484	$u->filename( $upload->{filename} );
	485	push @uploads, $u;
	486	}
	487	$c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
f4a57de4	488
c4bed79a	489	# support access to the filename as a normal param
c4bed79a	490	my @filenames = map { $_->{filename} } @uploads;
f4a57de4	491	$c->request->parameters->{$name} =
f4a57de4	492	@filenames > 1 ? \@filenames : $filenames[0];
fbcc39ad	493	}
	494	}
	495
b5ecfcf0	496	=head2 $self->prepare_write($c)
c9afa5fc	497
4ab87e27	498	Abstract method. Implemented by the engines.
4ab87e27	499
c9afa5fc	500	=cut
c9afa5fc	501
fbcc39ad	502	sub prepare_write { }
fbcc39ad	503
b5ecfcf0	504	=head2 $self->read($c, [$maxlength])
fbcc39ad	505
	506	=cut
	507
	508	sub read {
	509	my ( $self, $c, $maxlength ) = @_;
4f5ebacd	510
fbcc39ad	511	unless ( $self->{_prepared_read} ) {
4f5ebacd	512	$self->prepare_read($c);
fbcc39ad	513	$self->{_prepared_read} = 1;
fbcc39ad	514	}
4f5ebacd	515
fbcc39ad	516	my $remaining = $self->read_length - $self->read_position;
4bd82c41	517	$maxlength \|\|= $CHUNKSIZE;
4f5ebacd	518
fbcc39ad	519	# Are we done reading?
fbcc39ad	520	if ( $remaining <= 0 ) {
4f5ebacd	521	$self->finalize_read($c);
fbcc39ad	522	return;
fbcc39ad	523	}
c9afa5fc	524
fbcc39ad	525	my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
	526	my $rc = $self->read_chunk( $c, my $buffer, $readlen );
	527	if ( defined $rc ) {
	528	$self->read_position( $self->read_position + $rc );
	529	return $buffer;
	530	}
	531	else {
4f5ebacd	532	Catalyst::Exception->throw(
4f5ebacd	533	message => "Unknown error reading input: $!" );
fbcc39ad	534	}
fbcc39ad	535	}
fc7ec1d9	536
b5ecfcf0	537	=head2 $self->read_chunk($c, $buffer, $length)
23f9d934	538
fbcc39ad	539	Each engine inplements read_chunk as its preferred way of reading a chunk
fbcc39ad	540	of data.
fc7ec1d9	541
fbcc39ad	542	=cut
61b1e958	543
fbcc39ad	544	sub read_chunk { }
61b1e958	545
b5ecfcf0	546	=head2 $self->read_length
ca39d576	547
fbcc39ad	548	The length of input data to be read. This is obtained from the Content-Length
fbcc39ad	549	header.
fc7ec1d9	550
b5ecfcf0	551	=head2 $self->read_position
fc7ec1d9	552
fbcc39ad	553	The amount of input data that has already been read.
63b763c5	554
b5ecfcf0	555	=head2 $self->run($c)
63b763c5	556
4ab87e27	557	Start the engine. Implemented by the various engine classes.
4ab87e27	558
fbcc39ad	559	=cut
fc7ec1d9	560
fbcc39ad	561	sub run { }
fc7ec1d9	562
b5ecfcf0	563	=head2 $self->write($c, $buffer)
fc7ec1d9	564
4ab87e27	565	Writes the buffer to the client. Can only be called once for a request.
4ab87e27	566
fc7ec1d9	567	=cut
fc7ec1d9	568
fbcc39ad	569	sub write {
fbcc39ad	570	my ( $self, $c, $buffer ) = @_;
4f5ebacd	571
fbcc39ad	572	unless ( $self->{_prepared_write} ) {
4f5ebacd	573	$self->prepare_write($c);
fbcc39ad	574	$self->{_prepared_write} = 1;
fc7ec1d9	575	}
4f5ebacd	576
4f5ebacd	577	print STDOUT $buffer;
fc7ec1d9	578	}
fc7ec1d9	579
4ab87e27	580	=head2 $self->finalize_output
	581
	582	<obsolete>, see finalize_body
	583
fbcc39ad	584	=head1 AUTHORS
	585
	586	Sebastian Riedel, <sri@cpan.org>
fc7ec1d9	587
fbcc39ad	588	Andy Grundman, <andy@hybridized.org>
fc7ec1d9	589
	590	=head1 COPYRIGHT
	591
	592	This program is free software, you can redistribute it and/or modify it under
	593	the same terms as Perl itself.
	594
	595	=cut
	596
	597	1;