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

    foreach my $name ( keys %{ $c->response->cookies } ) {

        my $val = $c->response->cookies->{$name};

        my $cookie = CGI::Cookie->new(
            -name    => $name,
            -value   => $val->{value},
            -expires => $val->{expires},
            -domain  => $val->{domain},
            -path    => $val->{path},
            -secure  => $val->{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
    foreach my $name ( keys %{ $c->request->query_parameters } ) {
        my $param = $c->request->query_parameters->{$name};
        $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
        $c->request->parameters->{$name} = $param;
    }

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