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

package Catalyst::Engine;

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 namespace::clean -except => 'meta';

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

has _prepared_write => (is => 'rw');

# 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 ( 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 = (
            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 appropriate 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
        $c->req->_clear_context;
        $c->res->_clear_context;

        # Don't show body parser in the dump
        $c->req->_clear_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
(pt) Por favor volte mais tarde
(ru) Попробуйте еще раз позже
(ua) Спробуйте ще раз пізніше
</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 = grep { length $_ } 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 implements 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);
    }
    
    return 0 if !defined $buffer;
    
    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

Catalyst Contributors, see Catalyst.pm

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