X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine.pm;h=d8d47b51d40be920f379ce2b406ddd687be48c3a;hb=72596f03a20aff3156e410d35e267ec90ee2b849;hp=ec4842b34ebba1bdd4055e93ce28611c950cc6c9;hpb=970cc51d658caacc56714f712fa567398ee48218;p=catagits%2FCatalyst-Runtime.git

diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm
index ec4842b..d8d47b5 100644
--- a/lib/Catalyst/Engine.pm
+++ b/lib/Catalyst/Engine.pm
@@ -3,6 +3,7 @@ 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;
@@ -115,6 +116,42 @@ 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} },
+              _prettify_stats( $action, sprintf( '%fs', $elapsed ), '' );
+            $c->state(@state);
+        }
+        else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
+    };
+    if ( my $error = $@ ) {
+        chomp $error;
+        $error = qq/Caught exception "$error"/;
+        $c->log->error($error);
+        $c->error($error) if $c->debug;
+        $c->state(0);
+    }
+    return $c->state;
+}
+
 =item $c->finalize
 
 Finalize request.
@@ -124,24 +161,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->status(302);
-    }
-
-    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 '<br/>', @{ $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 = <<"";
+        $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';
+
+    my ( $title, $error, $infos );
+    if ( $c->debug ) {
+        $error = join '<br/>', @{ $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 = <<"";
 <br/>
 <b><u>Request</u></b><br/>
 <pre>$req</pre>
@@ -150,11 +239,11 @@ sub finalize {
 <b><u>Stash</u></b><br/>
 <pre>$stash</pre>
 
-        }
-        else {
-            $title = $name;
-            $error = '';
-            $infos = <<"";
+    }
+    else {
+        $title = $name;
+        $error = '';
+        $infos = <<"";
 <pre>
 (en) Please come back later
 (de) Bitte versuchen sie es spaeter nocheinmal
@@ -166,67 +255,62 @@ sub finalize {
 (it) Ritornato prego più successivamente
 </pre>
 
-            $name = '';
-        }
-        $c->res->{output} = <<"";
+        $name = '';
+    }
+    $c->res->output( <<"" );
 <html>
-    <head>
-        <title>$title</title>
-        <style type="text/css">
-            body {
-                font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
-                             Tahoma, Arial, helvetica, sans-serif;
-                color: #ddd;
-                background-color: #eee;
-                margin: 0px;
-                padding: 0px;
-            }
-            div.box {
-                background-color: #ccc;
-                border: 1px solid #aaa;
-                padding: 4px;
-                margin: 10px;
-                -moz-border-radius: 10px;
-            }
-            div.error {
-                background-color: #977;
-                border: 1px solid #755;
-                padding: 8px;
-                margin: 4px;
-                margin-bottom: 10px;
-                -moz-border-radius: 10px;
-            }
-            div.infos {
-                background-color: #797;
-                border: 1px solid #575;
-                padding: 8px;
-                margin: 4px;
-                margin-bottom: 10px;
-                -moz-border-radius: 10px;
-            }
-            div.name {
-                background-color: #779;
-                border: 1px solid #557;
-                padding: 8px;
-                margin: 4px;
-                -moz-border-radius: 10px;
-            }
-        </style>
-    </head>
-    <body>
-        <div class="box">
-            <div class="error">$error</div>
-            <div class="infos">$infos</div>
-            <div class="name">$name</div>
-        </div>
-    </body>
+<head>
+    <title>$title</title>
+    <style type="text/css">
+        body {
+            font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
+                         Tahoma, Arial, helvetica, sans-serif;
+            color: #ddd;
+            background-color: #eee;
+            margin: 0px;
+            padding: 0px;
+        }
+        div.box {
+            background-color: #ccc;
+            border: 1px solid #aaa;
+            padding: 4px;
+            margin: 10px;
+            -moz-border-radius: 10px;
+        }
+        div.error {
+            background-color: #977;
+            border: 1px solid #755;
+            padding: 8px;
+            margin: 4px;
+            margin-bottom: 10px;
+            -moz-border-radius: 10px;
+        }
+        div.infos {
+            background-color: #797;
+            border: 1px solid #575;
+            padding: 8px;
+            margin: 4px;
+            margin-bottom: 10px;
+            -moz-border-radius: 10px;
+        }
+        div.name {
+            background-color: #779;
+            border: 1px solid #557;
+            padding: 8px;
+            margin: 4px;
+            -moz-border-radius: 10px;
+        }
+    </style>
+</head>
+<body>
+    <div class="box">
+        <div class="error">$error</div>
+        <div class="infos">$infos</div>
+        <div class="name">$name</div>
+    </div>
+</body>
 </html>
 
-    }
-    $c->res->headers->content_length( length $c->res->output );
-    my $status = $c->finalize_headers;
-    $c->finalize_output;
-    return $status;
 }
 
 =item $c->finalize_headers
@@ -250,7 +334,7 @@ sub finalize_output { }
 Forward processing to a private action or a method from a class.
 If you define a class without method it will default to process().
 
-    $c->forward('foo');
+    $c->forward('/foo');
     $c->forward('index');
     $c->forward(qw/MyApp::Model::CDBI::Foo do_stuff/);
     $c->forward('MyApp::View::TT');
@@ -266,7 +350,11 @@ sub forward {
     }
     my $caller    = caller(0);
     my $namespace = '/';
-    if ( $command =~ /^\/(.*)$/ ) { $command = $1 }
+    if ( $command =~ /^\// ) {
+        $command =~ /^(.*)\/(\w+)$/;
+        $namespace = $1 || '/';
+        $command = $2;
+    }
     else { $namespace = _class2prefix($caller) || '/' }
     my $results = $c->get_action( $command, $namespace );
     unless ( @{$results} ) {
@@ -345,14 +433,16 @@ Handles the request.
 
 =cut
 
-sub handler ($$) {
-    my ( $class, $r ) = @_;
+sub handler {
+    my ( $class, $engine ) = @_;
 
     # Always expect worst case!
     my $status = -1;
     eval {
+        my @stats = ();
         my $handler = sub {
-            my $c         = $class->prepare($r);
+            my $c = $class->prepare($engine);
+            $c->{stats} = \@stats;
             my $action    = $c->req->action;
             my $namespace = '';
             $namespace = ( join( '/', @{ $c->req->args } ) || '/' )
@@ -369,11 +459,13 @@ sub handler ($$) {
                 for my $begin ( @{ $c->get_action( 'begin', $namespace ) } ) {
                     $c->state( $c->execute( @{ $begin->[0] } ) );
                 }
-                for my $result ( @{ $c->get_action( $action, $default ) } ) {
+                for my $result ( @{ $c->get_action( $action, $default ) }[-1] )
+                {
                     $c->state( $c->execute( @{ $result->[0] } ) );
                     last unless $default;
                 }
-                for my $end ( @{ $c->get_action( 'end', $namespace ) } ) {
+                for my $end ( reverse @{ $c->get_action( 'end', $namespace ) } )
+                {
                     $c->state( $c->execute( @{ $end->[0] } ) );
                 }
             }
@@ -392,7 +484,7 @@ sub handler ($$) {
             ( $elapsed, $status ) = $class->benchmark($handler);
             $elapsed = sprintf '%f', $elapsed;
             my $av = sprintf '%.3f', 1 / $elapsed;
-            $class->log->info( "Request took $elapsed" . "s ($av/s)" );
+            $class->log->info( "Request took $elapsed" . "s ($av/s)", @stats );
         }
         else { $status = &$handler }
     };
@@ -440,8 +532,8 @@ sub prepare {
     }
     $c->prepare_request($r);
     $c->prepare_path;
-    $c->prepare_cookies;
     $c->prepare_headers;
+    $c->prepare_cookies;
     $c->prepare_connection;
     my $method   = $c->req->method   || '';
     my $path     = $c->req->path     || '';
@@ -456,9 +548,9 @@ sub prepare {
         my @params;
         for my $key ( keys %{ $c->req->params } ) {
             my $value = $c->req->params->{$key} || '';
-            push @params, "$key=$value";
+            push @params, "  $key=$value";
         }
-        $c->log->debug( 'Parameters are "' . join( ' ', @params ) . '"' );
+        $c->log->debug( 'Parameters are', @params );
     }
     $c->prepare_uploads;
     return $c;
@@ -522,7 +614,13 @@ Prepare cookies.
 
 =cut
 
-sub prepare_cookies { }
+sub prepare_cookies {
+    my $c = shift;
+
+    if ( my $header = $c->request->header('Cookie') ) {
+        $c->req->cookies( { CGI::Cookie->parse($header) } );
+    }
+}
 
 =item $c->prepare_headers
 
@@ -564,39 +662,6 @@ Prepare uploads.
 
 sub prepare_uploads { }
 
-=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);
-    eval {
-        if ( $c->debug )
-        {
-            my $action = $c->actions->{reverse}->{"$code"} || "$code";
-            my ( $elapsed, @state ) =
-              $c->benchmark( $code, $class, $c, @{ $c->req->args } );
-            $c->log->info( sprintf qq/Processing "$action" took %fs/, $elapsed )
-              if $c->debug;
-            $c->state(@state);
-        }
-        else { $c->state( &$code( $class, $c, @{ $c->req->args } ) ) }
-    };
-    if ( my $error = $@ ) {
-        chomp $error;
-        $error = qq/Caught exception "$error"/;
-        $c->log->error($error);
-        $c->error($error) if $c->debug;
-        $c->state(0);
-    }
-    return $c->state;
-}
-
 =item $c->run
 
 Starts the engine.
@@ -630,47 +695,18 @@ Set an action in a given namespace.
 sub set_action {
     my ( $c, $method, $code, $namespace, $attrs ) = @_;
 
-    my $prefix   = _class2prefix($namespace) || '';
-    my $action   = 0;
-    my $public   = 0;
-    my $regex    = 0;
-    my $arg      = '';
-    my $absolute = 0;
+    my $prefix = _class2prefix($namespace) || '';
+    my %flags;
 
     for my $attr ( @{$attrs} ) {
-        if ( $attr =~ /^Action$/ ) {
-            $action++;
-            $arg = $1 if $1;
-        }
-        elsif ( $attr =~ /^Path\((.+)\)$/i ) {
-            $arg = $1;
-            $public++;
-        }
-        elsif ( $attr =~ /^Public$/i ) {
-            $public++;
-        }
-        elsif ( $attr =~ /^Private$/i ) {
-            $action++;
-        }
-        elsif ( $attr =~ /Regex(?:\((.+)\))?$/i ) {
-            $regex++;
-            $action++;
-            $arg = $1 if $1;
-        }
-        elsif ( $attr =~ /Absolute(?:\((.+)\))?$/i ) {
-            $action++;
-            $absolute++;
-            $public++;
-            $arg = $1 if $1;
-        }
-        elsif ( $attr =~ /Relative(?:\((.+)\))?$/i ) {
-            $action++;
-            $public++;
-            $arg = $1 if $1;
-        }
+        if    ( $attr =~ /^(Local|Relative)$/ )        { $flags{local}++ }
+        elsif ( $attr =~ /^(Global|Absolute)$/ )       { $flags{global}++ }
+        elsif ( $attr =~ /^Path\((.+)\)$/i )           { $flags{path} = $1 }
+        elsif ( $attr =~ /^Private$/i )                { $flags{private}++ }
+        elsif ( $attr =~ /^(Regex|Regexp)\((.+)\)$/i ) { $flags{regex} = $2 }
     }
 
-    return unless $action;
+    return unless keys %flags;
 
     my $parent  = $c->tree;
     my $visitor = Tree::Simple::Visitor::FindByPath->new;
@@ -689,32 +725,36 @@ sub set_action {
     my $uid = $parent->getUID;
     $c->actions->{private}->{$uid}->{$method} = [ $namespace, $code ];
     my $forward = $prefix ? "$prefix/$method" : $method;
-    $c->log->debug(qq|Private "/$forward" is "$namespace->$method"|)
-      if $c->debug;
 
-    $arg =~ s/^\w+//;
-    $arg =~ s/\w+$//;
-    if ( $arg =~ /^'(.*)'$/ ) { $arg = $1 }
-    if ( $arg =~ /^"(.*)"$/ ) { $arg = $1 }
+    if ( $flags{path} ) {
+        $flags{path} =~ s/^\w+//;
+        $flags{path} =~ s/\w+$//;
+        if ( $flags{path} =~ /^'(.*)'$/ ) { $flags{path} = $1 }
+        if ( $flags{path} =~ /^"(.*)"$/ ) { $flags{path} = $1 }
+    }
+    if ( $flags{regex} ) {
+        $flags{regex} =~ s/^\w+//;
+        $flags{regex} =~ s/\w+$//;
+        if ( $flags{regex} =~ /^'(.*)'$/ ) { $flags{regex} = $1 }
+        if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
+    }
 
-    my $reverse = $prefix ? "$method ($prefix)" : $method;
+    my $reverse = $prefix ? "$prefix/$method" : $method;
 
-    if ($public) {
-        my $is_absolute = 0;
-        $is_absolute = 1 if $absolute;
-        if ( $arg =~ /^\/(.+)/ ) {
-            $arg         = $1;
-            $is_absolute = 1;
+    if ( $flags{local} || $flags{global} || $flags{path} ) {
+        my $path = $flags{path} || $method;
+        my $absolute = 0;
+        if ( $path =~ /^\/(.+)/ ) {
+            $path     = $1;
+            $absolute = 1;
         }
-        my $name =
-          $is_absolute ? ( $arg || $method ) : "$prefix/" . ( $arg || $method );
+        $absolute = 1 if $flags{global};
+        my $name = $absolute ? $path : "$prefix/$path";
         $c->actions->{plain}->{$name} = [ $namespace, $code ];
-        $c->log->debug(qq|Public "/$name" is "/$forward"|) if $c->debug;
     }
-    if ($regex) {
-        push @{ $c->actions->{compiled} }, [ $arg, qr#$arg# ];
-        $c->actions->{regex}->{$arg} = [ $namespace, $code ];
-        $c->log->debug(qq|Public "$arg" is "/$forward"|) if $c->debug;
+    if ( my $regex = $flags{regex} ) {
+        push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
+        $c->actions->{regex}->{$regex} = [ $namespace, $code ];
     }
 
     $c->actions->{reverse}->{"$code"} = $reverse;
@@ -750,10 +790,23 @@ sub setup_actions {
         my ( $code, $attrs ) = @{$action};
         my $name = '';
         no strict 'refs';
-        for my $sym ( values %{ $comp . '::' } ) {
-            if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
-                $name = *{$sym}{NAME};
-                $self->set_action( $name, $code, $comp, $attrs );
+        my @cache = ( $comp, @{"$comp\::ISA"} );
+        my %namespaces;
+        while ( my $namespace = shift @cache ) {
+            $namespaces{$namespace}++;
+            for my $isa ( @{"$comp\::ISA"} ) {
+                next if $namespaces{$isa};
+                push @cache, $isa;
+                $namespaces{$isa}++;
+            }
+        }
+        for my $namespace ( keys %namespaces ) {
+            for my $sym ( values %{ $namespace . '::' } ) {
+                if ( *{$sym}{CODE} && *{$sym}{CODE} == $code ) {
+                    $name = *{$sym}{NAME};
+                    $self->set_action( $name, $code, $comp, $attrs );
+                    last;
+                }
             }
         }
     }
@@ -791,10 +844,39 @@ sub setup_components {
         $self->components->{ ref $comp } = $comp;
         $self->setup_actions($comp);
     }
-    $self->log->debug( 'Initialized components "'
-          . join( ' ', keys %{ $self->components } )
-          . '"' )
-      if $self->debug;
+    my @comps;
+    push @comps, "  $_" for keys %{ $self->components };
+    $self->log->debug( 'Loaded components', @comps )
+      if ( @comps && $self->debug );
+    my $actions  = $self->actions;
+    my @messages = ('Loaded private actions');
+    my $walker   = sub {
+        my ( $walker, $parent, $messages, $prefix ) = @_;
+        $prefix .= $parent->getNodeValue || '';
+        $prefix .= '/' unless $prefix =~ /\/$/;
+        my $uid = $parent->getUID;
+        for my $action ( keys %{ $actions->{private}->{$uid} } ) {
+            my ( $class, $code ) = @{ $actions->{private}->{$uid}->{$action} };
+            push @$messages,
+              _prettify_action( "$prefix$action", $class, $code );
+        }
+        $walker->( $walker, $_, $messages, $prefix )
+          for $parent->getAllChildren;
+    };
+    $walker->( $walker, $self->tree, \@messages, '' );
+    $self->log->debug(@messages) if ( $#messages && $self->debug );
+    @messages = ('Loaded plain actions');
+    for my $plain ( sort keys %{ $actions->{plain} } ) {
+        my ( $class, $code ) = @{ $actions->{plain}->{$plain} };
+        push @messages, _prettify_action( "/$plain", $class, $code );
+    }
+    $self->log->debug(@messages) if ( $#messages && $self->debug );
+    @messages = ('Loaded regex actions');
+    for my $regex ( sort keys %{ $actions->{regex} } ) {
+        my ( $class, $code ) = @{ $actions->{regex}->{$regex} };
+        push @messages, _prettify_action( $regex, $class, $code );
+    }
+    $self->log->debug(@messages) if ( $#messages && $self->debug );
 }
 
 =item $c->stash
@@ -826,12 +908,33 @@ sub _prefix {
 
 sub _class2prefix {
     my $class = shift || '';
-    $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/;
-    my $prefix = lc $2 || '';
-    $prefix =~ s/\:\:/\//g;
+    my $prefix;
+    if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
+        $prefix = lc $2;
+        $prefix =~ s/\:\:/\//g;
+    }
     return $prefix;
 }
 
+sub _prettify_action {
+    my ( $val1, $val2, $val3 ) = @_;
+    formline
+'  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>>  ',
+      $val1, $val2, $val3;
+    my $formatted = $^A;
+    $^A = '';
+    return $formatted;
+}
+
+sub _prettify_stats {
+    my ( $val1, $val2 ) = @_;
+    formline '  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< ',
+      $val1, $val2;
+    my $formatted = $^A;
+    $^A = '';
+    return $formatted;
+}
+
 =back
 
 =head1 AUTHOR