X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine.pm;h=641cc6d63ac6e0a0e684da3ec897635896a5ad8d;hb=cd677e12b127597abb93b76560c8cb23a47d5da6;hp=8968128834def8259acad48bfc4399e1e2903337;hpb=92a3f2c99c49d32ada1bf0106ae324f92e795a43;p=catagits%2FCatalyst-Runtime.git
diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm
index 8968128..641cc6d 100644
--- a/lib/Catalyst/Engine.pm
+++ b/lib/Catalyst/Engine.pm
@@ -3,28 +3,23 @@ package Catalyst::Engine;
use strict;
use base qw/Class::Data::Inheritable Class::Accessor::Fast/;
use UNIVERSAL::require;
+use CGI::Cookie;
use Data::Dumper;
use HTML::Entities;
use HTTP::Headers;
-use Memoize;
use Time::HiRes qw/gettimeofday tv_interval/;
-use Tree::Simple;
-use Tree::Simple::Visitor::FindByPath;
+use Text::ASCIITable;
use Catalyst::Request;
+use Catalyst::Request::Upload;
use Catalyst::Response;
require Module::Pluggable::Fast;
$Data::Dumper::Terse = 1;
-__PACKAGE__->mk_classdata($_) for qw/actions components tree/;
+__PACKAGE__->mk_classdata('components');
__PACKAGE__->mk_accessors(qw/request response state/);
-__PACKAGE__->actions(
- { plain => {}, private => {}, regex => {}, compiled => [], reverse => {} }
-);
-__PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
-
*comp = \&component;
*req = \&request;
*res = \&response;
@@ -32,8 +27,6 @@ __PACKAGE__->tree( Tree::Simple->new( 0, Tree::Simple->ROOT ) );
our $COUNT = 1;
our $START = time;
-memoize('_class2prefix');
-
=head1 NAME
Catalyst::Engine - The Catalyst Engine
@@ -115,6 +108,45 @@ sub error {
return $c->{error};
}
+=item $c->execute($class, $coderef)
+
+Execute a coderef in given class and catch exceptions.
+Errors are available via $c->error.
+
+=cut
+
+sub execute {
+ my ( $c, $class, $code ) = @_;
+ $class = $c->comp($class) || $class;
+ $c->state(0);
+ my $callsub = ( caller(1) )[3];
+ eval {
+ if ( $c->debug )
+ {
+ my $action = $c->actions->{reverse}->{"$code"};
+ $action = "/$action" unless $action =~ /\-\>/;
+ $action = "-> $action" if $callsub =~ /forward$/;
+ my ( $elapsed, @state ) =
+ $c->benchmark( $code, $class, $c, @{ $c->req->args } );
+ push @{ $c->{stats} }, [ $action, sprintf( '%fs', $elapsed ) ];
+ $c->state(@state);
+ }
+ else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
+ };
+ if ( my $error = $@ ) {
+
+ unless ( ref $error ) {
+ chomp $error;
+ $error = qq/Caught exception "$error"/;
+ }
+
+ $c->log->error($error);
+ $c->error($error);
+ $c->state(0);
+ }
+ return $c->state;
+}
+
=item $c->finalize
Finalize request.
@@ -124,26 +156,76 @@ Finalize request.
sub finalize {
my $c = shift;
- if ( my $location = $c->res->redirect ) {
+ $c->finalize_cookies;
+
+ if ( my $location = $c->response->redirect ) {
$c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
- $c->res->headers->header( Location => $location );
- $c->res->headers->remove_content_headers;
- $c->res->status(302);
- return $c->finalize_headers;
+ $c->response->header( Location => $location );
+ $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
+ }
+
+ if ( $#{ $c->error } >= 0 ) {
+ $c->finalize_error;
+ }
+
+ if ( !$c->response->output && $c->response->status !~ /^(1|3)\d\d$/ ) {
+ $c->finalize_error;
+ }
+
+ if ( $c->response->output && !$c->response->content_length ) {
+ use bytes; # play safe with a utf8 aware perl
+ $c->response->content_length( length $c->response->output );
+ }
+
+ my $status = $c->finalize_headers;
+ $c->finalize_output;
+ return $status;
+}
+
+=item $c->finalize_cookies
+
+Finalize cookies.
+
+=cut
+
+sub finalize_cookies {
+ my $c = shift;
+
+ while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
+ my $cookie = CGI::Cookie->new(
+ -name => $name,
+ -value => $cookie->{value},
+ -expires => $cookie->{expires},
+ -domain => $cookie->{domain},
+ -path => $cookie->{path},
+ -secure => $cookie->{secure} || 0
+ );
+
+ $c->res->headers->push_header( 'Set-Cookie' => $cookie->as_string );
}
+}
+
+=item $c->finalize_error
+
+Finalize error.
+
+=cut
+
+sub finalize_error {
+ my $c = shift;
+
+ $c->res->headers->content_type('text/html');
+ my $name = $c->config->{name} || 'Catalyst Application';
- if ( !$c->res->output || $#{ $c->error } >= 0 ) {
- $c->res->headers->content_type('text/html');
- my $name = $c->config->{name} || 'Catalyst Application';
- my ( $title, $error, $infos );
- if ( $c->debug ) {
- $error = join '
', @{ $c->error };
- $error ||= 'No output';
- $title = $name = "$name on Catalyst $Catalyst::VERSION";
- my $req = encode_entities Dumper $c->req;
- my $res = encode_entities Dumper $c->res;
- my $stash = encode_entities Dumper $c->stash;
- $infos = <<"";
+ my ( $title, $error, $infos );
+ if ( $c->debug ) {
+ $error = join '
', @{ $c->error };
+ $error ||= 'No output';
+ $title = $name = "$name on Catalyst $Catalyst::VERSION";
+ my $req = encode_entities Dumper $c->req;
+ my $res = encode_entities Dumper $c->res;
+ my $stash = encode_entities Dumper $c->stash;
+ $infos = <<"";
Request
$req
@@ -152,11 +234,11 @@ sub finalize {
Stash
$stash
- }
- else {
- $title = $name;
- $error = '';
- $infos = <<"";
+ }
+ else {
+ $title = $name;
+ $error = '';
+ $infos = <<"";
(en) Please come back later
(de) Bitte versuchen sie es spaeter nocheinmal
@@ -168,67 +250,62 @@ sub finalize {
(it) Ritornato prego più successivamente
- $name = '';
- }
- $c->res->{output} = <<"";
+ $name = '';
+ }
+ $c->res->output( <<"" );
-
- $title
-
-
-
-
-
$error
-
$infos
-
$name
-
+
$error
+
$infos
+
$name
+