X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst.pm;h=8d59a4d1f1517096e437926a33c23e8f8bf3b96f;hp=89b7f9f20df59fe18231e07a30c2518c98642b57;hb=684d10edf63074f94667d437db01d30b8d13cefc;hpb=66e28e3f90fa1c00c75ef7e551b7a4c2e6e453be diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 89b7f9f..8d59a4d 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -11,16 +11,19 @@ use Catalyst::Request::Upload; use Catalyst::Response; use Catalyst::Utils; use NEXT; -use Text::ASCIITable; +use Text::SimpleTable; use Path::Class; use Time::HiRes qw/gettimeofday tv_interval/; use URI; use Scalar::Util qw/weaken/; +use attributes; __PACKAGE__->mk_accessors( qw/counter depth request response state action namespace/ ); +attributes->import( __PACKAGE__, \&namespace, 'lvalue' ); + # Laziness++ *comp = \&component; *req = \&request; @@ -38,12 +41,12 @@ our $DETACH = "catalyst_detach\n"; require Module::Pluggable::Fast; # Helper script generation -our $CATALYST_SCRIPT_GEN = 8; +our $CATALYST_SCRIPT_GEN = 10; __PACKAGE__->mk_classdata($_) for qw/components arguments dispatcher engine log/; -our $VERSION = '5.49_01'; +our $VERSION = '5.49_03'; sub import { my ( $class, @arguments ) = @_; @@ -219,6 +222,23 @@ sub component { Returns a hashref containing your applications settings. +=cut + +=item $c->controller($name) + +Get a L instance by name. + + $c->controller('Foo')->do_stuff; + +=cut + +sub controller { + my ( $c, $name ) = @_; + my $controller = $c->comp("Controller::$name"); + return $controller if $controller; + return $c->comp("C::$name"); +} + =item debug Overload to enable debug messages. @@ -257,10 +277,42 @@ from the function. sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) } +=item $c->model($name) + +Get a L instance by name. + + $c->model('Foo')->do_stuff; + +=cut + +sub model { + my ( $c, $name ) = @_; + my $model = $c->comp("Model::$name"); + return $model if $model; + return $c->comp("M::$name"); +} + =item $c->namespace Accessor to the namespace of the current action +=item $c->path_to(@path) + +Merges C<@path> with $c->config->{home} and returns a L object. + +For example: + + $c->path_to( 'db', 'sqlite.db' ); + +=cut + +sub path_to { + my ( $c, @path ) = @_; + my $path = dir( $c->config->{home}, @path ); + if ( -d $path ) { return $path } + else { return file( $c->config->{home}, @path ) } +} + =item $c->setup Setup. @@ -331,12 +383,8 @@ sub setup { } if (@plugins) { - my $t = Text::ASCIITable->new; - $t->setOptions( 'hide_HeadRow', 1 ); - $t->setOptions( 'hide_HeadLine', 1 ); - $t->setCols('Class'); - $t->setColWidth( 'Class', 75, 1 ); - $t->addRow($_) for @plugins; + my $t = Text::SimpleTable->new(76); + $t->row($_) for @plugins; $class->log->debug( "Loaded plugins:\n" . $t->draw ); } @@ -367,14 +415,13 @@ sub setup { $class->setup_components; if ( $class->debug ) { - my $t = Text::ASCIITable->new; - $t->setOptions( 'hide_HeadRow', 1 ); - $t->setOptions( 'hide_HeadLine', 1 ); - $t->setCols('Class'); - $t->setColWidth( 'Class', 75, 1 ); - $t->addRow($_) for sort keys %{ $class->components }; + my $t = Text::SimpleTable->new( [ 37, 'Class' ], [ 36, 'Type' ] ); + for my $comp ( sort keys %{ $class->components } ) { + my $type = ref $class->components->{$comp} ? 'instance' : 'class'; + $t->row( $comp, $type ); + } $class->log->debug( "Loaded components:\n" . $t->draw ) - if ( @{ $t->{tbl_rows} } ); + if ( keys %{ $class->components } ); } # Add our self to components, since we are also a component @@ -389,27 +436,34 @@ sub setup { $class->log->_flush() if $class->log->can('_flush'); } -=item $c->uri_for($path) +=item $c->uri_for($path,[@args]) Merges path with $c->request->base for absolute uri's and with $c->request->match for relative uri's, then returns a normalized -L object. +L object. If any args are passed, they are added at the end +of the path. =cut sub uri_for { - my ( $c, $path ) = @_; + my ( $c, $path, @args ) = @_; my $base = $c->request->base->clone; my $basepath = $base->path; $basepath =~ s/\/$//; $basepath .= '/'; my $match = $c->request->match; + + # massage match, empty if absolute path $match =~ s/^\///; $match .= '/' if $match; + $path ||= ''; $match = '' if $path =~ /^\//; $path =~ s/^\///; - return URI->new_abs( URI->new_abs( $path, "$basepath$match" ), $base ) - ->canonical; + + # join args with '/', or a blank string + my $args = ( scalar @args ? '/' . join( '/', @args ) : '' ); + return URI->new_abs( URI->new_abs( "$path$args", "$basepath$match" ), + $base )->canonical; } =item $c->error @@ -426,13 +480,20 @@ Add a new error. $c->error('Something bad happened'); +Clean errors. + + $c->error(0); + =cut sub error { my $c = shift; - my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_]; - push @{ $c->{error} }, @$error; - return $c->{error}; + if ( $_[0] ) { + my $error = ref $_[0] eq 'ARRAY' ? $_[0] : [@_]; + push @{ $c->{error} }, @$error; + } + elsif ( defined $_[0] ) { $c->{error} = undef } + return $c->{error} || []; } =item $c->engine @@ -534,6 +595,21 @@ sub stash { return $c->{stash}; } +=item $c->view($name) + +Get a L instance by name. + + $c->view('Foo')->do_stuff; + +=cut + +sub view { + my ( $c, $name ) = @_; + my $view = $c->comp("View::$name"); + return $view if $view; + return $c->comp("V::$name"); +} + =item $c->welcome_message Returns the Catalyst welcome HTML page. @@ -545,20 +621,24 @@ sub welcome_message { my $name = $c->config->{name}; my $logo = $c->uri_for('/static/images/catalyst_logo.png'); my $prefix = Catalyst::Utils::appprefix( ref $c ); + $c->response->content_type('text/html; charset=utf-8'); return <<"EOF"; - + + + + $name on Catalyst $VERSION @@ -619,12 +700,12 @@ sub welcome_message {
-

