[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} || join(' ', split('::', ref $c));

    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   = _fixup_debug_info($c->req);
        my $res   = _fixup_debug_info($c->res);
        my $stash = _fixup_debug_info($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
(fr) SVP veuillez revenir plus tard
(de) Bitte versuchen sie es spaeter nocheinmal
(at) Konnten's bitt'schoen spaeter nochmal reinschauen
(no) Vennligst prov igjen senere
(dk) Venligst prov igen senere
(pl) Prosze sprobowac pozniej
</pre>

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


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

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

=head2 $self->finalize_headers($c)

Abstract method, allows engines to write headers to response

=cut

sub finalize_headers { }

=head2 $self->finalize_read($c)

=cut

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

    undef $self->{_prepared_read};
}

=head2 $self->finalize_uploads($c)

Clean up after uploads, deleting temp files.

=cut

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

    if ( keys %{ $c->request->uploads } ) {
        for my $key ( keys %{ $c->request->uploads } ) {
            my $upload = $c->request->uploads->{$key};
            unlink map { $_->tempname }
              grep     { -e $_->tempname }
              ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
        }
    }
}

=head2 $self->prepare_body($c)

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

=cut

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

    $self->read_length( $c->request->header('Content-Length') || 0 );
    my $type = $c->request->header('Content-Type');

    unless ( $c->request->{_body} ) {
        $c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
        $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
          if exists $c->config->{uploadtmp};
    }

    if ( $self->read_length > 0 ) {
        while ( my $buffer = $self->read($c) ) {
            $c->prepare_body_chunk($buffer);
        }

        # paranoia against wrong Content-Length header
        my $remaining = $self->read_length - $self->read_position;
        if ( $remaining > 0 ) {
            $self->finalize_read($c);
            Catalyst::Exception->throw(
                "Wrong Content-Length value: " . $self->read_length );
        }
    }
}

=head2 $self->prepare_body_chunk($c)

Add a chunk to the request body.

=cut

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

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

=head2 $self->prepare_body_parameters($c)

Sets up parameters from body. 

=cut

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

=head2 $self->prepare_connection($c)

Abstract method implemented in engines.

=cut

sub prepare_connection { }

=head2 $self->prepare_cookies($c)

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

=cut

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

    if ( my $header = $c->request->header('Cookie') ) {
        $c->req->cookies( { CGI::Cookie->parse($header) } );
    }
}

=head2 $self->prepare_headers($c)

=cut

sub prepare_headers { }

=head2 $self->prepare_parameters($c)

sets up parameters from query and post parameters.

=cut

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

    # We copy, no references
    while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
        $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
        $c->request->parameters->{$name} = $param;
    }

    # Merge query and body parameters
    while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
        $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
        if ( my $old_param = $c->request->parameters->{$name} ) {
            if ( ref $old_param eq 'ARRAY' ) {
                push @{ $c->request->parameters->{$name} },
                  ref $param eq 'ARRAY' ? @$param : $param;
            }
            else { $c->request->parameters->{$name} = [ $old_param, $param ] }
        }
        else { $c->request->parameters->{$name} = $param }
    }
}

=head2 $self->prepare_path($c)

abstract method, implemented by engines.

=cut

sub prepare_path { }

=head2 $self->prepare_request($c)

=head2 $self->prepare_query_parameters($c)

process the query string and extract query parameters.

=cut

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

    # replace semi-colons
    $query_string =~ s/;/&/g;

    my $u = URI->new( '', 'http' );
    $u->query($query_string);
    for my $key ( $u->query_param ) {
        my @vals = $u->query_param($key);
        $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0];
    }
}

=head2 $self->prepare_read($c)

prepare to read from the engine.

=cut

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

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

=head2 $self->prepare_request(@arguments)

Populate the context object from the request object.

=cut

sub prepare_request { }

=head2 $self->prepare_uploads($c)

=cut

sub prepare_uploads {
    my ( $self, $c ) = @_;
    my $uploads = $c->request->{_body}->upload;
    for my $name ( keys %$uploads ) {
        my $files = $uploads->{$name};
        $files = ref $files eq 'ARRAY' ? $files : [$files];
        my @uploads;
        for my $upload (@$files) {
            my $u = Catalyst::Request::Upload->new;
            $u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
            $u->type( $u->headers->content_type );
            $u->tempname( $upload->{tempname} );
            $u->size( $upload->{size} );
            $u->filename( $upload->{filename} );
            push @uploads, $u;
        }
        $c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];

        # support access to the filename as a normal param
        my @filenames = map { $_->{filename} } @uploads;
        $c->request->parameters->{$name} =
          @filenames > 1 ? \@filenames : $filenames[0];
    }
}

=head2 $self->prepare_write($c)

