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

package Catalyst::Engine;

use strict;
use base 'Class::Accessor::Fast';
use CGI::Simple::Cookie;
use Data::Dump qw/dump/;
use HTML::Entities;
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
use Scalar::Util ();

# 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 = 64 * 1024;

=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;
    no warnings 'uninitialized';
    if ( Scalar::Util::blessed($body) && $body->can('read') or 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::Simple::Cookie objects 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 = (
            Scalar::Util::blessed($val)
            ? $val
            : CGI::Simple::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 ) = @_;
    
    my $length = $c->request->header('Content-Length') || 0;

    $self->read_length( $length );

    if ( $length > 0 ) {
        unless ( $c->request->{_body} ) {
            my $type = $c->request->header('Content-Type');
            $c->request->{_body} = HTTP::Body->new( $type, $length );
            $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
              if exists $c->config->{uploadtmp};
        }
        
        while ( my $buffer = $self->read($c) ) {
            $c->prepare_body_chunk($buffer);
        }

        # paranoia against wrong Content-Length header
        my $remaining = $length - $self->read_position;
        if ( $remaining > 0 ) {
            $self->finalize_read($c);
            Catalyst::Exception->throw(
                "Wrong Content-Length value: $length" );
        }
    }
    else {
        # Defined but will cause all body code to be skipped
        $c->request->{_body} = 0;
    }
}

=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 ) = @_;
    
    return unless $c->request->{_body};
    
    $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::Simple::Cookie> object.

=cut

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

    if ( my $header = $c->request->header('Cookie') ) {
        $c->req->cookies( { CGI::Simple::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 ) = @_;
    
    # Make sure query has params
    if ( index( $query_string, '=' ) < 0 ) {
        return;
    }

    my %query;

    # replace semi-colons
    $query_string =~ s/;/&/g;
    
    my @params = split /&/, $query_string;

    for my $item ( @params ) {
        
        my ($param, $value) 
            = map { $self->unescape_uri($_) }
              split( /=/, $item );
          
        $param = $self->unescape_uri($item) unless defined $param;
        
        if ( exists $query{$param} ) {
            if ( ref $query{$param} ) {
                push @{ $query{$param} }, $value;
            }
            else {
                $query{$param} = [ $query{$param}, $value ];
            }
        }
        else {
            $query{$param} = $value;
        }
    }

    $c->request->query_parameters( \%query );
}

=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 ) = @_;
    
    return unless $c->request->{_body};
    
    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;
        # append, if there's already params with this name
        if (exists $c->request->parameters->{$name}) {
            if (ref $c->request->parameters->{$name} eq 'ARRAY') {
                push @{ $c->request->parameters->{$name} }, @filenames;
            }
            else {
                $c->request->parameters->{$name} = 
                    [ $c->request->parameters->{$name}, @filenames ];
            }
        }
        else {
            $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->unescape_uri($uri)

Unescapes a given URI using the most efficient method available.  Engines such
as Apache may implement this using Apache's C-based modules, for example.

=cut

sub unescape_uri {
    my ( $self, $str ) = @_;
    
    $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    $str =~ s/\+/ /g;
    
    return $str;
}

=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';
fa32ac82	5	use CGI::Simple::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;
2832cb5d	11	use Scalar::Util ();
fbcc39ad	12
fbcc39ad	13	# input position and length
4f5ebacd	14	__PACKAGE__->mk_accessors(qw/read_position read_length/);
fbcc39ad	15
	16	# Stringify to class
	17	use overload '""' => sub { return ref shift }, fallback => 1;
fc7ec1d9	18
4bd82c41	19	# Amount of data to read from input on each pass
4bb8bd62	20	our $CHUNKSIZE = 64 * 1024;
4bd82c41	21
fc7ec1d9	22	=head1 NAME
	23
	24	Catalyst::Engine - The Catalyst Engine
	25
	26	=head1 SYNOPSIS
	27
	28	See L<Catalyst>.
	29
	30	=head1 DESCRIPTION
	31
23f9d934	32	=head1 METHODS
fc7ec1d9	33
cd3bb248	34
b5ecfcf0	35	=head2 $self->finalize_body($c)
06e1b616	36
fbcc39ad	37	Finalize body. Prints the response output.
06e1b616	38
	39	=cut
	40
fbcc39ad	41	sub finalize_body {
fbcc39ad	42	my ( $self, $c ) = @_;
7257e9db	43	my $body = $c->response->body;
f9b6d612	44	no warnings 'uninitialized';
f9b6d612	45	if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) {
7257e9db	46	while ( !eof $body ) {
4c423abf	47	read $body, my ($buffer), $CHUNKSIZE;
6484fba0	48	last unless $self->write( $c, $buffer );
f4a57de4	49	}
7257e9db	50	close $body;
f4a57de4	51	}
f4a57de4	52	else {
7257e9db	53	$self->write( $c, $body );
f4a57de4	54	}
fbcc39ad	55	}
6dc87a0f	56
b5ecfcf0	57	=head2 $self->finalize_cookies($c)
6dc87a0f	58
fa32ac82	59	Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
fa32ac82	60	response headers.
4ab87e27	61
6dc87a0f	62	=cut
	63
	64	sub finalize_cookies {
fbcc39ad	65	my ( $self, $c ) = @_;
6dc87a0f	66
fbcc39ad	67	my @cookies;
c82ed742	68
	69	foreach my $name ( keys %{ $c->response->cookies } ) {
	70
	71	my $val = $c->response->cookies->{$name};
fbcc39ad	72
2832cb5d	73	my $cookie = (
	74	Scalar::Util::blessed($val)
	75	? $val
	76	: CGI::Simple::Cookie->new(
	77	-name => $name,
	78	-value => $val->{value},
	79	-expires => $val->{expires},
	80	-domain => $val->{domain},
	81	-path => $val->{path},
	82	-secure => $val->{secure} \|\| 0
	83	)
6dc87a0f	84	);
6dc87a0f	85
fbcc39ad	86	push @cookies, $cookie->as_string;
6dc87a0f	87	}
6dc87a0f	88
b39840da	89	for my $cookie (@cookies) {
b39840da	90	$c->res->headers->push_header( 'Set-Cookie' => $cookie );
fbcc39ad	91	}
fbcc39ad	92	}
969647fd	93
b5ecfcf0	94	=head2 $self->finalize_error($c)
969647fd	95
4ab87e27	96	Output an apropriate error message, called if there's an error in $c
	97	after the dispatch has finished. Will output debug messages if Catalyst
	98	is in debug mode, or a `please come back later` message otherwise.
	99
