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;
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);
+ eval {
+ if ( $c->debug )
+ {
+ my $action = $c->actions->{reverse}->{"$code"};
+ $action = "/$action" unless $action =~ /\-\>/;
+ my ( $elapsed, @state ) =
+ $c->benchmark( $code, $class, $c, @{ $c->req->args } );
+ push @{ $c->{stats} },
+ _prettify( $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.
sub finalize {
my $c = shift;
+ $c->finalize_cookies;
+
if ( my $location = $c->res->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);
+ $c->response->header( Location => $location );
+ $c->response->status(302);
+ }
+
+ if ( $c->res->status =~ /^(1\d\d|[23]04)$/ ) {
+ $c->response->headers->remove_content_headers;
return $c->finalize_headers;
}
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_headers
Finalize headers.
=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 } ) || '/' )
( $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 }
};
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;
=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
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.
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;
if ( $flags{path} ) {
$flags{path} =~ s/^\w+//;
if ( $flags{regex} =~ /^"(.*)"$/ ) { $flags{regex} = $1 }
}
- my $reverse = $prefix ? "$method ($prefix)" : $method;
+ my $reverse = $prefix ? "$prefix/$method" : $method;
if ( $flags{local} || $flags{global} || $flags{path} ) {
my $path = $flags{path} || $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 ( my $regex = $flags{regex} ) {
push @{ $c->actions->{compiled} }, [ $regex, qr#$regex# ];
$c->actions->{regex}->{$regex} = [ $namespace, $code ];
- $c->log->debug(qq|Public "$regex" is "/$forward"|) if $c->debug;
}
$c->actions->{reverse}->{"$code"} = $reverse;
$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( "$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( "/$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( $regex, $class, $code );
+ }
+ $self->log->debug(@messages) if ( $#messages && $self->debug );
}
=item $c->stash
return $prefix;
}
+sub _prettify {
+ my ( $val1, $val2, $val3 ) = @_;
+ formline
+' @<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>>>>>> ',
+ $val1, $val2, $val3;
+ my $formatted = $^A;
+ $^A = '';
+ return $formatted;
+}
+
=back
=head1 AUTHOR
projects / catagits/Catalyst-Runtime.git / blobdiff