Abstract method. Implemented by the engines.

=cut

sub prepare_write { }

=head2 $self->read($c, [$maxlength])

=cut

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

    unless ( $self->{_prepared_read} ) {
        $self->prepare_read($c);
        $self->{_prepared_read} = 1;
    }

    my $remaining = $self->read_length - $self->read_position;
    $maxlength ||= $CHUNKSIZE;

    # Are we done reading?
    if ( $remaining <= 0 ) {
        $self->finalize_read($c);
        return;
    }

    my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
    my $rc = $self->read_chunk( $c, my $buffer, $readlen );
    if ( defined $rc ) {
        $self->read_position( $self->read_position + $rc );
        return $buffer;
    }
    else {
        Catalyst::Exception->throw(
            message => "Unknown error reading input: $!" );
    }
}

=head2 $self->read_chunk($c, $buffer, $length)

Each engine inplements read_chunk as its preferred way of reading a chunk
of data.

=cut

sub read_chunk { }

=head2 $self->read_length

The length of input data to be read.  This is obtained from the Content-Length
header.

=head2 $self->read_position

The amount of input data that has already been read.

=head2 $self->run($c)

Start the engine. Implemented by the various engine classes.

=cut

sub run { }

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

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

=cut

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

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

    print STDOUT $buffer;
}

sub _fixup_debug_info {
    my $info   = encode_entities Dumper shift;
     my @info = split "\n", $info; 
     pop @info; shift @info;
     return join "\n",@info;    
}

=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;
34d28dfd	43	if ( ref $body && ( $body->can('read') \|\| ref($body) eq 'GLOB' ) ) {
7257e9db	44	while ( !eof $body ) {
4c423abf	45	read $body, my ($buffer), $CHUNKSIZE;
6484fba0	46	last unless $self->write( $c, $buffer );
f4a57de4	47	}
7257e9db	48	close $body;
f4a57de4	49	}
f4a57de4	50	else {
7257e9db	51	$self->write( $c, $body );
f4a57de4	52	}
fbcc39ad	53	}
6dc87a0f	54
b5ecfcf0	55	=head2 $self->finalize_cookies($c)
6dc87a0f	56
4ab87e27	57	Create CGI::Cookies from $c->res->cookies, and set them as response headers.
4ab87e27	58
6dc87a0f	59	=cut
	60
	61	sub finalize_cookies {
fbcc39ad	62	my ( $self, $c ) = @_;
6dc87a0f	63
fbcc39ad	64	my @cookies;
6dc87a0f	65	while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
fbcc39ad	66
6dc87a0f	67	my $cookie = CGI::Cookie->new(
	68	-name => $name,
	69	-value => $cookie->{value},
	70	-expires => $cookie->{expires},
	71	-domain => $cookie->{domain},
	72	-path => $cookie->{path},
	73	-secure => $cookie->{secure} \|\| 0
	74	);
	75
fbcc39ad	76	push @cookies, $cookie->as_string;
6dc87a0f	77	}
6dc87a0f	78
b39840da	79	for my $cookie (@cookies) {
b39840da	80	$c->res->headers->push_header( 'Set-Cookie' => $cookie );
fbcc39ad	81	}
fbcc39ad	82	}
969647fd	83
b5ecfcf0	84	=head2 $self->finalize_error($c)
969647fd	85
4ab87e27	86	Output an apropriate error message, called if there's an error in $c
	87	after the dispatch has finished. Will output debug messages if Catalyst
	88	is in debug mode, or a `please come back later` message otherwise.
	89