969647fd	100	=cut
	101
	102	sub finalize_error {
fbcc39ad	103	my ( $self, $c ) = @_;
969647fd	104
7299a7b4	105	$c->res->content_type('text/html; charset=utf-8');
34d28dfd	106	my $name = $c->config->{name} \|\| join(' ', split('::', ref $c));
969647fd	107
	108	my ( $title, $error, $infos );
	109	if ( $c->debug ) {
62d9b030	110
62d9b030	111	# For pretty dumps
b5ecfcf0	112	$error = join '', map {
	113	'<p><code class="error">'
	114	. encode_entities($_)
	115	. '</code></p>'
	116	} @{ $c->error };
969647fd	117	$error \|\|= 'No output';
2666dd3b	118	$error = qq{<pre wrap="">$error</pre>};
969647fd	119	$title = $name = "$name on Catalyst $Catalyst::VERSION";
d82cc9ae	120	$name = "<h1>$name</h1>";
fbcc39ad	121
	122	# Don't show context in the dump
	123	delete $c->req->{_context};
	124	delete $c->res->{_context};
	125
	126	# Don't show body parser in the dump
	127	delete $c->req->{_body};
	128
	129	# Don't show response header state in dump
	130	delete $c->res->{_finalized_headers};
	131
c6ef5e69	132	my @infos;
c6ef5e69	133	my $i = 0;
c6ef5e69	134	for my $dump ( $c->dump_these ) {
c6ef5e69	135	my $name = $dump->[0];
f63c03e4	136	my $value = encode_entities( dump( $dump->[1] ));
c6ef5e69	137	push @infos, sprintf <<"EOF", $name, $value;
9619f23c	138	<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
c6ef5e69	139	<div id="dump_$i">
2666dd3b	140	<pre wrap="">%s</pre>
c6ef5e69	141	</div>
	142	EOF
	143	$i++;
	144	}
	145	$infos = join "\n", @infos;
969647fd	146	}
	147	else {
	148	$title = $name;
	149	$error = '';
	150	$infos = <<"";
	151	<pre>
	152	(en) Please come back later
0c2b4ac0	153	(fr) SVP veuillez revenir plus tard
969647fd	154	(de) Bitte versuchen sie es spaeter nocheinmal
d82cc9ae	155	(at) Konnten's bitt'schoen spaeter nochmal reinschauen
969647fd	156	(no) Vennligst prov igjen senere
d82cc9ae	157	(dk) Venligst prov igen senere
d82cc9ae	158	(pl) Prosze sprobowac pozniej
969647fd	159	</pre>
	160
	161	$name = '';
	162	}
e060fe05	163	$c->res->body( <<"" );
7299a7b4	164	<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	165	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
	166	<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
969647fd	167	<head>
7299a7b4	168	<meta http-equiv="Content-Language" content="en" />
7299a7b4	169	<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
969647fd	170	<title>$title</title>
7299a7b4	171	<script type="text/javascript">
c6ef5e69	172	<!--
c6ef5e69	173	function toggleDump (dumpElement) {
7299a7b4	174	var e = document.getElementById( dumpElement );
	175	if (e.style.display == "none") {
	176	e.style.display = "";
c6ef5e69	177	}
c6ef5e69	178	else {
7299a7b4	179	e.style.display = "none";
c6ef5e69	180	}
	181	}
	182	-->
	183	</script>
969647fd	184	<style type="text/css">
	185	body {
	186	font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
	187	Tahoma, Arial, helvetica, sans-serif;
34d28dfd	188	color: #333;
969647fd	189	background-color: #eee;
	190	margin: 0px;
	191	padding: 0px;
	192	}
c6ef5e69	193	:link, :link:hover, :visited, :visited:hover {
34d28dfd	194	color: #000;
c6ef5e69	195	}
969647fd	196	div.box {
9619f23c	197	position: relative;
969647fd	198	background-color: #ccc;
	199	border: 1px solid #aaa;
	200	padding: 4px;
	201	margin: 10px;
969647fd	202	}
969647fd	203	div.error {
34d28dfd	204	background-color: #cce;
969647fd	205	border: 1px solid #755;
	206	padding: 8px;
	207	margin: 4px;
	208	margin-bottom: 10px;
969647fd	209	}
969647fd	210	div.infos {
34d28dfd	211	background-color: #eee;
969647fd	212	border: 1px solid #575;
	213	padding: 8px;
	214	margin: 4px;
	215	margin-bottom: 10px;
969647fd	216	}
969647fd	217	div.name {
34d28dfd	218	background-color: #cce;
969647fd	219	border: 1px solid #557;
	220	padding: 8px;
	221	margin: 4px;
969647fd	222	}
7f8e0078	223	code.error {
	224	display: block;
	225	margin: 1em 0;
	226	overflow: auto;
7f8e0078	227	}
9619f23c	228	div.name h1, div.error p {
	229	margin: 0;
	230	}
	231	h2 {
	232	margin-top: 0;
	233	margin-bottom: 10px;
	234	font-size: medium;
	235	font-weight: bold;
	236	text-decoration: underline;
	237	}
	238	h1 {
	239	font-size: medium;
	240	font-weight: normal;
	241	}
2666dd3b	242	/* from http://users.tkk.fi/~tkarvine/linux/doc/pre-wrap/pre-wrap-css3-mozilla-opera-ie.html */
	243	/* Browser specific (not valid) styles to make preformatted text wrap */
	244	pre {
	245	white-space: pre-wrap; /* css-3 */
	246	white-space: -moz-pre-wrap; /* Mozilla, since 1999 */
	247	white-space: -pre-wrap; /* Opera 4-6 */
	248	white-space: -o-pre-wrap; /* Opera 7 */
	249	word-wrap: break-word; /* Internet Explorer 5.5+ */
	250	}
969647fd	251	</style>
	252	</head>
	253	<body>
	254	<div class="box">
	255	<div class="error">$error</div>
	256	<div class="infos">$infos</div>
	257	<div class="name">$name</div>
	258	</div>
	259	</body>
	260	</html>
	261
d82cc9ae	262
	263	# Trick IE
	264	$c->res->{body} .= ( ' ' x 512 );
	265
	266	# Return 500
33117422	267	$c->res->status(500);
969647fd	268	}
969647fd	269
b5ecfcf0	270	=head2 $self->finalize_headers($c)
fc7ec1d9	271
4ab87e27	272	Abstract method, allows engines to write headers to response
4ab87e27	273
fc7ec1d9	274	=cut
	275
	276	sub finalize_headers { }
	277
