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

package Catalyst::Engine;

use MRO::Compat;
use mro 'c3';
use Moose;
with 'MooseX::Emulate::Class::Accessor::Fast';

use CGI::Simple::Cookie;
use Data::Dump qw/dump/;
use Errno 'EWOULDBLOCK';
use HTML::Entities;
use HTTP::Body;
use HTTP::Headers;
use URI::QueryParam;
use Scalar::Util ();

# input position and length
has read_length => (is => 'rw');
has read_position => (is => 'rw');

no Moose;

# 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;
    my $response = $c->response;

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

        my $val = $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) {
        $response->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};

        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 { }

=head2 $self->finalize_uploads($c)

Clean up after uploads, deleting temp files.

=cut

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

    my $request = $c->request;
    foreach my $key (keys %{ $request->uploads }) {
        my $upload = $request->uploads->{$key};
        unlink grep { -e $_ } map { $_->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 ) = @_;

    if ( my $length = $self->read_length ) {
        my $request = $c->request;
        unless ( $request->{_body} ) {
            my $type = $request->header('Content-Type');
            $request->{_body} = HTTP::Body->new( $type, $length );
            $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 ) = @_;

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

    # Merge query and body parameters
    foreach my $name (keys %$body_parameters) {
        my $param = $body_parameters->{$name};
        my @values = ref $param eq 'ARRAY' ? @$param : ($param);
        if ( my $existing = $parameters->{$name} ) {
          unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
        }
        $parameters->{$name} = @values > 1 ? \@values : $values[0];
    }
}

=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 ) = @_;
    
    # Check for keywords (no = signs)
    # (yes, index() is faster than a regex :))
    if ( index( $query_string, '=' ) < 0 ) {
        $c->request->query_keywords( $self->unescape_uri($query_string) );
        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, 2 );
          
        $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 ) = @_;

    # Initialize the read position
    $self->read_position(0);
    
    # Initialize the amount of data we think we need to read
    $self->read_length( $c->request->header('Content-Length') || 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 $request = $c->request;
    return unless $request->{_body};

    my $uploads = $request->{_body}->upload;
    my $parameters = $request->parameters;
    foreach my $name (keys %$uploads) {
        my $files = $uploads->{$name};
        my @uploads;
        for my $upload (ref $files eq 'ARRAY' ? @$files : ($files)) {
            my $headers = HTTP::Headers->new( %{ $upload->{headers} } );
            my $u = Catalyst::Request::Upload->new
              (
               size => $upload->{size},
               type => $headers->content_type,
               headers => $headers,
               tempname => $upload->{tempname},
               filename => $upload->{filename},
              );
            push @uploads, $u;
        }
        $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 $parameters->{$name}) {
            if (ref $parameters->{$name} eq 'ARRAY') {
                push @{ $parameters->{$name} }, @filenames;
            }
            else {
                $parameters->{$name} = [ $parameters->{$name}, @filenames ];
            }
        }
        else {
            $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 ) = @_;

    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.

=cut

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

    unless ( $self->{_prepared_write} ) {
        $self->prepare_write($c);
        $self->{_prepared_write} = 1;
    }
    
    my $len   = length($buffer);
    my $wrote = syswrite STDOUT, $buffer;
    
    if ( !defined $wrote && $! == EWOULDBLOCK ) {
        # Unable to write on the first try, will retry in the loop below
        $wrote = 0;
    }
    
    if ( defined $wrote && $wrote < $len ) {
        # We didn't write the whole buffer
        while (1) {
            my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote;
            if ( defined $ret ) {
                $wrote += $ret;
            }
            else {
                next if $! == EWOULDBLOCK;
                return;
            }
            
            last if $wrote >= $len;
        }
    }
    
    return $wrote;
}

=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})|\+)/defined $1 ? chr(hex($1)) : ' '/eg;

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