969647fd	90	=cut
	91
	92	sub finalize_error {
fbcc39ad	93	my ( $self, $c ) = @_;
969647fd	94
7299a7b4	95	$c->res->content_type('text/html; charset=utf-8');
34d28dfd	96	my $name = $c->config->{name} \|\| join(' ', split('::', ref $c));
969647fd	97
	98	my ( $title, $error, $infos );
	99	if ( $c->debug ) {
62d9b030	100
	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
34d28dfd	123	my $req = _fixup_debug_info($c->req);
	124	my $res = _fixup_debug_info($c->res);
	125	my $stash = _fixup_debug_info($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
0c2b4ac0	148	(fr) SVP veuillez revenir plus tard
969647fd	149	(de) Bitte versuchen sie es spaeter nocheinmal
d82cc9ae	150	(at) Konnten's bitt'schoen spaeter nochmal reinschauen
969647fd	151	(no) Vennligst prov igjen senere
d82cc9ae	152	(dk) Venligst prov igen senere
d82cc9ae	153	(pl) Prosze sprobowac pozniej
969647fd	154	</pre>
	155
	156	$name = '';
	157	}
e060fe05	158	$c->res->body( <<"" );
7299a7b4	159	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	160	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
	161	<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
969647fd	162	<head>
7299a7b4	163	<meta http-equiv="Content-Language" content="en" />
7299a7b4	164	<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
969647fd	165	<title>$title</title>
7299a7b4	166	<script type="text/javascript">
c6ef5e69	167	<!--
c6ef5e69	168	function toggleDump (dumpElement) {
7299a7b4	169	var e = document.getElementById( dumpElement );
	170	if (e.style.display == "none") {
	171	e.style.display = "";
c6ef5e69	172	}
c6ef5e69	173	else {
7299a7b4	174	e.style.display = "none";
c6ef5e69	175	}
	176	}
	177	-->
	178	</script>
969647fd	179	<style type="text/css">
	180	body {
	181	font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
	182	Tahoma, Arial, helvetica, sans-serif;
34d28dfd	183	color: #333;
969647fd	184	background-color: #eee;
	185	margin: 0px;
	186	padding: 0px;
	187	}
c6ef5e69	188	:link, :link:hover, :visited, :visited:hover {
34d28dfd	189	color: #000;
c6ef5e69	190	}
969647fd	191	div.box {
9619f23c	192	position: relative;
969647fd	193	background-color: #ccc;
	194	border: 1px solid #aaa;
	195	padding: 4px;
	196	margin: 10px;
969647fd	197	}
969647fd	198	div.error {
34d28dfd	199	background-color: #cce;
969647fd	200	border: 1px solid #755;
	201	padding: 8px;
	202	margin: 4px;
	203	margin-bottom: 10px;
969647fd	204	}
969647fd	205	div.infos {
34d28dfd	206	background-color: #eee;
969647fd	207	border: 1px solid #575;
	208	padding: 8px;
	209	margin: 4px;
	210	margin-bottom: 10px;
969647fd	211	}
969647fd	212	div.name {
34d28dfd	213	background-color: #cce;
969647fd	214	border: 1px solid #557;
	215	padding: 8px;
	216	margin: 4px;
969647fd	217	}
7f8e0078	218	code.error {
	219	display: block;
	220	margin: 1em 0;
	221	overflow: auto;
7f8e0078	222	}
9619f23c	223	div.name h1, div.error p {
	224	margin: 0;
	225	}
	226	h2 {
	227	margin-top: 0;
	228	margin-bottom: 10px;
	229	font-size: medium;
	230	font-weight: bold;
	231	text-decoration: underline;
	232	}
	233	h1 {
	234	font-size: medium;
	235	font-weight: normal;
	236	}
2666dd3b	237	/* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
	238	/* Browser specific (not valid) styles to make preformatted text wrap */
	239	pre {
	240	white-space: pre-wrap; /* css-3 */
	241	white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
	242	white-space: -pre-wrap; /* Opera 4-6 */
	243	white-space: -o-pre-wrap; /* Opera 7 */
	244	word-wrap: break-word; /* Internet Explorer 5.5+ */
	245	}
969647fd	246	</style>
	247	</head>
	248	<body>
	249	<div class="box">
	250	<div class="error">$error</div>
	251	<div class="infos">$infos</div>
	252	<div class="name">$name</div>
	253	</div>
	254	</body>
	255	</html>
	256
d82cc9ae	257
	258	# Trick IE
	259	$c->res->{body} .= ( ' ' x 512 );
	260
	261	# Return 500
33117422	262	$c->res->status(500);
969647fd	263	}
969647fd	264
b5ecfcf0	265	=head2 $self->finalize_headers($c)
fc7ec1d9	266
4ab87e27	267	Abstract method, allows engines to write headers to response
4ab87e27	268
fc7ec1d9	269	=cut
	270
	271	sub finalize_headers { }
	272
b5ecfcf0	273	=head2 $self->finalize_read($c)
fc7ec1d9	274
	275	=cut
	276
fbcc39ad	277	sub finalize_read {
fbcc39ad	278	my ( $self, $c ) = @_;
4f5ebacd	279
fbcc39ad	280	undef $self->{_prepared_read};
fc7ec1d9	281	}
fc7ec1d9	282
b5ecfcf0	283	=head2 $self->finalize_uploads($c)
fc7ec1d9	284
4ab87e27	285	Clean up after uploads, deleting temp files.
4ab87e27	286
fc7ec1d9	287	=cut
fc7ec1d9	288
fbcc39ad	289	sub finalize_uploads {
fbcc39ad	290	my ( $self, $c ) = @_;
99fe1710	291
fbcc39ad	292	if ( keys %{ $c->request->uploads } ) {
	293	for my $key ( keys %{ $c->request->uploads } ) {
	294	my $upload = $c->request->uploads->{$key};
	295	unlink map { $_->tempname }
	296	grep { -e $_->tempname }
	297	ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
c85ff642	298	}
c85ff642	299	}
fc7ec1d9	300	}
fc7ec1d9	301
b5ecfcf0	302	=head2 $self->prepare_body($c)
fc7ec1d9	303
4ab87e27	304	sets up the L<Catalyst::Request> object body using L<HTTP::Body>
4ab87e27	305
fc7ec1d9	306	=cut
fc7ec1d9	307
fbcc39ad	308	sub prepare_body {
fbcc39ad	309	my ( $self, $c ) = @_;
99fe1710	310
fbcc39ad	311	$self->read_length( $c->request->header('Content-Length') \|\| 0 );
fbcc39ad	312	my $type = $c->request->header('Content-Type');
99fe1710	313
fbcc39ad	314	unless ( $c->request->{_body} ) {
fbcc39ad	315	$c->request->{_body} = HTTP::Body->new( $type, $self->read_length );
34d28dfd	316	$c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
34d28dfd	317	if exists $c->config->{uploadtmp};
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;
34d28dfd	327	if ( $remaining > 0 ) {
fdb3773e	328	$self->finalize_read($c);
34d28dfd	329	Catalyst::Exception->throw(
34d28dfd	330	"Wrong Content-Length value: " . $self->read_length );
fdb3773e	331	}
fc7ec1d9	332	}
	333	}
	334
b5ecfcf0	335	=head2 $self->prepare_body_chunk($c)
4bd82c41	336
4ab87e27	337	Add a chunk to the request body.
4ab87e27	338
4bd82c41	339	=cut
	340
	341	sub prepare_body_chunk {
	342	my ( $self, $c, $chunk ) = @_;
4f5ebacd	343
4f5ebacd	344	$c->request->{_body}->add($chunk);
4bd82c41	345	}
4bd82c41	346
b5ecfcf0	347	=head2 $self->prepare_body_parameters($c)
06e1b616	348
4ab87e27	349	Sets up parameters from body.
4ab87e27	350
06e1b616	351	=cut
06e1b616	352
fbcc39ad	353	sub prepare_body_parameters {
	354	my ( $self, $c ) = @_;
	355	$c->request->body_parameters( $c->request->{_body}->param );
	356	}
0556eb49	357
b5ecfcf0	358	=head2 $self->prepare_connection($c)
0556eb49	359
4ab87e27	360	Abstract method implemented in engines.
4ab87e27	361
0556eb49	362	=cut
	363
	364	sub prepare_connection { }
	365
b5ecfcf0	366	=head2 $self->prepare_cookies($c)
fc7ec1d9	367
4ab87e27	368	Parse cookies from header. Sets a L<CGI::Cookie> object.
4ab87e27	369
fc7ec1d9	370	=cut
fc7ec1d9	371
6dc87a0f	372	sub prepare_cookies {
fbcc39ad	373	my ( $self, $c ) = @_;
6dc87a0f	374
	375	if ( my $header = $c->request->header('Cookie') ) {
	376	$c->req->cookies( { CGI::Cookie->parse($header) } );
	377	}
	378	}
fc7ec1d9	379
b5ecfcf0	380	=head2 $self->prepare_headers($c)
fc7ec1d9	381
	382	=cut
	383
	384	sub prepare_headers { }
	385
b5ecfcf0	386	=head2 $self->prepare_parameters($c)
fc7ec1d9	387
4ab87e27	388	sets up parameters from query and post parameters.
4ab87e27	389
fc7ec1d9	390	=cut
fc7ec1d9	391
fbcc39ad	392	sub prepare_parameters {
fbcc39ad	393	my ( $self, $c ) = @_;
fc7ec1d9	394
fbcc39ad	395	# We copy, no references
	396	while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) {
	397	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	398	$c->request->parameters->{$name} = $param;
	399	}
fc7ec1d9	400
fbcc39ad	401	# Merge query and body parameters
	402	while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) {
	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	sub _fixup_debug_info {
	580	my $info = encode_entities Dumper shift;
	581	my @info = split "\n", $info;
	582	pop @info; shift @info;
	583	return join "\n",@info;
	584	}
	585
4ab87e27	586	=head2 $self->finalize_output
	587
	588	<obsolete>, see finalize_body
	589
fbcc39ad	590	=head1 AUTHORS
	591
	592	Sebastian Riedel, <sri@cpan.org>
fc7ec1d9	593
fbcc39ad	594	Andy Grundman, <andy@hybridized.org>
fc7ec1d9	595
	596	=head1 COPYRIGHT
	597
	598	This program is free software, you can redistribute it and/or modify it under
	599	the same terms as Perl itself.
	600
	601	=cut
	602
	603	1;