b5ecfcf0	278	=head2 $self->finalize_read($c)
fc7ec1d9	279
	280	=cut
	281
fbcc39ad	282	sub finalize_read {
fbcc39ad	283	my ( $self, $c ) = @_;
4f5ebacd	284
fbcc39ad	285	undef $self->{_prepared_read};
fc7ec1d9	286	}
fc7ec1d9	287
b5ecfcf0	288	=head2 $self->finalize_uploads($c)
fc7ec1d9	289
4ab87e27	290	Clean up after uploads, deleting temp files.
4ab87e27	291
fc7ec1d9	292	=cut
fc7ec1d9	293
fbcc39ad	294	sub finalize_uploads {
fbcc39ad	295	my ( $self, $c ) = @_;
99fe1710	296
fbcc39ad	297	if ( keys %{ $c->request->uploads } ) {
	298	for my $key ( keys %{ $c->request->uploads } ) {
	299	my $upload = $c->request->uploads->{$key};
	300	unlink map { $_->tempname }
	301	grep { -e $_->tempname }
	302	ref $upload eq 'ARRAY' ? @{$upload} : ($upload);
c85ff642	303	}
c85ff642	304	}
fc7ec1d9	305	}
fc7ec1d9	306
b5ecfcf0	307	=head2 $self->prepare_body($c)
fc7ec1d9	308
4ab87e27	309	sets up the L<Catalyst::Request> object body using L<HTTP::Body>
4ab87e27	310
fc7ec1d9	311	=cut
fc7ec1d9	312
fbcc39ad	313	sub prepare_body {
fbcc39ad	314	my ( $self, $c ) = @_;
847e3257	315
847e3257	316	my $length = $c->request->header('Content-Length') \|\| 0;
99fe1710	317
847e3257	318	$self->read_length( $length );
99fe1710	319
847e3257	320	if ( $length > 0 ) {
	321	unless ( $c->request->{_body} ) {
	322	my $type = $c->request->header('Content-Type');
	323	$c->request->{_body} = HTTP::Body->new( $type, $length );
	324	$c->request->{_body}->{tmpdir} = $c->config->{uploadtmp}
	325	if exists $c->config->{uploadtmp};
	326	}
	327
4f5ebacd	328	while ( my $buffer = $self->read($c) ) {
4f5ebacd	329	$c->prepare_body_chunk($buffer);
fbcc39ad	330	}
fdb3773e	331
fdb3773e	332	# paranoia against wrong Content-Length header
847e3257	333	my $remaining = $length - $self->read_position;
34d28dfd	334	if ( $remaining > 0 ) {
fdb3773e	335	$self->finalize_read($c);
34d28dfd	336	Catalyst::Exception->throw(
847e3257	337	"Wrong Content-Length value: $length" );
fdb3773e	338	}
fc7ec1d9	339	}
847e3257	340	else {
	341	# Defined but will cause all body code to be skipped
	342	$c->request->{_body} = 0;
	343	}
fc7ec1d9	344	}
fc7ec1d9	345
b5ecfcf0	346	=head2 $self->prepare_body_chunk($c)
4bd82c41	347
4ab87e27	348	Add a chunk to the request body.
4ab87e27	349
4bd82c41	350	=cut
	351
	352	sub prepare_body_chunk {
	353	my ( $self, $c, $chunk ) = @_;
4f5ebacd	354
4f5ebacd	355	$c->request->{_body}->add($chunk);
4bd82c41	356	}
4bd82c41	357
b5ecfcf0	358	=head2 $self->prepare_body_parameters($c)
06e1b616	359
4ab87e27	360	Sets up parameters from body.
4ab87e27	361
06e1b616	362	=cut
06e1b616	363
fbcc39ad	364	sub prepare_body_parameters {
fbcc39ad	365	my ( $self, $c ) = @_;
847e3257	366
	367	return unless $c->request->{_body};
	368
fbcc39ad	369	$c->request->body_parameters( $c->request->{_body}->param );
fbcc39ad	370	}
0556eb49	371
b5ecfcf0	372	=head2 $self->prepare_connection($c)
0556eb49	373
4ab87e27	374	Abstract method implemented in engines.
4ab87e27	375
0556eb49	376	=cut
	377
	378	sub prepare_connection { }
	379
