[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 ) = @_;
    if ( ref $c->response->body && $c->response->body->can('read') ) {
        while ( !$c->response->body->eof() ) {
            $c->response->body->read( my $buffer, $CHUNKSIZE );
            last unless $self->write( $c, $buffer );
        }
        $c->response->body->close();
    }
    else {
        $self->write( $c, $c->response->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 );
    }

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