$name on Catalyst +

$name on Catalyst $VERSION

- + Catalyst Logo

Welcome to the wonderful world of Catalyst. This MVC @@ -639,13 +720,13 @@ sub welcome_message { perldoc Catalyst::Manual

What to do next?

Next it's time to write an actual application. Use the - helper scripts to generate controllers, - models and - views, + helper scripts to generate controllers, + models and + views, they can save you a lot of work.

script/${prefix}_create.pl -help

Also, be sure to check out the vast and growing - collection of plugins for Catalyst on CPAN, + collection of plugins for Catalyst on CPAN, you are likely to find what you need there.

@@ -664,7 +745,7 @@ perldoc log->error($error); $c->error($error); $c->state(0); } @@ -787,6 +884,10 @@ Finalize request. sub finalize { my $c = shift; + for my $error ( @{ $c->error } ) { + $c->log->error($error); + } + $c->finalize_uploads; # Error @@ -887,13 +988,21 @@ Finalize uploads. Cleans up any temporary files. sub finalize_uploads { my $c = shift; $c->engine->finalize_uploads( $c, @_ ) } -=item $c->get_action( $action, $namespace, $inherit ) +=item $c->get_action( $action, $namespace ) Get an action in a given namespace. =cut -sub get_action { my $c = shift; $c->dispatcher->get_action( $c, @_ ) } +sub get_action { my $c = shift; $c->dispatcher->get_action(@_) } + +=item $c->get_actions( $action, $namespace ) + +Get all actions of a given name in a namespace and all base namespaces. + +=cut + +sub get_actions { my $c = shift; $c->dispatcher->get_actions( $c, @_ ) } =item handle_request( $class, @arguments ) @@ -922,12 +1031,9 @@ sub handle_request { $elapsed = sprintf '%f', $elapsed; my $av = sprintf '%.3f', ( $elapsed == 0 ? '??' : ( 1 / $elapsed ) ); - my $t = Text::ASCIITable->new; - $t->setCols( 'Action', 'Time' ); - $t->setColWidth( 'Action', 64, 1 ); - $t->setColWidth( 'Time', 9, 1 ); + my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] ); - for my $stat (@stats) { $t->addRow( $stat->[0], $stat->[1] ) } + for my $stat (@stats) { $t->row( $stat->[0], $stat->[1] ) } $class->log->info( "Request took ${elapsed}s ($av/s)\n" . $t->draw ); } @@ -1045,15 +1151,11 @@ sub prepare_body { $c->prepare_uploads; if ( $c->debug && keys %{ $c->req->body_parameters } ) { - my $t = Text::ASCIITable->new; - $t->setCols( 'Key', 'Value' ); - $t->setColWidth( 'Key', 37, 1 ); - $t->setColWidth( 'Value', 36, 1 ); - $t->alignCol( 'Value', 'right' ); + my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] ); for my $key ( sort keys %{ $c->req->body_parameters } ) { my $param = $c->req->body_parameters->{$key}; my $value = defined($param) ? $param : ''; - $t->addRow( $key, + $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value ); } $c->log->debug( "Body Parameters are:\n" . $t->draw ); @@ -1141,15 +1243,11 @@ sub prepare_query_parameters { $c->engine->prepare_query_parameters( $c, @_ ); if ( $c->debug && keys %{ $c->request->query_parameters } ) { - my $t = Text::ASCIITable->new; - $t->setCols( 'Key', 'Value' ); - $t->setColWidth( 'Key', 37, 1 ); - $t->setColWidth( 'Value', 36, 1 ); - $t->alignCol( 'Value', 'right' ); + my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] ); for my $key ( sort keys %{ $c->req->query_parameters } ) { my $param = $c->req->query_parameters->{$key}; my $value = defined($param) ? $param : ''; - $t->addRow( $key, + $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value ); } $c->log->debug( "Query Parameters are:\n" . $t->draw ); @@ -1184,17 +1282,16 @@ sub prepare_uploads { $c->engine->prepare_uploads( $c, @_ ); if ( $c->debug && keys %{ $c->request->uploads } ) { - my $t = Text::ASCIITable->new; - $t->setCols( 'Key', 'Filename', 'Type', 'Size' ); - $t->setColWidth( 'Key', 12, 1 ); - $t->setColWidth( 'Filename', 28, 1 ); - $t->setColWidth( 'Type', 18, 1 ); - $t->setColWidth( 'Size', 9, 1 ); - $t->alignCol( 'Size', 'left' ); + my $t = Text::SimpleTable->new( + [ 12, 'Key' ], + [ 28, 'Filename' ], + [ 18, 'Type' ], + [ 9, 'Size' ] + ); for my $key ( sort keys %{ $c->request->uploads } ) { my $upload = $c->request->uploads->{$key}; for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) { - $t->addRow( $key, $u->filename, $u->type, $u->size ); + $t->row( $key, $u->filename, $u->type, $u->size ); } } $c->log->debug( "File Uploads are:\n" . $t->draw ); @@ -1257,11 +1354,11 @@ sub setup_components { my $callback = sub { my ( $component, $context ) = @_; - unless ( $component->isa('Catalyst::Base') ) { + unless ( $component->isa('Catalyst::Component') ) { return $component; } - my $suffix = Catalyst::Utils::class2classsuffix($component); + my $suffix = Catalyst::Utils::class2classsuffix($class); my $config = $class->config->{$suffix} || {}; my $instance; @@ -1429,6 +1526,38 @@ qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/ ); } + # check for old engines that are no longer compatible + my $old_engine; + if ( $engine->isa('Catalyst::Engine::Apache') + && !Catalyst::Engine::Apache->VERSION ) + { + $old_engine = 1; + } + + elsif ( $engine->isa('Catalyst::Engine::Server::Base') + && Catalyst::Engine::Server->VERSION le '0.02' ) + { + $old_engine = 1; + } + + elsif ($engine->isa('Catalyst::Engine::HTTP::POE') + && $engine->VERSION eq '0.01' ) + { + $old_engine = 1; + } + + elsif ($engine->isa('Catalyst::Engine::Zeus') + && $engine->VERSION eq '0.01' ) + { + $old_engine = 1; + } + + if ($old_engine) { + Catalyst::Exception->throw( message => + qq/Engine "$engine" is not supported by this version of Catalyst/ + ); + } + # engine instance $class->engine( $engine->new ); } @@ -1469,7 +1598,14 @@ sub setup_log { $class->log( Catalyst::Log->new ); } - if ( $ENV{CATALYST_DEBUG} || $ENV{ uc($class) . '_DEBUG' } || $debug ) { + my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG'; + + if ( + ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) ) + ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} ) + : $debug + ) + { no strict 'refs'; *{"$class\::debug"} = sub { 1 }; $class->log->debug('Debug messages enabled'); @@ -1519,8 +1655,27 @@ sub write { return $c->engine->write( $c, @_ ); } +=item version + +Returns the Catalyst version number. mostly useful for powered by messages +in template systems. + +=cut + +sub version { return $Catalyst::VERSION } + =back +=head1 INTERNAL ACTIONS + +Catalyst uses internal actions like C<_DISPATCH>, C<_BEGIN>, C<_AUTO> +C<_ACTION> and C<_END>, these are by default not shown in the private +action table. + +But you can deactivate this with a config parameter. + + MyApp->config->{show_internal_actions} = 1; + =head1 CASE SENSITIVITY By default Catalyst is not case sensitive, so C becomes @@ -1632,6 +1787,8 @@ Arthur Bergman Autrijus Tang +Brian Cassidy + Christian Hansen Christopher Hicks @@ -1664,6 +1821,10 @@ Matt S Trout Robert Sedlacek +Sam Vilain + +Sascha Kiefer + Tatsuhiko Miyagawa Ulf Edvinsson @@ -1676,7 +1837,7 @@ Sebastian Riedel, C =head1 LICENSE -This library is free software . You can redistribute it and/or modify it under +This library is free software, you can redistribute it and/or modify it under the same terms as Perl itself. =cut