b5ecfcf0	380	=head2 $self->prepare_cookies($c)
fc7ec1d9	381
fa32ac82	382	Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
4ab87e27	383
fc7ec1d9	384	=cut
fc7ec1d9	385
6dc87a0f	386	sub prepare_cookies {
fbcc39ad	387	my ( $self, $c ) = @_;
6dc87a0f	388
6dc87a0f	389	if ( my $header = $c->request->header('Cookie') ) {
fa32ac82	390	$c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
6dc87a0f	391	}
6dc87a0f	392	}
fc7ec1d9	393
b5ecfcf0	394	=head2 $self->prepare_headers($c)
fc7ec1d9	395
	396	=cut
	397
	398	sub prepare_headers { }
	399
b5ecfcf0	400	=head2 $self->prepare_parameters($c)
fc7ec1d9	401
4ab87e27	402	sets up parameters from query and post parameters.
4ab87e27	403
fc7ec1d9	404	=cut
fc7ec1d9	405
fbcc39ad	406	sub prepare_parameters {
fbcc39ad	407	my ( $self, $c ) = @_;
fc7ec1d9	408
fbcc39ad	409	# We copy, no references
c82ed742	410	foreach my $name ( keys %{ $c->request->query_parameters } ) {
c82ed742	411	my $param = $c->request->query_parameters->{$name};
fbcc39ad	412	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	413	$c->request->parameters->{$name} = $param;
	414	}
fc7ec1d9	415
fbcc39ad	416	# Merge query and body parameters
c82ed742	417	foreach my $name ( keys %{ $c->request->body_parameters } ) {
c82ed742	418	my $param = $c->request->body_parameters->{$name};
fbcc39ad	419	$param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param;
	420	if ( my $old_param = $c->request->parameters->{$name} ) {
	421	if ( ref $old_param eq 'ARRAY' ) {
	422	push @{ $c->request->parameters->{$name} },
	423	ref $param eq 'ARRAY' ? @$param : $param;
	424	}
	425	else { $c->request->parameters->{$name} = [ $old_param, $param ] }
	426	}
	427	else { $c->request->parameters->{$name} = $param }
	428	}
	429	}
	430
b5ecfcf0	431	=head2 $self->prepare_path($c)
fc7ec1d9	432
4ab87e27	433	abstract method, implemented by engines.
4ab87e27	434
fc7ec1d9	435	=cut
	436
	437	sub prepare_path { }
	438
b5ecfcf0	439	=head2 $self->prepare_request($c)
fc7ec1d9	440
b5ecfcf0	441	=head2 $self->prepare_query_parameters($c)
fc7ec1d9	442
4ab87e27	443	process the query string and extract query parameters.
4ab87e27	444
fc7ec1d9	445	=cut
fc7ec1d9	446
e0616220	447	sub prepare_query_parameters {
e0616220	448	my ( $self, $c, $query_string ) = @_;
933ba403	449
94b8f5de	450	# Make sure query has params
933ba403	451	if ( index( $query_string, '=' ) < 0 ) {
933ba403	452	return;
	453	}
	454
	455	my %query;
e0616220	456
	457	# replace semi-colons
	458	$query_string =~ s/;/&/g;
933ba403	459
933ba403	460	my @params = split /&/, $query_string;
e0616220	461
933ba403	462	for my $item ( @params ) {
	463
	464	my ($param, $value)
	465	= map { $self->unescape_uri($_) }
	466	split( /=/, $item );
	467
	468	$param = $self->unescape_uri($item) unless defined $param;
	469
	470	if ( exists $query{$param} ) {
	471	if ( ref $query{$param} ) {
	472	push @{ $query{$param} }, $value;
	473	}
	474	else {
	475	$query{$param} = [ $query{$param}, $value ];
	476	}
	477	}
	478	else {
	479	$query{$param} = $value;
	480	}
e0616220	481	}
933ba403	482
933ba403	483	$c->request->query_parameters( \%query );
e0616220	484	}
fbcc39ad	485
b5ecfcf0	486	=head2 $self->prepare_read($c)
fbcc39ad	487
4ab87e27	488	prepare to read from the engine.
4ab87e27	489
fbcc39ad	490	=cut
fc7ec1d9	491
fbcc39ad	492	sub prepare_read {
fbcc39ad	493	my ( $self, $c ) = @_;
4f5ebacd	494
fbcc39ad	495	# Reset the read position
4f5ebacd	496	$self->read_position(0);
fbcc39ad	497	}
fc7ec1d9	498
b5ecfcf0	499	=head2 $self->prepare_request(@arguments)
fc7ec1d9	500
4ab87e27	501	Populate the context object from the request object.
4ab87e27	502
fc7ec1d9	503	=cut
fc7ec1d9	504
fbcc39ad	505	sub prepare_request { }
fc7ec1d9	506
b5ecfcf0	507	=head2 $self->prepare_uploads($c)
c9afa5fc	508
fbcc39ad	509	=cut
	510
	511	sub prepare_uploads {
	512	my ( $self, $c ) = @_;
847e3257	513
	514	return unless $c->request->{_body};
	515
fbcc39ad	516	my $uploads = $c->request->{_body}->upload;
	517	for my $name ( keys %$uploads ) {
	518	my $files = $uploads->{$name};
	519	$files = ref $files eq 'ARRAY' ? $files : [$files];
	520	my @uploads;
	521	for my $upload (@$files) {
	522	my $u = Catalyst::Request::Upload->new;
	523	$u->headers( HTTP::Headers->new( %{ $upload->{headers} } ) );
	524	$u->type( $u->headers->content_type );
	525	$u->tempname( $upload->{tempname} );
	526	$u->size( $upload->{size} );
	527	$u->filename( $upload->{filename} );
	528	push @uploads, $u;
	529	}
	530	$c->request->uploads->{$name} = @uploads > 1 ? \@uploads : $uploads[0];
f4a57de4	531
c4bed79a	532	# support access to the filename as a normal param
c4bed79a	533	my @filenames = map { $_->{filename} } @uploads;
a7e05d9d	534	# append, if there's already params with this name
	535	if (exists $c->request->parameters->{$name}) {
	536	if (ref $c->request->parameters->{$name} eq 'ARRAY') {
	537	push @{ $c->request->parameters->{$name} }, @filenames;
	538	}
	539	else {
	540	$c->request->parameters->{$name} =
	541	[ $c->request->parameters->{$name}, @filenames ];
	542	}
	543	}
	544	else {
	545	$c->request->parameters->{$name} =
	546	@filenames > 1 ? \@filenames : $filenames[0];
	547	}
fbcc39ad	548	}
	549	}
	550
b5ecfcf0	551	=head2 $self->prepare_write($c)
c9afa5fc	552
4ab87e27	553	Abstract method. Implemented by the engines.
4ab87e27	554
c9afa5fc	555	=cut
c9afa5fc	556
fbcc39ad	557	sub prepare_write { }
fbcc39ad	558
b5ecfcf0	559	=head2 $self->read($c, [$maxlength])
fbcc39ad	560
	561	=cut
	562
	563	sub read {
	564	my ( $self, $c, $maxlength ) = @_;
4f5ebacd	565
fbcc39ad	566	unless ( $self->{_prepared_read} ) {
4f5ebacd	567	$self->prepare_read($c);
fbcc39ad	568	$self->{_prepared_read} = 1;
fbcc39ad	569	}
4f5ebacd	570
fbcc39ad	571	my $remaining = $self->read_length - $self->read_position;
4bd82c41	572	$maxlength \|\|= $CHUNKSIZE;
4f5ebacd	573
fbcc39ad	574	# Are we done reading?
fbcc39ad	575	if ( $remaining <= 0 ) {
4f5ebacd	576	$self->finalize_read($c);
fbcc39ad	577	return;
fbcc39ad	578	}
c9afa5fc	579
fbcc39ad	580	my $readlen = ( $remaining > $maxlength ) ? $maxlength : $remaining;
	581	my $rc = $self->read_chunk( $c, my $buffer, $readlen );
	582	if ( defined $rc ) {
	583	$self->read_position( $self->read_position + $rc );
	584	return $buffer;
	585	}
	586	else {
4f5ebacd	587	Catalyst::Exception->throw(
4f5ebacd	588	message => "Unknown error reading input: $!" );
fbcc39ad	589	}
fbcc39ad	590	}
fc7ec1d9	591
b5ecfcf0	592	=head2 $self->read_chunk($c, $buffer, $length)
23f9d934	593
fbcc39ad	594	Each engine inplements read_chunk as its preferred way of reading a chunk
fbcc39ad	595	of data.
fc7ec1d9	596
fbcc39ad	597	=cut
61b1e958	598
fbcc39ad	599	sub read_chunk { }
61b1e958	600
b5ecfcf0	601	=head2 $self->read_length
ca39d576	602
fbcc39ad	603	The length of input data to be read. This is obtained from the Content-Length
fbcc39ad	604	header.
fc7ec1d9	605
b5ecfcf0	606	=head2 $self->read_position
fc7ec1d9	607
fbcc39ad	608	The amount of input data that has already been read.
63b763c5	609
b5ecfcf0	610	=head2 $self->run($c)
63b763c5	611
4ab87e27	612	Start the engine. Implemented by the various engine classes.
4ab87e27	613
fbcc39ad	614	=cut
fc7ec1d9	615
fbcc39ad	616	sub run { }
fc7ec1d9	617
b5ecfcf0	618	=head2 $self->write($c, $buffer)
fc7ec1d9	619
4ab87e27	620	Writes the buffer to the client. Can only be called once for a request.
4ab87e27	621
fc7ec1d9	622	=cut
fc7ec1d9	623
fbcc39ad	624	sub write {
fbcc39ad	625	my ( $self, $c, $buffer ) = @_;
4f5ebacd	626
fbcc39ad	627	unless ( $self->{_prepared_write} ) {
4f5ebacd	628	$self->prepare_write($c);
fbcc39ad	629	$self->{_prepared_write} = 1;
fc7ec1d9	630	}
4f5ebacd	631
4f5ebacd	632	print STDOUT $buffer;
fc7ec1d9	633	}
fc7ec1d9	634
933ba403	635	=head2 $self->unescape_uri($uri)
933ba403	636
6a44fe01	637	Unescapes a given URI using the most efficient method available. Engines such
6a44fe01	638	as Apache may implement this using Apache's C-based modules, for example.
933ba403	639
	640	=cut
	641
	642	sub unescape_uri {
8c7d83e1	643	my ( $self, $str ) = @_;
933ba403	644
8c7d83e1	645	$str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
8c7d83e1	646	$str =~ s/\+/ /g;
933ba403	647
8c7d83e1	648	return $str;
933ba403	649	}
34d28dfd	650
4ab87e27	651	=head2 $self->finalize_output
	652
	653	<obsolete>, see finalize_body
	654
fbcc39ad	655	=head1 AUTHORS
	656
	657	Sebastian Riedel, <sri@cpan.org>
fc7ec1d9	658
fbcc39ad	659	Andy Grundman, <andy@hybridized.org>
fc7ec1d9	660
	661	=head1 COPYRIGHT
	662
	663	This program is free software, you can redistribute it and/or modify it under
	664	the same terms as Perl itself.
	665
	666	=cut
	667
	668	1;