diff --git a/CHANGES b/CHANGES index 489297012..76619e053 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,22 @@ +1.3089_01 26.11.2011 + + [ BUG FIXES ] + * Fix bug that made system() fail with -1 under Dancer (felixdo). + * Support for 'content_type' option on send_file when sending a + system wide file (Emmanuel Rodriguez). + * Support HTTP_X_FORWARDED_HOST in behing proxy (Ipaponov). + * Deserialize PATCH requests (Sam Kington). + * Encode log messages properly if charset UTF-8 is set (David Precious, + thanks to Penfold for the fix & MiklerGM for reporting). + + [ ENHANCEMENTS ] + * Continuations-style exception system! (Damien Krotkine). + * The ability for dancer_response to send file contents for file uploads + as a scalar, instead of reading from file on disk (Squeeks). + + [ DOCUMENTATION ] + * Clean up "plack_middlewares" example in docs (Richard Simões). + 1.3080 25.10.2011 ** Codename: Sawyer's Sugar Stream // Sawyer X ** diff --git a/MANIFEST b/MANIFEST index ea67e9bfa..92f3b8c3f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -13,6 +13,14 @@ examples/dancr/views/show_entries.tt lib/Dancer.pm lib/Dancer/App.pm lib/Dancer/Config.pm +lib/Dancer/Continuation.pm +lib/Dancer/Continuation/Halted.pm +lib/Dancer/Continuation/Route.pm +lib/Dancer/Continuation/Route/ErrorSent.pm +lib/Dancer/Continuation/Route/FileSent.pm +lib/Dancer/Continuation/Route/Forwarded.pm +lib/Dancer/Continuation/Route/Passed.pm +lib/Dancer/Continuation/Route/Templated.pm lib/Dancer/Cookbook.pod lib/Dancer/Cookie.pm lib/Dancer/Cookies.pm @@ -23,6 +31,7 @@ lib/Dancer/Development/Integration.pod lib/Dancer/Engine.pm lib/Dancer/Error.pm lib/Dancer/Exception.pm +lib/Dancer/Exception/Base.pm lib/Dancer/Factory/Hook.pm lib/Dancer/FileUtils.pm lib/Dancer/GetOpt.pm @@ -302,6 +311,7 @@ t/23_dancer_tests/01_basic.t t/23_dancer_tests/02_tests_functions.t t/24_deployment/01_multi_webapp.t t/25_exceptions/01_exceptions.t +t/25_exceptions/02_exceptions.t t/25_exceptions/views/error.tt t/25_exceptions/views/index.tt t/25_exceptions/views/layouts/main.tt diff --git a/Makefile.PL b/Makefile.PL index 2d0fbad2f..f066c4853 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -47,6 +47,7 @@ WriteMakefile1( 'HTTP::Server::Simple::PSGI' => '0.11', 'MIME::Types' => '0', 'URI' => '1.59', + 'Try::Tiny' => '0.09', # core 'File::Basename' => '0', diff --git a/lib/Dancer.pm b/lib/Dancer.pm index e4d637ce9..e842406e6 100644 --- a/lib/Dancer.pm +++ b/lib/Dancer.pm @@ -5,7 +5,7 @@ use warnings; use Carp; use Cwd 'realpath'; -our $VERSION = '1.3080'; +our $VERSION = '1.3089_01'; our $AUTHORITY = 'SUKRIA'; use Dancer::App; @@ -26,6 +26,14 @@ use Dancer::Session; use Dancer::SharedData; use Dancer::Handler; use Dancer::MIME; +use Dancer::Exception qw(:all); + +use Dancer::Continuation::Halted; +use Dancer::Continuation::Route::Forwarded; +use Dancer::Continuation::Route::Passed; +use Dancer::Continuation::Route::ErrorSent; +use Dancer::Continuation::Route::FileSent; +use Dancer::Continuation::Route::Templated; use File::Spec; @@ -132,13 +140,19 @@ sub dirname { Dancer::FileUtils::dirname(@_) } sub engine { Dancer::Engine->engine(@_) } sub error { goto &Dancer::Logger::error } sub false { 0 } -sub forward { Dancer::SharedData->response->forward(@_) } +sub forward { Dancer::SharedData->response->forward(@_); + # throw a special continuation exception + Dancer::Continuation::Route::Forwarded->new->throw; + } sub from_dumper { Dancer::Serializer::Dumper::from_dumper(@_) } sub from_json { Dancer::Serializer::JSON::from_json(@_) } sub from_xml { Dancer::Serializer::XML::from_xml(@_) } sub from_yaml { Dancer::Serializer::YAML::from_yaml(@_) } sub get { map { my $r = $_; Dancer::App->current->registry->universal_add($r, @_) } qw(head get) } -sub halt { Dancer::SharedData->response->halt(@_) } +sub halt { Dancer::SharedData->response->halt(@_); + # throw a special continuation exception + Dancer::Continuation::Halted->new->throw; + } sub header { goto &headers } sub push_header { Dancer::SharedData->response->push_header(@_); } sub headers { Dancer::SharedData->response->headers(@_); } @@ -158,7 +172,10 @@ sub mime { Dancer::MIME->instance() } sub options { Dancer::App->current->registry->universal_add('options', @_) } sub params { Dancer::SharedData->request->params(@_) } sub param { params->{$_[0]} } -sub pass { Dancer::SharedData->response->pass(1) } +sub pass { Dancer::SharedData->response->pass(1); + # throw a special continuation exception + Dancer::Continuation::Route::Passed->new->throw; + } sub patch { Dancer::App->current->registry->universal_add('patch', @_) } sub path { Dancer::FileUtils::path(@_) } sub post { Dancer::App->current->registry->universal_add('post', @_) } @@ -167,8 +184,16 @@ sub put { Dancer::App->current->registry->universal_add('put', @ sub redirect { goto &_redirect } sub render_with_layout { Dancer::Template::Abstract->_render_with_layout(@_) } sub request { Dancer::SharedData->request } -sub send_error { Dancer::Error->new(message => $_[0], code => $_[1] || 500)->render() } -sub send_file { goto &_send_file } +sub send_error { Dancer::Continuation::Route::ErrorSent->new( + return_value => Dancer::Error->new( + message => $_[0], + code => $_[1] || 500)->render() + )->throw } +#sub send_file { goto &_send_file } +sub send_file { Dancer::Continuation::Route::FileSent->new( + return_value => _send_file(@_) + )->throw + } sub set { goto &setting } sub set_cookie { Dancer::Cookies->set_cookie(@_) } sub setting { Dancer::App->applications ? Dancer::App->current->setting(@_) : Dancer::Config::setting(@_) } @@ -176,7 +201,9 @@ sub session { goto &_session } sub splat { @{ Dancer::SharedData->request->params->{splat} || [] } } sub start { goto &_start } sub status { Dancer::SharedData->response->status(@_) } -sub template { Dancer::Template::Abstract->template(@_) } +sub template { Dancer::Continuation::Route::Templated->new( + return_value => Dancer::Template::Abstract->template(@_) + )->throw } sub to_dumper { Dancer::Serializer::Dumper::to_dumper(@_) } sub to_json { Dancer::Serializer::JSON::to_json(@_) } sub to_xml { Dancer::Serializer::XML::to_xml(@_) } @@ -248,7 +275,7 @@ sub _load_app { # load the application _init_script_dir($script); my ($res, $error) = Dancer::ModuleLoader->load($app_name); - $res or croak "unable to load application $app_name : $error"; + $res or raise core => "unable to load application $app_name : $error"; # restore the main application Dancer::App->set_running_app('main'); @@ -304,7 +331,7 @@ sub _init_script_dir { || Dancer::FileUtils::path($appdir, 'views')); my ($res, $error) = Dancer::ModuleLoader->use_lib(Dancer::FileUtils::path($appdir, 'lib')); - $res or croak "unable to set libdir : $error"; + $res or raise core => "unable to set libdir : $error"; } @@ -327,7 +354,7 @@ sub _redirect { sub _session { engine 'session' - or croak "Must specify session engine in settings prior to using 'session' keyword"; + or raise core => "Must specify session engine in settings prior to using 'session' keyword"; @_ == 0 ? Dancer::Session->get : @_ == 1 ? Dancer::Session->read(@_) : Dancer::Session->write(@_); @@ -342,8 +369,8 @@ sub _send_file { # if you asked for streaming but it's not supported in PSGI if ( $options{'streaming'} && ! $env->{'psgi.streaming'} ) { - # TODO: throw a fit (AKA "exception") or a Dancer::Error (or croak)? - croak 'Sorry, streaming is not supported on this server.'; + # TODO: throw a fit (AKA "exception") or a Dancer::Error? + raise core => 'Sorry, streaming is not supported on this server.'; } if (exists($options{content_type})) { @@ -769,20 +796,21 @@ reached. If it was a B, it will remain a B. Broader functionality might be added in the future. -It is important to note that issuing a forward by itself does not exit and -forward immediately, forwarding is deferred until after the current route -or filter has been processed. To exit and forward immediately, use the return -function, e.g. +B : Issuing a forward immediately exits the current route, +and perform the forward. Thus, any code after a forward is ignored, until the +end of the route. e.g. get '/some/path => sub { if ($condition) { - return forward '/articles/$article_id'; + forward '/articles/$article_id'; + # The following code is never executed + do_stuf(); } more_stuff(); }; -You probably always want to use C with forward. +So it's not necessary anymore to use C with forward. Note that forward doesn't parse GET arguments. So, you can't use something like: @@ -840,7 +868,9 @@ renders the response immediately: before sub { if ($some_condition) { - return halt("Unauthorized"); + halt("Unauthorized"); + # This code is not executed : + do_stuff(); } }; @@ -848,6 +878,10 @@ renders the response immediately: "hello there"; }; +B : Issuing a halt immediately exits the current route, and perform +the halt. Thus, any code after a halt is ignored, until the end of the route. +So it's not necessary anymore to use C with halt. + =head2 headers Adds custom headers to responses: @@ -1056,6 +1090,26 @@ This hook receives as argument a L object. my $response = shift; }; +=item on_handler_exception + +This hook is called when an exception has been caught, at the handler level, +just before creating and rendering L. This hook receives as +argument a L object. + + hook on_handler_exception => sub { + my $exception = shift; + }; + +=item on_route_exception + +This hook is called when an exception has been caught, at the route level, just +before rethrowing it higher. This hook receives the exception as argument. It +can be a Dancer::Exception, or a string, or whatever was used to C. + + hook on_route_exception => sub { + my $exception = shift; + }; + =back =head2 layout @@ -1145,12 +1199,16 @@ I. Tells Dancer to pass the processing of the request to the next matching route. -You should always C after calling C: +B : Issuing a pass immediately exits the current route, and perform +the pass. Thus, any code after a pass is ignored, until the end of the route. +So it's not necessary anymore to use C with pass. get '/some/route' => sub { if (...) { # we want to let the next matching route handler process this one - return pass(); + pass(...); + # This code will be ignored + do_stuff(); } }; @@ -1329,10 +1387,18 @@ Returns a HTTP error. By default the HTTP code returned is 500: } } -This will not cause your route handler to return immediately, so be careful that -your route handler doesn't then override the error. You can avoid that by -saying C instead. +B : Issuing a send_error immediately exits the current route, and perform +the send_error. Thus, any code after a send_error is ignored, until the end of the route. +So it's not necessary anymore to use C with send_error. + get '/some/route' => sub { + if (...) { + # we want to let the next matching route handler process this one + send_error(..); + # This code will be ignored + do_stuff(); + } + }; =head2 send_file @@ -1344,6 +1410,19 @@ the C option (see below). return send_file(params->{file}); } +B : Issuing a send_file immediately exits the current route, and perform +the send_file. Thus, any code after a send_file is ignored, until the end of the route. +So it's not necessary anymore to use C with send_file. + + get '/some/route' => sub { + if (...) { + # we want to let the next matching route handler process this one + send_file(...); + # This code will be ignored + do_stuff(); + } + }; + Send file supports streaming possibility using PSGI streaming. The server should support it but normal streaming is supported on most, if not all. @@ -1615,6 +1694,20 @@ Tells the route handler to build a response with the current template engine: template 'some_view', { token => 'value'}; }; +B : Issuing a template immediately exits the current route, and perform +the template. Thus, any code after a template is ignored, until the end of the route. +So it's not necessary anymore to use C with template. + + get '/some/route' => sub { + if (...) { + # we want to let the next matching route handler process this one + template(...); + # This code will be ignored + do_stuff(); + } + }; + + The first parameter should be a template available in the views directory, the second one (optional) is a HashRef of tokens to interpolate, and the third (again optional) is a HashRef of options. @@ -1727,19 +1820,24 @@ versions: =head2 var -Defines a variable shared between filters and route handlers. +Provides an accessor for variables shared between filters and route handlers. +Given a key/value pair, it sets a variable: before sub { var foo => 42; }; -Route handlers and other filters will be able to read that variable with the -C keyword. +Later, route handlers and other filters will be able to read that variable: + + get '/path' => sub { + my $foo = var 'foo'; + ... + }; =head2 vars Returns the HashRef of all shared variables set during the filter/route -chain: +chain with the C keyword: get '/path' => sub { if (vars->{foo} eq 42) { diff --git a/lib/Dancer/App.pm b/lib/Dancer/App.pm index 57dcf8619..5a03bead4 100644 --- a/lib/Dancer/App.pm +++ b/lib/Dancer/App.pm @@ -9,6 +9,7 @@ use Dancer::Config; use Dancer::ModuleLoader; use Dancer::Route::Registry; use Dancer::Logger; +use Dancer::Exception qw(:all); Dancer::App->attributes(qw(name app_prefix prefix registry settings on_lexical_prefix)); @@ -39,7 +40,7 @@ sub set_prefix { undef $prefix if defined($prefix) and $prefix eq "/"; - croak "not a valid prefix: `$prefix', must start with a /" + raise core_app => "not a valid prefix: `$prefix', must start with a /" if defined($prefix) && $prefix !~ /^\//; my $app_prefix = defined $self->app_prefix ? $self->app_prefix : ""; @@ -155,7 +156,7 @@ sub init { my ($self) = @_; $self->name('main') unless defined $self->name; - croak "an app named '" . $self->name . "' already exists" + raise core_app => "an app named '" . $self->name . "' already exists" if exists $_apps->{$self->name}; # default values for properties diff --git a/lib/Dancer/Config.pm b/lib/Dancer/Config.pm index b6eecb26a..0dd1738b5 100644 --- a/lib/Dancer/Config.pm +++ b/lib/Dancer/Config.pm @@ -10,6 +10,7 @@ use Dancer::Template; use Dancer::ModuleLoader; use Dancer::FileUtils 'path'; use Carp; +use Dancer::Exception qw(:all); use Encode; @@ -72,7 +73,7 @@ my $setters = { }, traces => sub { my ($setting, $traces) = @_; - $Carp::Verbose = $traces ? 1 : 0; + $Dancer::Exception::Verbose = $traces ? 1 : 0; }, }; $setters->{log_path} = $setters->{log_file}; @@ -84,7 +85,7 @@ my $normalizers = { or return $charset; my $encoding = Encode::find_encoding($charset); defined $encoding - or croak "Charset defined in configuration is wrong : couldn't identify '$charset'"; + or raise core_config => "Charset defined in configuration is wrong : couldn't identify '$charset'"; my $name = $encoding->name; # Perl makes a distinction between the usual perl utf8, and the strict # utf8 charset. But we don't want to make this distinction diff --git a/lib/Dancer/Continuation.pm b/lib/Dancer/Continuation.pm new file mode 100644 index 000000000..08acd264e --- /dev/null +++ b/lib/Dancer/Continuation.pm @@ -0,0 +1,16 @@ +package Dancer::Continuation; + +use strict; +use warnings; +use Carp; + +sub new { + my $class = shift; + bless { @_ }, $class; +} + +sub throw { die shift } + +sub rethrow { die shift } + +1; diff --git a/lib/Dancer/Continuation/Halted.pm b/lib/Dancer/Continuation/Halted.pm new file mode 100644 index 000000000..426ce8b54 --- /dev/null +++ b/lib/Dancer/Continuation/Halted.pm @@ -0,0 +1,9 @@ +package Dancer::Continuation::Halted; + +use strict; +use warnings; +use Carp; + +use base qw(Dancer::Continuation); + +1; diff --git a/lib/Dancer/Continuation/Route.pm b/lib/Dancer/Continuation/Route.pm new file mode 100644 index 000000000..cf0795472 --- /dev/null +++ b/lib/Dancer/Continuation/Route.pm @@ -0,0 +1,17 @@ +package Dancer::Continuation::Route; + +use strict; +use warnings; +use Carp; + +use base qw(Dancer::Continuation); + +# A Dancer::Continuation::Route is a continuation exception, that is caught as +# route execution level (see Dancer::Route::run). It may store a return_value, that +# will be recovered from the continuation catcher, and stored as the returning +# content. + +sub return_value { $#_ ? $_[0]->{return_value} = $_[1] : $_[0]->{return_value} } + + +1; diff --git a/lib/Dancer/Continuation/Route/ErrorSent.pm b/lib/Dancer/Continuation/Route/ErrorSent.pm new file mode 100644 index 000000000..54912019f --- /dev/null +++ b/lib/Dancer/Continuation/Route/ErrorSent.pm @@ -0,0 +1,9 @@ +package Dancer::Continuation::Route::ErrorSent; + +use strict; +use warnings; +use Carp; + +use base qw(Dancer::Continuation::Route); + +1; diff --git a/lib/Dancer/Continuation/Route/FileSent.pm b/lib/Dancer/Continuation/Route/FileSent.pm new file mode 100644 index 000000000..4ad4a3506 --- /dev/null +++ b/lib/Dancer/Continuation/Route/FileSent.pm @@ -0,0 +1,9 @@ +package Dancer::Continuation::Route::FileSent; + +use strict; +use warnings; +use Carp; + +use base qw(Dancer::Continuation::Route); + +1; diff --git a/lib/Dancer/Continuation/Route/Forwarded.pm b/lib/Dancer/Continuation/Route/Forwarded.pm new file mode 100644 index 000000000..9aa9ba39a --- /dev/null +++ b/lib/Dancer/Continuation/Route/Forwarded.pm @@ -0,0 +1,9 @@ +package Dancer::Continuation::Route::Forwarded; + +use strict; +use warnings; +use Carp; + +use base qw(Dancer::Continuation::Route); + +1; diff --git a/lib/Dancer/Continuation/Route/Passed.pm b/lib/Dancer/Continuation/Route/Passed.pm new file mode 100644 index 000000000..7921b3a20 --- /dev/null +++ b/lib/Dancer/Continuation/Route/Passed.pm @@ -0,0 +1,9 @@ +package Dancer::Continuation::Route::Passed; + +use strict; +use warnings; +use Carp; + +use base qw(Dancer::Continuation::Route); + +1; diff --git a/lib/Dancer/Continuation/Route/Templated.pm b/lib/Dancer/Continuation/Route/Templated.pm new file mode 100644 index 000000000..84b726177 --- /dev/null +++ b/lib/Dancer/Continuation/Route/Templated.pm @@ -0,0 +1,9 @@ +package Dancer::Continuation::Route::Templated; + +use strict; +use warnings; +use Carp; + +use base qw(Dancer::Continuation::Route); + +1; diff --git a/lib/Dancer/Cookbook.pod b/lib/Dancer/Cookbook.pod index f6219e22a..d6e8310e6 100644 --- a/lib/Dancer/Cookbook.pod +++ b/lib/Dancer/Cookbook.pod @@ -879,7 +879,7 @@ For instance, if you want to enable L in your Dancer application, all you have to do is to set C like that: set plack_middlewares => [ - [ 'Debug' => [ 'panels' => qw(DBITrace Memory Timer) ]], + [ 'Debug' => [ 'panels' => [qw(DBITrace Memory Timer)] ] ], ]; Of course, you can also put this configuration into your config.yml file, or @@ -890,11 +890,12 @@ even in your environment configuration files: plack_middlewares: - - Debug # first element of the array is the name of the middleware - - panels # following elements are the configuration ofthe middleware - - - DBITrace - - Memory - - Timer + - panels # following elements are the configuration ofthe middleware + - + - DBITrace + - Memory + - Timer =head3 Path-based middlewares @@ -908,5 +909,3 @@ C. You'll need L to do that. =head1 AUTHORS Dancer contributors - see AUTHORS file. - - diff --git a/lib/Dancer/Deprecation.pm b/lib/Dancer/Deprecation.pm index bd2bccd67..2c6f82089 100644 --- a/lib/Dancer/Deprecation.pm +++ b/lib/Dancer/Deprecation.pm @@ -2,7 +2,8 @@ package Dancer::Deprecation; use strict; use warnings; -use Carp qw/croak carp/; +use Carp; +use Dancer::Exception qw(:all); sub deprecated { my ($class, %args) = @_; @@ -25,7 +26,7 @@ sub deprecated { $msg .= " since version $deprecated_at" if defined $deprecated_at; $msg .= ". " . $args{reason} if defined $args{reason}; - croak($msg) if $args{fatal}; + raise core_deprecation => $msg if $args{fatal}; carp($msg); } @@ -59,7 +60,7 @@ List of possible parameters: =item B message to display -=item B if set to true, croak instead of carp +=item B if set to true, raises a Dancer::Exception (Core::Deprecation) instead of carp =item B why is the feature deprecated diff --git a/lib/Dancer/Engine.pm b/lib/Dancer/Engine.pm index 770a90a53..ceb9e0b5d 100644 --- a/lib/Dancer/Engine.pm +++ b/lib/Dancer/Engine.pm @@ -9,6 +9,7 @@ use warnings; use Carp; use Dancer::ModuleLoader; use base 'Dancer::Object'; +use Dancer::Exception qw(:all); # constructor arguments: # name => $name_of_the_engine @@ -30,7 +31,7 @@ sub config { sub build { my ($class, $type, $name, $config) = @_; - croak "cannot build engine without type and name " + raise core_engine => "cannot build engine without type and name " unless $name and $type; my $class_name = $class->_engine_class($type); @@ -43,7 +44,7 @@ sub build { my $engine_class = Dancer::ModuleLoader->class_from_setting($class_name => $name); - croak "unknown $type engine '$name', " + raise core_engine => "unknown $type engine '$name', " . "perhaps you need to install $engine_class?" unless Dancer::ModuleLoader->load($engine_class); diff --git a/lib/Dancer/Error.pm b/lib/Dancer/Error.pm index f361cdaf8..9e0ec2d42 100644 --- a/lib/Dancer/Error.pm +++ b/lib/Dancer/Error.pm @@ -328,6 +328,14 @@ The message of the error page. This is only an attribute getter, you'll have to set it at C. +=head2 exception + +The exception that caused the error. If the error was not caused by an +exception, returns undef. Exceptions are usually objects that inherits of +Dancer::Exception. + +This is only an attribute getter, you'll have to set it at C. + =head1 METHODS/SUBROUTINES =head2 new @@ -350,6 +358,10 @@ The code that caused the error. The message that will appear to the user. +=head3 exception + +The exception that will be useable by the rendering. + =head2 backtrace Create a backtrace of the code where the error is caused. diff --git a/lib/Dancer/Exception.pm b/lib/Dancer/Exception.pm index 9516c35ee..b44abbe5a 100644 --- a/lib/Dancer/Exception.pm +++ b/lib/Dancer/Exception.pm @@ -4,207 +4,273 @@ use strict; use warnings; use Carp; +our $Verbose = 0; + +use Dancer::Exception::Base; + use base qw(Exporter); -my @exceptions = qw(E_HALTED E_GENERIC); -our @EXPORT_OK = (@exceptions, qw(raise list_exceptions is_dancer_exception register_custom_exception)); -our %value_to_custom_name; -our %custom_name_to_value; -our %EXPORT_TAGS = ( exceptions => [ @exceptions], - internal_exceptions => [ @exceptions], - custom_exceptions => [], - utils => => [ qw(raise list_exceptions is_dancer_exception register_custom_exception) ], - all => \@EXPORT_OK, - ); +our @EXPORT_OK = (qw(try catch continuation register_exception registered_exceptions raise)); +our %EXPORT_TAGS = ( all => \@EXPORT_OK ); +use Try::Tiny (); -=head1 SYNOPSIS +sub try (&;@) { + goto &Try::Tiny::try; +} - use Dancer::Exception qw(:all); +sub catch (&;@) { + my ( $block, @rest ) = @_; + + my $continuation_code; + my @new_rest = grep { ref ne 'Try::Tiny::Catch' or $continuation_code = $$_, 0 } @rest; + $continuation_code + and return ( bless( \ sub { + ref && $_->isa('Dancer::Continuation') + ? $continuation_code->(@_) : $block->(@_); + }, 'Try::Tiny::Catch') , @new_rest); + + return ( bless ( \ sub { + ref && $_->isa('Dancer::Continuation') + ? die($_) : $block->(@_) ; + }, 'Try::Tiny::Catch'), @new_rest ); +} + +sub continuation (&;@) { + my ( $block, @rest ) = @_; + + my $catch_code; + my @new_rest = grep { ref ne 'Try::Tiny::Catch' or $catch_code = $$_, 0 } @rest; + $catch_code + and return ( bless( \ sub { + ref && $_->isa('Dancer::Continuation') + ? $block->(@_) : $catch_code->(@_); + }, 'Try::Tiny::Catch') , @new_rest); + + return ( bless ( \ sub { + ref && $_->isa('Dancer::Continuation') + ? $block->(@_) : die($_); + }, 'Try::Tiny::Catch'), @new_rest ); +} - # raise an exception - raise E_HALTED; +sub raise ($;@) { + my $exception_name = shift; + my $exception; + if ($exception_name =~ s/^\+//) { + $exception = $exception_name->new(@_); + } else { + _camelize($exception_name); + $exception = "Dancer::Exception::$exception_name"->new(@_); + } + $exception->throw(); +} - # get a list of possible exceptions - my @exception_names = list_exceptions; +sub _camelize { + # using aliasing for ease of use + $_[0] =~ s/^(.)/uc($1)/e; + $_[0] =~ s/_(.)/'::' . uc($1)/eg; +} - # catch an exception - eval { ... }; - if ( my $value = is_dancer_exception(my $exception = $@) ) { - if ($value == ( E_HALTED | E_FOO ) ) { - # it's a halt or foo exception... +sub register_exception { + my ($exception_name, %params) = @_; + my $exception_class = 'Dancer::Exception::' . $exception_name; + my $path = $exception_class; $path =~ s|::|/|g; $path .= '.pm'; + + if (exists $INC{$path}) { + local $Carp::CarpLevel = $Carp::CarpLevel++; + 'Dancer::Exception::Base::Internal' + ->new("register_exception failed: $exception_name is already defined") + ->throw; } - } elsif ($exception) { - # do something with $exception (don't use $@ as it may have been reset) - } -=head1 DESCRIPTION + my $message_pattern = $params{message_pattern}; + my $composed_from = $params{composed_from}; + my @composition = map { 'Dancer::Exception::' . $_ } @$composed_from; -This is a lighweight exceptions module. Yes, it's not Object Oriented, that's -on purpose, to keep it light and fast. Thus, you can use ref() instead of -->isa(), and exceptions have no method to call on. Simply dereference them to -get their value + $INC{$path} = __FILE__; + eval "\@${exception_class}::ISA=qw(Dancer::Exception::Base " . join (' ', @composition) . ');'; + + if (defined $message_pattern) { + no strict 'refs'; + *{"${exception_class}::_message_pattern"} = sub { $message_pattern }; + } -An exception is a blessed reference on an integer. This integer is always a -power of two, so that you can test its value using the C<|> operator. A Dancer -exception is always blessed as C<'Dancer::Exception'>. +} -=head1 EXPORTS +sub registered_exceptions { + sort map { s|/|::|g; s/\.pm$//; $_ } grep { s|^Dancer/Exception/||; } keys %INC; +} -to be able to use this module, you should use it with these options : +register_exception(@$_) foreach ( + [ 'Core', message_pattern => 'core - %s' ], + [ 'Core::App', message_pattern => 'app - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Config', message_pattern => 'config - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Deprecation', message_pattern => 'deprecation - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Engine', message_pattern => 'engine - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Factory', message_pattern => 'factory - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Factory::Hook', message_pattern => 'hook - %s', composed_from => [ qw(Core::Factory) ] ], + [ 'Core::Hook', message_pattern => 'hook - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Fileutils', message_pattern => 'file utils - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Handler', message_pattern => 'handler - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Handler::PSGI', message_pattern => 'handler - %s', composed_from => [ qw(Core::Handler) ] ], + [ 'Core::Plugin', message_pattern => 'plugin - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Renderer', message_pattern => 'renderer - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Route', message_pattern => 'route - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Serializer', message_pattern => 'serializer - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Template', message_pattern => 'template - %s', composed_from => [ qw(Core) ] ], + [ 'Core::Session', message_pattern => 'session - %s', composed_from => [ qw(Core) ] ], +); - # loads specific exceptions only. See list_exceptions for a list - use Dancer::Exception qw(E_HALTED E_PLOP); +1; - # loads the utility functions - use Dancer::Exception qw(raise list_exceptions is_dancer_exception register_custom_exception); +__END__ - # this does the same thing as above - use Dancer::Exception qw(:utils); +=pod - # loads all exception names, but not the utils - use Dancer::Exception qw(:exceptions); +=head1 NAME - # loads only the internal exception names - use Dancer::Exception qw(:internal_exceptions); +Dancer::Exception - class for throwing and catching exceptions - # loads only the custom exception names - use Dancer::Exception qw(:custom_exceptions); +=head1 SYNOPSIS - # loads everything - use Dancer::Exception qw(:all); + use Dancer::Exception qw(:all); -=head1 FUNCTIONS + register_exception('DataProblem', + message_pattern => "test message : %s" + ); -=head2 raise + sub do_stuff { + raise DataProblem => "we've lost data!"; + } - raise E_HALTED; + try { + do_stuff() + } catch { + # an exception was thrown + my ($exception) = @_; + if ($exception->does('DataProblem')) { + # handle the data problem + my $message = $exception->message(); + } else { + $exception->rethrow + } + }; -Used to raise an exception. Takes in argument an integer (must be a power of -2). You should give it an existing Dancer exception. -=cut -# yes we use __CLASS__, it's not OO and inheritance proof, but if you'd pay -# attention, you'd have noticed that this module is *not* a class :) -sub raise { die bless \ do { my $e = $_[0] }, __PACKAGE__ } +=head1 DESCRIPTION -=head2 list_exceptions +Dancer::Exception is based on L. You can try and catch exceptions, +like in L. - my @exception_names = list_exceptions; - my @exception_names = list_exceptions(type => 'internal'); - my @exception_names = list_exceptions(type => 'custom'); +Exceptions are objects, from subclasses of L. -Returns a list of strings, the names of available exceptions. +However, for internal Dancer usage, we introduce a special class of exceptions, +called L. Exceptions that are from this class are not +caught with a C block, but only with a C. That's a cheap +way to implement a I. Dancer users should ignore this +feature. -Parameters are an optional list of key values. Accepted keys are for now only -C, to restrict the list of exceptions on the type of the Dancer -exception. C can be 'internal' or 'custom'. +=head2 What it means for Dancer users -=cut +Users can throw and catch exceptions, using C and C. They can reuse +some Dancer core exceptions (C), but they can also +create new exception classes, and use them for their own means. That way it's +easy to use custom exceptions in a Dancer application. Have a look at +C, C, and the methods in L. -sub list_exceptions { - my %params = @_; - ( $params{type} || '' ) eq 'internal' - and return @exceptions; - ( $params{type} || '' ) eq 'custom' - and return keys %custom_name_to_value; - return @exceptions, keys %custom_name_to_value; -} +=head1 METHODS -=head2 is_dancer_internal_exception - - # test if it's a Dancer exception - my $value = is_dancer_exception($@); - # test if it's a Dancer internal exception - my $value = is_dancer_exception($@, type => 'internal'); - # test if it's a Dancer custom exception - my $value = is_dancer_exception($@, type => 'custom'); - -This function tests if an exception is a Dancer exception, and if yes get its -value. If not, it returns void - -First parameter is the exception to test. Other parameters are an optional list -of key values. Accepted keys are for now only C, to restrict the test on -the type of the Dancer exception. C can be 'internal' or 'custom'. - -Returns the exception value (which is always true), or void (empty list) if the -exception was not a dancer exception (of the right type if specified). - -=cut - -sub is_dancer_exception { - my ($exception, %params) = @_; - ref $exception eq __PACKAGE__ - or return 0; - my $value = $$exception; - @_ > 1 - or return $value; - $params{type} eq 'internal' && $value < 2**16 - and return $value; - $params{type} eq 'custom' && $value >= 2**16 - and return $value; - return 0; -} +=head2 try -=head2 register_custom_exception +Same as in L - register_custom_exception('E_FROBNICATOR'); - # now I can use this exception for raising - raise E_FROBNICATOR; +=head2 catch +Same as in L. The exception can be retrieved as the first parameter: -=cut + try { ... } catch { my ($exception) = @_; }; -sub register_custom_exception { - my ($exception_name, %params) = @_; - exists $value_to_custom_name{$exception_name} - and croak "can't register '$exception_name' custom exception, it already exists"; - keys %value_to_custom_name < 16 - or croak "can't register '$exception_name' custom exception, all 16 custom slots are registered"; - my $value = 2**16; - while($value_to_custom_name{$value}) { $value*=2; } - $value_to_custom_name{$value} = $exception_name; - $custom_name_to_value{$exception_name} = $value; - - my $pkg = __PACKAGE__; - no strict 'refs'; - *{"$pkg\::$exception_name"} = sub { $value }; - - push @EXPORT_OK, $exception_name; - push @{$EXPORT_TAGS{custom_exceptions}}, $exception_name; - $params{no_import} - or $pkg->export_to_level(1, $pkg, $exception_name); - - return; -} +=head2 continuation +To be used by Dancer developers only, in Dancer core code. -=head1 INTERNAL EXCEPTIONS +=head2 raise -=head2 E_GENERIC + # raise Dancer::Exception::Base::Custom + raise Custom => "user $username is unknown"; -A generic purpose exception. Not used by internal code, so this exception can -be used by user code safely, without having to register a custom user exception. + # raise Dancer::Exception::Base::Custom::Frontend + raise 'Custom::Frontend' => "user $username is unknown"; -=cut + # same, raise Dancer::Exception::Base::Custom::Frontend + raise custom_frontend => "user $username is unknown"; -sub E_GENERIC () { 1 } + # raise My::Own::ExceptionSystem::Invalid::Login + raise '+My::Own::ExceptionSystem::Invalid::Login' => "user $username is unknown"; -=head2 E_HALTED +raise provides an easy way to throw an exception. First parameter is the name +of the exception class, without the C prefix. other +parameters are stored as I in the exception. Usually the +parameters is an exception message, but it's left to the exception class +implementation. -Internal exception, generated when C is called (see in L POD). +If the exception class name starts with a C<+>, then the +C won't be added. This allows to build their own +exception class hierarchy, but you should first look at C +before implementing your own class hierarchy. If you really wish to build your +own exception class hierarchy, we recommend that all exceptions inherit of +L. Or at least it should implement its methods. -=cut +The exception class can also be written as words separated by underscores, it'll be +camelized automatically. So C<'Exception::Foo'> and C<'exception_foo'> are +equivalent. Be careful, C<'MyException'> can't be written C<'myexception'>, as +it would be camelized into C<'Myexception'>. -sub E_HALTED () { 2 } +=head2 register_exception -=head1 CUSTOM EXCEPTIONS +This method allows to register custom exceptions, usable by Dancer users in +their route code (actually pretty much everywhere). -In addition to internal (and the generic one) exception, users have the ability -to register more Dancer exceptions for their need. To do that, see -C. + # simple exception + register_exception ('InvalidCredentials', + message_pattern => "invalid credentials : %s", + ); -=cut +This registers a new custom exception. To use it, do: -1; + raise InvalidCredentials => "user Herbert not found"; + +The exception message can be retrieved with the C<$exception->message> method, and we'll be +C<"invalid credentials : user Herbert not found"> (see methods in L) + + # complex exception + register_exception ('InvalidLogin', + composed_from => [qw(Fatal InvalidCredentials)], + message_pattern => "wrong login or password", + ); + +In this example, the C is built as a composition of the C +and C exceptions. See the C method in +L. + +=head2 registered_exceptions + + my @exception_classes = registered_exceptions; + +Returns the list of exception class names. It will list core exceptions C +custom exceptions (except the one you've registered with a leading C<+>, see +C). The list is sorted. + +=head1 GLOBAL VARIABLE + +=head2 $Dancer::Exception::Verbose + +When set to 1, exceptions will stringify with a long stack trace. This variable +is similar to C<$Carp::Verbose>. I recommend you use it like that: + + local $Dancer::Exception::Verbose; + $Dancer::Exception::Verbose = 1; + +All the L global variables can also be used to alter the stacktrace +generation. diff --git a/lib/Dancer/Exception/Base.pm b/lib/Dancer/Exception/Base.pm new file mode 100644 index 000000000..ff51134df --- /dev/null +++ b/lib/Dancer/Exception/Base.pm @@ -0,0 +1,208 @@ +package Dancer::Exception::Base; + +use strict; +use warnings; +use Carp; + +use base qw(Exporter); + +use Dancer::Exception; + +use overload '""' => sub { + my ($self) = @_; + $self->message + . ( $Dancer::Exception::Verbose ? $self->{_longmess} : $self->{_shortmess}); +}; + +# string comparison is done without the stack traces +use overload 'cmp' => sub { + my ($e, $f) = @_; + ( ref $e && $e->isa(__PACKAGE__) + ? $e->message : $e ) + cmp + ( ref $f && $f->isa(__PACKAGE__) + ? $f->message : $f ) +}; + +# This is the base class of all exceptions + +sub new { + my $class = shift; + my $self = bless { _raised_arguments => [], + _shortmess => '', + _longmess => '', + }, $class; + $self->_raised_arguments(@_); + return $self; +} + +# base class has a passthrough message +sub _message_pattern { '%s' } + +sub throw { + my $self = shift; + $self->_raised_arguments(@_); + local $Carp::CarpInternal; + local $Carp::Internal; + $Carp::Internal{'Dancer'} ++; + $Carp::CarpInternal{'Dancer::Exception'} ++; + $self->{_shortmess} = Carp::shortmess; + $self->{_longmess} = Carp::longmess; + die $self; +} + +sub rethrow { die $_[0] } + +sub message { + my ($self) = @_; + my $message_pattern = $self->_message_pattern; + my $message = sprintf($message_pattern, @{$self->_raised_arguments}); + my @composition = (reverse $self->get_composition); + shift @composition; + foreach my $component (@composition) { + my $class = "Dancer::Exception::$component"; + no strict 'refs'; + my $pattern = $class->_message_pattern; + $message = sprintf($pattern, $message); + } + return $message; +} + +sub does { + my $self = shift; + my $regexp = join('|', map { '^' . $_ . '$'; } @_); + (scalar grep { /$regexp/ } $self->get_composition) >= 1; +} + +sub get_composition { + my ($self) = @_; + my $class = ref($self); + my @isa = do { no strict 'refs'; @{"${class}::ISA"}, $class }; + return grep { s|^Dancer::Exception::|| } @isa; +} + +sub _raised_arguments { + my $self = shift; + @_ and $self->{_raised_arguments} = [ @_ ]; + $self->{_raised_arguments}; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Dancer::Exception::Base - the base class of all Dancer exceptions + +=head1 DESCRIPTION + +Dancer::Exception::Base is the base class of all Dancer exception. All core +exceptions, and all custom exception registered using +C inherits of +C. + +=head1 METHODS + +=head2 throw + +Throws an exception. It's what C (from L) uses. Any +arguments is set as raising parameters. You should not use this method +directly, but instead, use C from L. + +B, if you want to rethrow an exception, use C. + +=head2 rethrow + +Re-throw the exception, without touching its parameters. Useful if you've +caught and exception but don't want to handle it, and want to rethrow it. + + try { ... } + catch { + my ($e) = @_; + $e->does('InvalidLogin') + or $e->rethrow; + ... + }; + +=head2 does + +Given an exception type, returns true if the exception is of the same type. + + try { raise InvalidLogin => 'foo'; } + catch { + my ($e) = @_; + $e->does('InvalidLogin') # true + ... + }; + +It can receive more than one type, useful for composed exception, or checking +multiple types at once. C performs a logical OR between them: + + try { raise InvalidPassword => 'foo'; } + catch { + my ($e) = @_; + $e->does('InvalidLogin', 'InvalidPassword') # true + ... + }; + +=head2 get_composition + +Returns the type or the composed types of an exception. +B, the result is a list, so you should call this method in list context. + + try { raise InvalidPassword => 'foo'; } + catch { + my ($e) = @_; + my @list = $e->get_composition() + # @list contains ( 'InvalidPassword' ) + }; + +=head2 message + +Computes and returns the message associated to the exception. It'll apply the +parameters that were set at throw time to the message patterns of all the class +that composes the exception. + +=head1 STRINGIFICATION + +=head2 string overloading + +All Dancer exceptions properly stringify. When evaluated to a string, they +return their message, concatenated with their stack trace (see below). + +=head2 cmp overloading + +The C operator is also overloaded, thus all the string operations can be +done on Dancer's exceptions, as they will all be based on the overloaded C +operator. Dancer exceptions wil be compared B their stacktraces. + +=head1 STACKTRACE + +Similarly to L, Dancer exceptions stringification appends a string +stacktrace to the exception message. + +The stacktrace can be a short one, or a long one. Actually the implementation +internally uses L. + +To enable long stack trace (for debugging purpose), you can use the global +variable C (see below). + +The short and long stacktrace snippets are stored within C<$self->{_shortmess}> +and C<$self->{_longmess}>. Don't touch them or rely on them, they are +internals, and will change soon. + +=head1 GLOBAL VARIABLE + +=head2 $Dancer::Exception::Verbose + +When set to 1, exceptions will stringify with a long stack trace. This variable +is similar to C<$Carp::Verbose>. I recommend you use it like that: + + local $Dancer::Exception::Verbose; + $Dancer::Exception::Verbose = 1; + +All the L global variables can also be used to alter the stacktrace +generation. diff --git a/lib/Dancer/Factory/Hook.pm b/lib/Dancer/Factory/Hook.pm index 59bdd0dce..f392542cb 100644 --- a/lib/Dancer/Factory/Hook.pm +++ b/lib/Dancer/Factory/Hook.pm @@ -5,6 +5,7 @@ use warnings; use Carp; use base 'Dancer::Object::Singleton'; +use Dancer::Exception qw(:all); __PACKAGE__->attributes(qw/ hooks registered_hooks/); @@ -19,12 +20,12 @@ sub install_hooks { my ( $self, @hooks_name ) = @_; if ( !scalar @hooks_name ) { - croak "at least one name is required"; + raise core_factory_hook => "at least one name is required"; } foreach my $hook_name (@hooks_name) { if ( $self->hook_is_registered($hook_name) ) { - croak "$hook_name is already regsitered, please use another name"; + raise core_factory_hook => "$hook_name is already regsitered, please use another name"; } $self->_add_hook( $hook_name ); } @@ -53,10 +54,10 @@ sub hook_is_registered { sub execute_hooks { my ($self, $hook_name, @args) = @_; - croak("Can't ask for hooks without a position") unless $hook_name; + raise core_factory_hook => "Can't ask for hooks without a position" unless $hook_name; if (!$self->hook_is_registered($hook_name)){ - croak("The hook '$hook_name' doesn't exists"); + raise core_factory_hook => "The hook '$hook_name' doesn't exists"; } foreach my $h (@{$self->get_hooks_for($hook_name)}) { @@ -67,7 +68,7 @@ sub execute_hooks { sub get_hooks_for { my ( $self, $hook_name ) = @_; - croak("Can't ask for hooks without a position") unless $hook_name; + raise core_factory_hook => "Can't ask for hooks without a position" unless $hook_name; $self->hooks->{$hook_name} || []; } diff --git a/lib/Dancer/FileUtils.pm b/lib/Dancer/FileUtils.pm index 83cfd176a..9bbda81d7 100644 --- a/lib/Dancer/FileUtils.pm +++ b/lib/Dancer/FileUtils.pm @@ -8,6 +8,8 @@ use File::Spec; use Carp; use Cwd 'realpath'; +use Dancer::Exception qw(:all); + use base 'Exporter'; use vars '@EXPORT_OK'; @@ -65,7 +67,7 @@ sub open_file { my ( $mode, $filename ) = @_; open my $fh, $mode, $filename - or croak "$! while opening '$filename' using mode '$mode'"; + or raise core_fileutils => "$! while opening '$filename' using mode '$mode'"; return set_file_mode($fh); } diff --git a/lib/Dancer/Handler.pm b/lib/Dancer/Handler.pm index 497cbc3a5..3d5aa63c9 100644 --- a/lib/Dancer/Handler.pm +++ b/lib/Dancer/Handler.pm @@ -2,7 +2,7 @@ package Dancer::Handler; use strict; use warnings; -use Carp 'croak'; +use Carp; use File::stat; use HTTP::Headers; @@ -14,9 +14,14 @@ use Dancer::Renderer; use Dancer::Config 'setting'; use Dancer::ModuleLoader; use Dancer::Exception qw(:all); +use Dancer::Factory::Hook; use Encode; +Dancer::Factory::Hook->instance->install_hooks( + qw/on_handler_exception/ +); + # This is where we choose which application handler to return sub get_handler { my $handler = 'Dancer::Handler::Standalone'; @@ -35,7 +40,7 @@ sub get_handler { # load the app handler my ($loaded, $error) = Dancer::ModuleLoader->load($handler); - croak "Unable to load app handler `$handler': $error" if $error; + raise core_handler => "Unable to load app handler `$handler': $error" if $error; # OK, everything's fine, load the handler Dancer::Logger::core('loading ' . $handler . ' handler'); @@ -76,29 +81,32 @@ sub handle_request { sub render_request { my $request = shift; my $action; - $action = eval { + $action = try { Dancer::Renderer->render_file || Dancer::Renderer->render_action || Dancer::Renderer->render_error(404); - }; - - my $value = is_dancer_exception(my $exception = $@); - if ($value && $value & E_HALTED) { - # special case for halted workflow exception: still render the response + } continuation { + # workflow exception (continuation) + my ($continuation) = @_; + $continuation->isa('Dancer::Continuation::Halted') + or $continuation->rethrow(); + # special case for halted workflow continuation: still render the response Dancer::Serializer->process_response(Dancer::SharedData->response); - } elsif ($exception) { + } catch { + my ($exception) = @_; + Dancer::Factory::Hook->execute_hooks('on_handler_exception', $exception); Dancer::Logger::error( 'request to ' . $request->path_info . " crashed: $exception"); + # use stringification, to get exception message in case of a + # Dancer::Exception Dancer::Error->new( code => 500, title => "Runtime Error", - message => $exception, - $value ? ( exception => $value, - exceptions => { }, - ) : (), + message => "$exception", + exception => $exception, )->render(); - } + }; return $action; } diff --git a/lib/Dancer/Handler/PSGI.pm b/lib/Dancer/Handler/PSGI.pm index 98b657a28..f6fea3ef2 100644 --- a/lib/Dancer/Handler/PSGI.pm +++ b/lib/Dancer/Handler/PSGI.pm @@ -11,11 +11,12 @@ use Dancer::Config; use Dancer::ModuleLoader; use Dancer::SharedData; use Dancer::Logger; +use Dancer::Exception qw(:all); sub new { my $class = shift; - croak "Plack::Request is needed by the PSGI handler" + raise core_handler_PSGI => "Plack::Request is needed by the PSGI handler" unless Dancer::ModuleLoader->load('Plack::Request'); my $self = {}; @@ -42,7 +43,7 @@ sub apply_plack_middlewares_map { my $mw_map = Dancer::Config::setting('plack_middlewares_map'); foreach my $req (qw(Plack::App::URLMap Plack::Builder)) { - croak "$req is needed to use apply_plack_middlewares_map" + raise core_handler_PSGI => "$req is needed to use apply_plack_middlewares_map" unless Dancer::ModuleLoader->load($req); } @@ -63,11 +64,11 @@ sub apply_plack_middlewares { my $middlewares = Dancer::Config::setting('plack_middlewares'); - croak "Plack::Builder is needed for middlewares support" + raise core_handler_PSGI => "Plack::Builder is needed for middlewares support" unless Dancer::ModuleLoader->load('Plack::Builder'); ref $middlewares eq "ARRAY" - or croak "'plack_middlewares' setting must be an ArrayRef"; + or raise core_handler_PSGI => "'plack_middlewares' setting must be an ArrayRef"; my $builder = Plack::Builder->new(); diff --git a/lib/Dancer/Handler/Standalone.pm b/lib/Dancer/Handler/Standalone.pm index ec122a131..3a3a8e1ac 100644 --- a/lib/Dancer/Handler/Standalone.pm +++ b/lib/Dancer/Handler/Standalone.pm @@ -60,4 +60,11 @@ sub print_startup_info { } +# Restore expected behavior for wait(), as +# HTTP::Server::Simple sets SIGCHLD to IGNORE. +# (Issue #499) +sub after_setup_listener { + $SIG{CHLD} = ''; +} + 1; diff --git a/lib/Dancer/Hook.pm b/lib/Dancer/Hook.pm index 61c66bd7a..100062aa6 100644 --- a/lib/Dancer/Hook.pm +++ b/lib/Dancer/Hook.pm @@ -18,7 +18,7 @@ sub new { my $self = bless {}, $class; if (!scalar @args) { - croak "one name and a coderef are required"; + raise core_hook => "one name and a coderef are required"; } my $hook_name = shift @args; @@ -42,33 +42,35 @@ sub new { $code = shift @args; } else { - croak "something's wrong with parameters passed to Hook constructor"; + raise core_hook => "something's wrong with parameters passed to Hook constructor"; } ref $code eq 'CODE' - or croak "the code argument passed to hook construction was not a CodeRef. Value was : '$code'"; + or raise core_hook => "the code argument passed to hook construction was not a CodeRef. Value was : '$code'"; my $compiled_filter = sub { + my @arguments = @_; return if Dancer::SharedData->response->halted; my $app = Dancer::App->current(); return unless $properties->should_run_this_app($app->name); Dancer::Logger::core( "entering " . $hook_name . " hook" ); - eval { $code->(@_) }; - if ( is_dancer_exception(my $exception = $@) ) { - # propagate the exception - die $exception; - } elsif ($exception) { - # exception is not a workflow halt but a genuine error + + + try { $code->(@arguments) } + catch { + my ($exception) = @_; + # exception is not a workflow continuation but a genuine error my $err = Dancer::Error->new( code => 500, title => $hook_name . ' filter error', - message => "An error occured while executing the filter named $hook_name: $exception" + message => "An error occured while executing the filter named $hook_name: $exception", + exception => $exception, ); # raise a new halt exception Dancer::halt( $err->render ); - } + }; }; $self->properties($properties); diff --git a/lib/Dancer/Logger/Abstract.pm b/lib/Dancer/Logger/Abstract.pm index 5e8596d3b..c9998dd62 100644 --- a/lib/Dancer/Logger/Abstract.pm +++ b/lib/Dancer/Logger/Abstract.pm @@ -60,10 +60,8 @@ sub format_message { my ($self, $level, $message) = @_; chomp $message; - if (setting('charset')) { - unless (uc setting('charset') eq "UTF-8" && Encode::is_utf8($message)) { - $message = Encode::encode(setting('charset'), $message); - } + if (my $charset = setting('charset')) { + $message = Encode::encode($charset, $message); } $level = 'warn' if $level eq 'warning'; @@ -92,7 +90,7 @@ sub format_message { ? $r->env->{'HTTP_X_REAL_IP'} || $r->env->{'REMOTE_ADDR'} : '-'; }, - t => sub { Encode::decode(setting('charset'), + t => sub { Encode::decode(setting('charset') || 'utf8', POSIX::strftime( "%d/%b/%Y %H:%M:%S", localtime )) }, T => sub { POSIX::strftime( "%Y-%m-%d %H:%M:%S", localtime ) }, P => sub { $$ }, diff --git a/lib/Dancer/Object.pm b/lib/Dancer/Object.pm index d3450c718..6ea5eee16 100644 --- a/lib/Dancer/Object.pm +++ b/lib/Dancer/Object.pm @@ -6,6 +6,7 @@ package Dancer::Object; use strict; use warnings; use Carp; +use Dancer::Exception qw(:all); # constructor sub new { @@ -18,7 +19,7 @@ sub new { sub clone { my ($self) = @_; - croak "The 'Clone' module is needed" + raise core => "The 'Clone' module is needed" unless Dancer::ModuleLoader->load('Clone'); return Clone::clone($self); } diff --git a/lib/Dancer/Object/Singleton.pm b/lib/Dancer/Object/Singleton.pm index cf1ed730d..c33cba764 100644 --- a/lib/Dancer/Object/Singleton.pm +++ b/lib/Dancer/Object/Singleton.pm @@ -6,6 +6,7 @@ package Dancer::Object::Singleton; use strict; use warnings; use Carp; +use Dancer::Exception qw(:all); use base qw(Dancer::Object); @@ -15,12 +16,12 @@ my %instances; # constructor sub new { my ($class) = @_; - croak "you can't call 'new' on $class, as it's a singleton. Try to call 'instance'"; + raise core => "you can't call 'new' on $class, as it's a singleton. Try to call 'instance'"; } sub clone { my ($class) = @_; - croak "you can't call 'clone' on $class, as it's a singleton. Try to call 'instance'"; + raise core => "you can't call 'clone' on $class, as it's a singleton. Try to call 'instance'"; } sub instance { diff --git a/lib/Dancer/Plugin.pm b/lib/Dancer/Plugin.pm index c22529f8b..d3bffab9b 100644 --- a/lib/Dancer/Plugin.pm +++ b/lib/Dancer/Plugin.pm @@ -6,6 +6,8 @@ use Carp; use base 'Exporter'; use Dancer::Config 'setting'; use Dancer::Hook; +use Dancer::Exception qw(:all); + use base 'Exporter'; use vars qw(@EXPORT); @@ -34,7 +36,7 @@ sub register($&) { my $plugin_name = caller(); $keyword =~ /^[a-zA-Z_]+[a-zA-Z0-9_]*$/ - or croak "You can't use '$keyword', it is an invalid name" + or raise core_plugin => "You can't use '$keyword', it is an invalid name" . " (it should match ^[a-zA-Z_]+[a-zA-Z0-9_]*$ )"; if ( @@ -42,11 +44,11 @@ sub register($&) { map { s/^(?:\$|%|&|@|\*)//; $_ } (@Dancer::EXPORT, @Dancer::EXPORT_OK) ) { - croak "You can't use '$keyword', this is a reserved keyword"; + raise core_plugin => "You can't use '$keyword', this is a reserved keyword"; } while (my ($plugin, $keywords) = each %$_keywords) { if (grep { $_->[0] eq $keyword } @$keywords) { - croak "You can't use $keyword, " + raise core_plugin => "You can't use $keyword, " . "this is a keyword reserved by $plugin"; } } diff --git a/lib/Dancer/Renderer.pm b/lib/Dancer/Renderer.pm index f868a9ab0..2f4d5ad11 100644 --- a/lib/Dancer/Renderer.pm +++ b/lib/Dancer/Renderer.pm @@ -17,6 +17,7 @@ use Dancer::FileUtils qw(path path_or_empty dirname read_file_content open_file) use Dancer::SharedData; use Dancer::Logger; use Dancer::MIME; +use Dancer::Exception qw(:all); Dancer::Factory::Hook->instance->install_hooks( qw/before after before_serializer after_serializer before_file_render after_file_render/ @@ -103,7 +104,7 @@ sub get_action_response { || ($method ne Dancer::SharedData->request->method)) { if ($depth > $MAX_RECURSIVE_LOOP) { - croak "infinite loop detected, " + raise core_renderer => "infinite loop detected, " . "check your route/filters for " . $method . ' ' . $path; @@ -182,6 +183,7 @@ sub get_file_response_for_path { my $response = Dancer::SharedData->response() || Dancer::Response->new(); $response->status($status) if ($status); $response->header('Content-Type' => (($mime && _get_full_mime_type($mime)) || + Dancer::SharedData->request->content_type || _get_mime_type($static_file))); $response->content($fh); diff --git a/lib/Dancer/Request.pm b/lib/Dancer/Request.pm index 2739fdc60..aa113bb2c 100644 --- a/lib/Dancer/Request.pm +++ b/lib/Dancer/Request.pm @@ -9,6 +9,7 @@ use base 'Dancer::Object'; use Dancer::Config 'setting'; use Dancer::Request::Upload; use Dancer::SharedData; +use Dancer::Exception qw(:all); use Encode; use HTTP::Body; use URI; @@ -56,7 +57,7 @@ sub host { $_[0]->{host} = $_[1]; } else { my $host; - $host = $_[0]->env->{X_FORWARDED_HOST} if setting('behind_proxy'); + $host = ($_[0]->env->{X_FORWARDED_HOST} || $_[0]->env->{HTTP_X_FORWARDED_HOST}) if setting('behind_proxy'); $host || $_[0]->{host} || $_[0]->env->{HTTP_HOST}; } } @@ -275,7 +276,7 @@ sub params { return $self->{_route_params}; } else { - croak "Unknown source params \"$source\"."; + raise core_request => "Unknown source params \"$source\"."; } } @@ -403,7 +404,7 @@ sub _build_path { $path ||= $self->_url_decode($self->request_uri); } - croak "Cannot resolve path" if not $path; + raise core_request => "Cannot resolve path" if not $path; $self->{path} = $path; } @@ -515,7 +516,7 @@ sub _read { return $buffer; } else { - croak "Unknown error reading input: $!"; + raise core_request => "Unknown error reading input: $!"; } } diff --git a/lib/Dancer/Request/Upload.pm b/lib/Dancer/Request/Upload.pm index 48accf8e5..dc9646d70 100644 --- a/lib/Dancer/Request/Upload.pm +++ b/lib/Dancer/Request/Upload.pm @@ -7,6 +7,7 @@ use strict; use warnings; use base 'Dancer::Object'; use Dancer::FileUtils qw(open_file); +use Dancer::Exception qw(:all); Dancer::Request::Upload->attributes( qw( @@ -18,7 +19,7 @@ sub file_handle { my ($self) = @_; return $self->{_fh} if defined $self->{_fh}; my $fh = open_file('<', $self->tempname) - or croak "Can't open `" . $self->tempname . "' for reading: $!"; + or raise core_request => "Can't open `" . $self->tempname . "' for reading: $!"; $self->{_fh} = $fh; } diff --git a/lib/Dancer/Response.pm b/lib/Dancer/Response.pm index 7e1070f5e..71538231b 100644 --- a/lib/Dancer/Response.pm +++ b/lib/Dancer/Response.pm @@ -12,6 +12,7 @@ use Dancer::MIME; use HTTP::Headers; use Dancer::SharedData; use Dancer::Exception qw(:all); +use Dancer::Continuation::Halted; __PACKAGE__->attributes(qw/content pass streamed/); @@ -101,7 +102,6 @@ sub halt { halted => 1, ); } - raise E_HALTED; } sub halted { diff --git a/lib/Dancer/Route.pm b/lib/Dancer/Route.pm index 6428e7304..1c16959df 100644 --- a/lib/Dancer/Route.pm +++ b/lib/Dancer/Route.pm @@ -10,6 +10,8 @@ use Dancer::Logger; use Dancer::Config 'setting'; use Dancer::Request; use Dancer::Response; +use Dancer::Exception qw(:all); +use Dancer::Factory::Hook; Dancer::Route->attributes( qw( @@ -26,6 +28,10 @@ Dancer::Route->attributes( ) ); +Dancer::Factory::Hook->instance->install_hooks( + qw/on_route_exception/ +); + # supported options and aliases my @_supported_options = Dancer::Request->get_attributes(); my %_options_aliases = (agent => 'user_agent'); @@ -35,7 +41,7 @@ sub init { $self->{'_compiled_regexp'} = undef; if (!$self->pattern) { - croak "cannot create Dancer::Route without a pattern"; + raise core_route => "cannot create Dancer::Route without a pattern"; } # If the route is a Regexp, store it directly @@ -145,7 +151,7 @@ sub check_options { return 1 unless defined $self->options; for my $opt (keys %{$self->options}) { - croak "Not a valid option for route matching: `$opt'" + raise core_route => "Not a valid option for route matching: `$opt'" if not( (grep {/^$opt$/} @{$_supported_options[0]}) || (grep {/^$opt$/} keys(%_options_aliases))); } @@ -166,7 +172,22 @@ sub validate_options { sub run { my ($self, $request) = @_; - my $content = $self->execute(); + my $content = try { + $self->execute(); + } continuation { + my ($continuation) = @_; + # route related continuation + $continuation->isa('Dancer::Continuation::Route') + or $continuation->rethrow(); + # If the continuation carries some content, get it + my $content = $continuation->return_value(); + defined $content or return; # to avoid returning undef; + return $content; + } catch { + my ($exception) = @_; + Dancer::Factory::Hook->execute_hooks('on_route_exception', $exception); + die $exception; + }; my $response = Dancer::SharedData->response; if ( $response && $response->is_forwarded ) { diff --git a/lib/Dancer/Route/Cache.pm b/lib/Dancer/Route/Cache.pm index f2f5615e4..ac1e22b58 100644 --- a/lib/Dancer/Route/Cache.pm +++ b/lib/Dancer/Route/Cache.pm @@ -10,6 +10,7 @@ use vars '$VERSION'; use Dancer::Config 'setting'; use Dancer::Error; +use Dancer::Exception qw(:all); $VERSION = '0.01'; Dancer::Route::Cache->attributes('size_limit', 'path_limit'); @@ -74,7 +75,7 @@ sub route_from_path { my ($self, $method, $path) = @_; $method && $path - or croak "Missing method or path"; + or raise core_route => "Missing method or path"; return $self->{'cache'}{$method}{$path} || undef; } @@ -83,7 +84,7 @@ sub store_path { my ($self, $method, $path, $route) = @_; $method && $path && $route - or croak "Missing method, path or route"; + or raise core_route => "Missing method, path or route"; $self->{'cache'}{$method}{$path} = $route; diff --git a/lib/Dancer/Route/Registry.pm b/lib/Dancer/Route/Registry.pm index 36a4f459d..15c320e02 100644 --- a/lib/Dancer/Route/Registry.pm +++ b/lib/Dancer/Route/Registry.pm @@ -5,6 +5,7 @@ use Carp; use Dancer::Route; use base 'Dancer::Object'; use Dancer::Logger; +use Dancer::Exception qw(:all); Dancer::Route::Registry->attributes(qw( id )); @@ -98,7 +99,7 @@ sub any_add { $pattern = shift @rest; } - croak "Syntax error, methods should be provided as an ARRAY ref" + raise core_route => "Syntax error, methods should be provided as an ARRAY ref" if grep {$_ eq $pattern} @methods; $self->universal_add($_, $pattern, @rest) for @methods; diff --git a/lib/Dancer/Serializer.pm b/lib/Dancer/Serializer.pm index c63a0d9d5..4d0bf90a3 100644 --- a/lib/Dancer/Serializer.pm +++ b/lib/Dancer/Serializer.pm @@ -77,7 +77,8 @@ sub process_request { return $request unless engine->support_content_type($request->content_type); - return $request unless $request->is_put || $request->is_post; + return $request + unless $request->is_put || $request->is_post || $request->is_patch; my $old_params = $request->params('body'); diff --git a/lib/Dancer/Serializer/Dumper.pm b/lib/Dancer/Serializer/Dumper.pm index 108ca7d22..d09dd07b8 100644 --- a/lib/Dancer/Serializer/Dumper.pm +++ b/lib/Dancer/Serializer/Dumper.pm @@ -5,6 +5,7 @@ use warnings; use Carp; use base 'Dancer::Serializer::Abstract'; use Data::Dumper; +use Dancer::Exception qw(:all); sub from_dumper { my ($string) = @_; @@ -29,7 +30,7 @@ sub serialize { sub deserialize { my ($self, $content) = @_; my $res = eval "my \$VAR1; $content"; - croak "unable to deserialize : $@" if $@; + raise core_serializer => "unable to deserialize : $@" if $@; return $res; } diff --git a/lib/Dancer/Serializer/JSON.pm b/lib/Dancer/Serializer/JSON.pm index 26e3039fe..25fce478f 100644 --- a/lib/Dancer/Serializer/JSON.pm +++ b/lib/Dancer/Serializer/JSON.pm @@ -6,6 +6,7 @@ use Carp; use Dancer::ModuleLoader; use Dancer::Deprecation; use Dancer::Config 'setting'; +use Dancer::Exception qw(:all); use base 'Dancer::Serializer::Abstract'; @@ -27,7 +28,7 @@ sub loaded { Dancer::ModuleLoader->load('JSON') } sub init { my ($self) = @_; - croak 'JSON is needed and is not installed' + raise core_serializer => 'JSON is needed and is not installed' unless $self->loaded; } diff --git a/lib/Dancer/Serializer/YAML.pm b/lib/Dancer/Serializer/YAML.pm index 80c89c1e1..ae38b3d06 100644 --- a/lib/Dancer/Serializer/YAML.pm +++ b/lib/Dancer/Serializer/YAML.pm @@ -4,6 +4,7 @@ use strict; use warnings; use Carp; use Dancer::ModuleLoader; +use Dancer::Exception qw(:all); use base 'Dancer::Serializer::Abstract'; # helpers @@ -26,7 +27,7 @@ sub loaded { Dancer::ModuleLoader->load('YAML') } sub init { my ($self) = @_; - croak 'YAML is needed and is not installed' + raise core_serializer => 'YAML is needed and is not installed' unless $self->loaded; } diff --git a/lib/Dancer/Session/YAML.pm b/lib/Dancer/Session/YAML.pm index bd4b71000..4044367bc 100644 --- a/lib/Dancer/Session/YAML.pm +++ b/lib/Dancer/Session/YAML.pm @@ -10,6 +10,7 @@ use Dancer::Logger; use Dancer::ModuleLoader; use Dancer::Config 'setting'; use Dancer::FileUtils qw(path set_file_mode); +use Dancer::Exception qw(:all); # static @@ -20,7 +21,7 @@ sub init { $self->SUPER::init(@_); if (!keys %session_dir_initialized) { - croak "YAML is needed and is not installed" + raise core_session => "YAML is needed and is not installed" unless Dancer::ModuleLoader->load('YAML'); } @@ -34,7 +35,7 @@ sub init { # make sure session_dir exists if (!-d $session_dir) { mkdir $session_dir - or croak "session_dir $session_dir cannot be created"; + or raise core_session => "session_dir $session_dir cannot be created"; } Dancer::Logger::core("session_dir : $session_dir"); } diff --git a/lib/Dancer/Template/Simple.pm b/lib/Dancer/Template/Simple.pm index bba81a901..8233db000 100644 --- a/lib/Dancer/Template/Simple.pm +++ b/lib/Dancer/Template/Simple.pm @@ -6,6 +6,7 @@ use Carp; use base 'Dancer::Template::Abstract'; Dancer::Template::Simple->attributes('start_tag', 'stop_tag'); use Dancer::FileUtils 'read_file_content'; +use Dancer::Exception qw(:all); sub init { my $self = shift; @@ -106,10 +107,10 @@ sub _read_content_from_template { $content = $$template; } else { - croak "'$template' is not a regular file" + raise core_template => "'$template' is not a regular file" unless -f $template; $content = read_file_content($template); - croak "unable to read content for file $template" + raise core_template => "unable to read content for file $template" if not defined $content; } return $content; diff --git a/lib/Dancer/Template/TemplateToolkit.pm b/lib/Dancer/Template/TemplateToolkit.pm index 87bc0364d..d33afde0c 100644 --- a/lib/Dancer/Template/TemplateToolkit.pm +++ b/lib/Dancer/Template/TemplateToolkit.pm @@ -5,6 +5,7 @@ use warnings; use Carp; use Dancer::Config 'setting'; use Dancer::ModuleLoader; +use Dancer::Exception qw(:all); use base 'Dancer::Template::Abstract'; @@ -14,7 +15,7 @@ sub init { my ($self) = @_; my $class = $self->config->{subclass} || "Template"; - croak "$class is needed by Dancer::Template::TemplateToolkit" + raise core_template => "$class is needed by Dancer::Template::TemplateToolkit" if !$class->can("process") and !Dancer::ModuleLoader->load($class); my $charset = setting('charset') || ''; @@ -47,13 +48,13 @@ sub render { my ($self, $template, $tokens) = @_; if ( ! ref $template ) { - -f $template or croak "'$template' doesn't exist or not a regular file"; + -f $template or raise core_template => "'$template' doesn't exist or not a regular file"; } my $content = ""; my $charset = setting('charset') || ''; my @options = length($charset) ? ( binmode => ":encoding($charset)" ) : (); - $_engine->process($template, $tokens, \$content, @options) or croak $_engine->error; + $_engine->process($template, $tokens, \$content, @options) or raise core_template => $_engine->error; return $content; } diff --git a/lib/Dancer/Test.pm b/lib/Dancer/Test.pm index 8be2cdaa2..0095bfaa5 100644 --- a/lib/Dancer/Test.pm +++ b/lib/Dancer/Test.pm @@ -13,6 +13,7 @@ use Dancer ':syntax', ':tests'; use Dancer::App; use Dancer::Deprecation; use Dancer::Request; +use Dancer::Request::Upload; use Dancer::SharedData; use Dancer::Renderer; use Dancer::Handler; @@ -311,9 +312,13 @@ Content-Disposition: form-data; name="$file->{name}"; filename="$file->{filename Content-Type: text/plain }; - open my $fh, '<', $file->{filename}; - while (<$fh>){ - $content .= $_; + if ( $file->{data} ) { + $content .= $file->{data}; + } else { + open my $fh, '<', $file->{filename}; + while (<$fh>) { + $content .= $_; + } } $content .= "\n"; } @@ -548,7 +553,11 @@ Only $method and $path are required. $params is a hashref, $body is a string and $headers can be an arrayref or a HTTP::Headers object, $files is an arrayref of hashref, containing some files to upload. -A good reason to use this function is for testing POST requests. Since POST requests may not be idempotent, it is necessary to capture the content and status in one shot. Calling the response_status_is and response_content_is functions in succession would make two requests, each of which could alter the state of the application and cause Schrodinger's cat to die. +A good reason to use this function is for testing POST requests. Since POST +requests may not be idempotent, it is necessary to capture the content and +status in one shot. Calling the response_status_is and response_content_is +functions in succession would make two requests, each of which could alter the +state of the application and cause Schrodinger's cat to die. my $response = dancer_response POST => '/widgets'; is $response->{status}, 202, "response for POST /widgets is 202"; @@ -564,7 +573,14 @@ It's possible to test file uploads: post '/upload' => sub { return upload('image')->content }; - $response = dancer_reponse(POST => '/upload', {files => [{name => 'image', filename => '/path/to/image.jpg}]}); + $response = dancer_reponse(POST => '/upload', {files => [{name => 'image', filename => '/path/to/image.jpg'}]}); + +In addition, you can supply the file contents as the C key: + + my $data = 'A test string that will pretend to be file contents.'; + $response = dancer_reponse(POST => '/upload', { + files => [{name => 'test', filename => "filename.ext", data => $data}] + }); =head2 read_logs diff --git a/t/01_config/06_stack_trace.t b/t/01_config/06_stack_trace.t index 5521fbb81..c0c162638 100644 --- a/t/01_config/06_stack_trace.t +++ b/t/01_config/06_stack_trace.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 16, import => ['!pass']; +use Test::More tests => 18, import => ['!pass']; use Dancer ':syntax'; use Dancer::Template::TemplateToolkit; @@ -9,21 +9,21 @@ use Dancer::Template::TemplateToolkit; # scoping for $Carp::Verbose localization { - # first of all, test without verbose Carp - local $Carp::Verbose = 0; + # first of all, test without verbose Exceptions + local $Dancer::Exception::Verbose = 0; eval { Dancer::Template::TemplateToolkit->render('/not/a/valid/file'); }; my @error_lines = split(/\n/, $@); is(scalar(@error_lines), 1, "test non verbose croak"); - like($error_lines[0], qr!^'/not/a/valid/file' doesn\'t exist or not a regular file at!, "test non verbose croak"); + like($error_lines[0], qr!^core - template - '/not/a/valid/file' doesn\'t exist or not a regular file at!, "test non verbose croak"); } { - # same with verbose Carp - local $Carp::Verbose = 1; + # same with verbose Exceptions + local $Dancer::Exception::Verbose = 1; eval { Dancer::Template::TemplateToolkit->render('/not/a/valid/file'); }; my @error_lines = split(/\n/, $@); is(scalar(@error_lines), 3, "test verbose croak"); - like($error_lines[0], qr!^'/not/a/valid/file' doesn\'t exist or not a regular file at!, "test verbose croak"); + like($error_lines[0], qr!^core - template - '/not/a/valid/file' doesn\'t exist or not a regular file at!, "test verbose croak"); like($error_lines[1], qr!^\s*Dancer::Template::TemplateToolkit::render\('Dancer::Template::TemplateToolkit', '/not/a/valid/file'\) called at!, "test verbose croak stack trace"); like($error_lines[2], qr!^\s*eval {...} called at (?:[.]/)?t/01_config/06_stack_trace.t!, "test verbose croak stack trace"); } @@ -32,20 +32,22 @@ use Dancer::Template::TemplateToolkit; # test that default Dancer traces setting is no verbose is(setting('traces'), 0, "default 'traces' option set to 0"); is($Carp::Verbose, 0, "default Carp verbose is 0"); + is($Dancer::Exception::Verbose, 0, "default Dancer Exception verbose is 0"); eval { Dancer::Template::TemplateToolkit->render('/not/a/valid/file'); }; my @error_lines = split(/\n/, $@); is(scalar(@error_lines), 1, "test non verbose croak 2"); - like($error_lines[0], qr!^'/not/a/valid/file' doesn\'t exist or not a regular file at!, "test non verbose croak 2"); + like($error_lines[0], qr!^core - template - '/not/a/valid/file' doesn\'t exist or not a regular file at!, "test non verbose croak 2"); } { # test setting traces to 1 ok(setting(traces => 1), 'can set traces'); - is($Carp::Verbose, 1, "new Carp verbose is 1"); + is($Carp::Verbose, 0, "new Carp verbose is 1"); + is($Dancer::Exception::Verbose, 1, "default Dancer Exception verbose is 1"); eval { Dancer::Template::TemplateToolkit->render('/not/a/valid/file'); }; my @error_lines = split(/\n/, $@); is(scalar(@error_lines), 3, "test verbose croak"); - like($error_lines[0], qr!^'/not/a/valid/file' doesn\'t exist or not a regular file at!, "test verbose croak"); + like($error_lines[0], qr!^core - template - '/not/a/valid/file' doesn\'t exist or not a regular file at!, "test verbose croak"); like($error_lines[1], qr!^\s*Dancer::Template::TemplateToolkit::render\('Dancer::Template::TemplateToolkit', '/not/a/valid/file'\) called at!, "test verbose croak stack trace"); like($error_lines[2], qr!^\s*eval {...} called at (?:[.]/)?t/01_config/06_stack_trace.t!, "test verbose croak stack trace"); } diff --git a/t/03_route_handler/03_routes_api.t b/t/03_route_handler/03_routes_api.t index 748f3fae4..68a35911f 100644 --- a/t/03_route_handler/03_routes_api.t +++ b/t/03_route_handler/03_routes_api.t @@ -29,7 +29,9 @@ is $response->{content} => 42, "response looks good"; my $r2 = Dancer::Route->new(method => 'get', pattern => '/pass/:var', - code => sub { pass && "this is r2" }, + code => sub { pass; + # The next line is not executed, as 'pass' breaks the route workflow + die }, prev => $r); my $r3 = Dancer::Route->new(method => 'get', diff --git a/t/03_route_handler/15_prefix.t b/t/03_route_handler/15_prefix.t index 0520187c8..70c6dd0b7 100644 --- a/t/03_route_handler/15_prefix.t +++ b/t/03_route_handler/15_prefix.t @@ -20,10 +20,14 @@ my @tests = ( { path => '/dura/us', expected => 'us worked' }, ); -plan tests => 1 + 2*@tests; +plan tests => 4 + 2*@tests; eval { prefix 'say' }; -like $@ => qr/not a valid prefix/, 'prefix must start with a /'; +my $e = $@; +like $e => qr/not a valid prefix/, 'prefix must start with a /'; +ok $e->isa('Dancer::Exception::Base'), 'exception is a Dancer exception'; +ok $e->does('Core'), 'exception is a Core one'; +ok $e->does('Core::App'), 'exception is a Acore::App one'; { prefix '/say' => 'prefix defined'; diff --git a/t/03_route_handler/34_forward_body_post.t b/t/03_route_handler/34_forward_body_post.t index 8a4670d0d..dad2a399e 100644 --- a/t/03_route_handler/34_forward_body_post.t +++ b/t/03_route_handler/34_forward_body_post.t @@ -34,7 +34,10 @@ Test::TCP::test_tcp( server => sub { my $port = shift; Dancer::Config->load; - post '/foo' => sub { forward '/bar'; }; + post '/foo' => sub { + forward '/bar'; + fail "This line should not be executed - forward should have aborted the route execution"; + }; post '/bar' => sub { join(":",params) }; post '/foz' => sub { forward '/baz'; }; diff --git a/t/06_helpers/01_send_file.t b/t/06_helpers/01_send_file.t index 25567cb44..4105d2106 100644 --- a/t/06_helpers/01_send_file.t +++ b/t/06_helpers/01_send_file.t @@ -8,10 +8,12 @@ use Dancer::Test; set public => path(dirname(__FILE__), 'public'); -plan tests => 20; +plan tests => 21; get '/cat/:file' => sub { send_file(params->{file}); + # The next line is not executed, as 'send_error' breaks the route workflow + die; }; get '/catheader/:file' => sub { @@ -32,6 +34,10 @@ get '/absolute/:file' => sub { send_file(path(dirname(__FILE__), "routes.pl"), system_path => 1); }; +get '/absolute/content_type/:file' => sub { + send_file(path(dirname(__FILE__), "routes.pl"), system_path => 1, content_type => 'text/plain'); +}; + get '/custom_status' => sub { status 'not_found'; send_file('file.txt'); @@ -71,6 +77,10 @@ is(ref($resp->{content}), 'GLOB', "content is a File handle"); $content = read_glob_content($resp->{content}); like($content, qr/'foo loaded'/, "content is ok"); +$resp = undef; # just to be sure +$resp = dancer_response(GET => '/absolute/content_type/file.txt'); +%headers = @{$resp->headers_to_array}; +is($headers{'Content-Type'}, 'text/plain', 'mime_type is ok'); $resp = undef; # just to be sure $resp = dancer_response(GET => '/scalar/file'); diff --git a/t/06_helpers/05_send_error.t b/t/06_helpers/05_send_error.t index e793bca2b..4c167e2f3 100644 --- a/t/06_helpers/05_send_error.t +++ b/t/06_helpers/05_send_error.t @@ -7,6 +7,8 @@ set show_errors => 1; get '/error' => sub { send_error "FAIL"; + # The next line is not executed, as 'send_error' breaks the route workflow + die; }; response_status_is [GET => '/error'] => 500, diff --git a/t/07_apphandlers/04_standalone_app.t b/t/07_apphandlers/04_standalone_app.t index b906e044e..299510f96 100644 --- a/t/07_apphandlers/04_standalone_app.t +++ b/t/07_apphandlers/04_standalone_app.t @@ -11,7 +11,7 @@ plan skip_all => "Test::TCP is needed for this test" use LWP::UserAgent; -plan tests => 4; +plan tests => 6; Test::TCP::test_tcp( client => sub { @@ -29,6 +29,13 @@ Test::TCP::test_tcp( $res = $ua->post("http://127.0.0.1:$port/name", { name => "xxx" }); like $res->content, qr/Your name: xxx/, 'name is found on a POST'; + + # we are already skipping under MSWin32 (check plan above) + $res = $ua->get("http://127.0.0.1:$port/issues/499/true"); + is $res->content, "OK"; + + $res = $ua->get("http://127.0.0.1:$port/issues/499/false"); + is $res->content, "OK"; }, server => sub { my $port = shift; diff --git a/t/17_apps/02_load_app.t b/t/17_apps/02_load_app.t index 470ac5ad8..e1cabefb7 100644 --- a/t/17_apps/02_load_app.t +++ b/t/17_apps/02_load_app.t @@ -29,8 +29,8 @@ ok defined($forum), "app 'Forum' is defined"; is @{ $main->registry->routes->{'get'} }, 1, "one route is defined in main app"; -is @{ $test_app->registry->routes->{'get'} }, 13, - "13 routes are defined in test app"; +is @{ $test_app->registry->routes->{'get'} }, 15, + "15 routes are defined in test app"; is @{ $forum->registry->routes->{'get'} }, 5, "5 routes are defined in forum app"; diff --git a/t/23_dancer_tests/02_tests_functions.t b/t/23_dancer_tests/02_tests_functions.t index 663c3c5b6..7f1ceb096 100644 --- a/t/23_dancer_tests/02_tests_functions.t +++ b/t/23_dancer_tests/02_tests_functions.t @@ -3,7 +3,7 @@ use warnings; use Test::More; -plan tests => 28; +plan tests => 29; use Dancer qw/ :syntax :tests /; use Dancer::Test; @@ -43,6 +43,10 @@ get '/query' => sub { return join(":",params('query')); }; +post '/upload' => sub { + return upload('payload')->content; +}; + my $resp = dancer_response GET => '/marco'; my @req = ( [ GET => $route ], $route, $resp ); @@ -88,3 +92,11 @@ is_deeply $r->{content}, { user => { id => 2, name => "Franck Cuny" } }, $r = dancer_response( GET => '/query', { params => {foo => 'bar'}}); is $r->{content} => "foo:bar"; + +my $data = "She sells sea shells by the sea shore"; +$r = dancer_response( + POST => '/upload', + { files => [{name => 'payload', filename =>'test.txt', data => $data }] } +); +is $r->{content}, $data, "file data uploaded"; + diff --git a/t/25_exceptions/01_exceptions.t b/t/25_exceptions/01_exceptions.t index c30417dcf..e2b407890 100644 --- a/t/25_exceptions/01_exceptions.t +++ b/t/25_exceptions/01_exceptions.t @@ -8,6 +8,40 @@ use Dancer::Test; BEGIN { use_ok('Dancer::Exception', ':all'); } set views => path( 't', '25_exceptions', 'views' ); + +{ + # halt in route + my $v = 0; + get '/halt_in_route' => sub { + halt ({ error => 'plop' }); + $v = 1; + }; + response_content_like( [ GET => '/halt_in_route' ], qr|Unable to process your query| ); + response_status_is( [ GET => '/halt_in_route' ], 500 => "We get a 500 status" ); + is ($v, 0, 'halt broke the workflow as intended'); +} + +{ + # halt in hook + my $flag = 0; + my $v = 0; + hook before_template_render => sub { + if ( 0 || ! $flag++ ) { + status 500; + halt ({ error => 'plop2' }); + $v = 1; + } + }; + + get '/halt_in_hook' => sub { + template 'index'; + }; + response_content_like( [ GET => '/halt_in_hook' ], qr|Unable to process your query| ); + is ($v, 0, 'halt broke the workflow as intended'); + $flag = 0; + response_status_is( [ GET => '/halt_in_hook' ], 500 => "We get a 500 status" ); +} + set error_template => "error.tt"; { @@ -16,22 +50,42 @@ set error_template => "error.tt"; die "die in route"; }; - route_exists [ GET => '/die_in_route' ]; response_content_like( [ GET => '/die_in_route' ], qr|MESSAGE:

runtime error

die in route| );
-    response_content_like( [ GET => '/die_in_route' ], qr|EXCEPTION: $| );
+    response_content_like( [ GET => '/die_in_route' ], qr|EXCEPTION: die in route| );
     response_status_is( [ GET => '/die_in_route' ], 500 => "We get a 500 status" );
 }
 
+register_exception ('Test',
+                    message_pattern => "test - %s",
+                   );
+
 {
+    my $route_hook_executed = 0;
+    my $handler_hook_executed = 0;
+
     # raise in route
     get '/raise_in_route' => sub {
-        raise E_GENERIC;
+        raise Test => 'plop';
+    };
+
+    hook on_route_exception => sub {
+        my ($exception) = @_;
+        $exception->isa('Dancer::Exception::Test');
+        $route_hook_executed++;
     };
-    route_exists [ GET => '/raise_in_route' ];
+
+    hook on_handler_exception => sub {
+        my ($exception) = @_;
+        $exception->isa('Dancer::Exception::Test');
+        $handler_hook_executed++;
+    };
+
     response_content_like( [ GET => '/raise_in_route' ], qr|MESSAGE: 
runtime error
| );
-    my $e = E_GENERIC;
+    my $e = "test - plop";
     response_content_like( [ GET => '/raise_in_route' ], qr|EXCEPTION: $e| );
     response_status_is( [ GET => '/raise_in_route' ], 500 => "We get a 500 status" );
+    is($route_hook_executed, 3,"exception route hook has been called");
+    is($handler_hook_executed, 3,"exception handler hook has been called");
 }
 
 {
@@ -44,21 +98,24 @@ set error_template => "error.tt";
     get '/die_in_hook' => sub {
         template 'index', { foo => 'baz' };
     };
-    route_exists [ GET => '/die_in_hook' ];
     $flag = 0;
     response_content_like( [ GET => '/die_in_hook' ], qr|MESSAGE: 
runtime error
| );
     $flag = 0;
-    response_content_like( [ GET => '/die_in_hook' ], qr|EXCEPTION: $| );
+    response_content_like( [ GET => '/die_in_hook' ], qr|EXCEPTION: die in hook| );
     $flag = 0;
     response_status_is( [ GET => '/die_in_hook' ], 500 => "We get a 500 status" );
 }
 
+register_exception ('Generic',
+                    message_pattern => "test message : %s",
+                   );
+
 {
     # raise in hook
     my $flag = 0;
     hook before_template_render => sub {
         $flag++
-          or raise E_GENERIC;
+          or raise Generic => 'foo';
     };
     get '/raise_in_hook' => sub {
         template 'index', { foo => 'baz' };
@@ -67,49 +124,9 @@ set error_template => "error.tt";
     $flag = 0;
     response_content_like( [ GET => '/raise_in_hook' ], qr|MESSAGE: 
runtime error
| );
     $flag = 0;
-    my $e = E_GENERIC;
-    response_content_like( [ GET => '/raise_in_hook' ], qr|EXCEPTION: $e| );
+    response_content_like( [ GET => '/raise_in_hook' ], qr|EXCEPTION: test message : foo| );
     $flag = 0;
     response_status_is( [ GET => '/raise_in_hook' ], 500 => "We get a 500 status" );
 }
 
-{
-    # register new custom exception
-    register_custom_exception('E_MY_EXCEPTION');
-    ok(E_MY_EXCEPTION(), 'exception registered and imported');
-}
-
-{
-    # register new custom exception but don't import it
-    register_custom_exception('E_MY_EXCEPTION2', no_import => 1);
-
-    eval { E_MY_EXCEPTION2() };
-    like( $@, qr/Undefined subroutine/, "exception were not imported");
-
-    # now reuse Dancer::Exception;
-    eval "use Dancer::Exception qw(:all)";
-
-    ok(E_MY_EXCEPTION2(), "exception is now imported");
-
-    eval { raise E_MY_EXCEPTION2() };
-    ok(my $value = is_dancer_exception($@), "custom exception is properly caught");
-    is($value, E_MY_EXCEPTION2(), "custom exception has the proper value");
-}
-
-{
-    # list of exceptions
-    is_deeply( [sort { $a cmp $b } list_exceptions()],
-               [ qw(E_GENERIC E_HALTED E_MY_EXCEPTION E_MY_EXCEPTION2) ],
-               'listing all exceptions',
-             );
-    is_deeply( [sort { $a cmp $b } list_exceptions(type => 'internal')],
-               [ qw(E_GENERIC E_HALTED) ],
-               'listing internal exceptions',
-             );
-    is_deeply([sort { $a cmp $b } list_exceptions(type => 'custom')],
-              [ qw(E_MY_EXCEPTION E_MY_EXCEPTION2) ],
-               'listing custom exceptions',
-             );
-}
-
 done_testing();
diff --git a/t/25_exceptions/02_exceptions.t b/t/25_exceptions/02_exceptions.t
new file mode 100644
index 000000000..2f57184a9
--- /dev/null
+++ b/t/25_exceptions/02_exceptions.t
@@ -0,0 +1,141 @@
+use strict;
+use warnings;
+use Test::More import => ['!pass'];
+
+use Dancer::Exception qw(:all);
+
+ok(1, "load ok");
+
+# test try/catch/continuation
+
+{
+    my $v1 = 0;
+    eval { try { $v1 = 1 }; };
+    ok(! $@);
+    is($v1, 1);
+}
+
+{
+    my $v1 = 0;
+    eval { try { $v1 = 1 } catch { $v1 = 2; }; };
+    ok(! $@);
+    is($v1, 1);
+}
+
+{
+    my $v1 = 0;
+    eval { try { $v1 = 1; die "plop"; } catch { $v1 = 2; }; };
+    ok(! $@);
+    is($v1, 2);
+}
+
+{
+    my $v1 = 0;
+    eval { try { $v1 = 1; die bless {}, 'Dancer::Continuation'; } catch { $v1 = 2; }; };
+    my $e = $@;
+    ok(defined $e);
+    is($v1, 1);
+    ok($e->isa('Dancer::Continuation'));
+}
+
+{
+    my $v1 = 0;
+    eval { try { $v1 = 1; die bless {}, 'Dancer::Continuation'; } catch { $v1 = 2; } continuation { $v1 = 3; }; };
+    ok(! $@);
+    is($v1, 3);
+}
+
+{
+    my $v1 = 0;
+    eval { try { $v1 = 1; die bless {}, 'Dancer::Continuation'; } continuation { $v1 = 3; } catch { $v1 = 2; }; };
+    ok(! $@);
+    is($v1, 3);
+}
+
+{
+    my $v1 = 0;
+    eval { try { $v1 = 1; die bless {}, 'plop'; } continuation { $v1 = 3; } catch { $v1 = 2; }; };
+    ok(! $@);
+    is($v1, 2);
+}
+
+{
+    my $v1 = 0;
+    eval { try { $v1 = 1; die "plop"; } continuation { $v1 = 3; } catch { $v1 = 2; }; };
+    ok(! $@);
+    is($v1, 2);
+}
+
+{
+    my $registered = [ registered_exceptions ];
+    is_deeply($registered,
+[ qw(
+Base Core Core::App Core::Config Core::Deprecation Core::Engine Core::Factory
+Core::Factory::Hook Core::Fileutils Core::Handler Core::Handler::PSGI
+Core::Hook Core::Plugin Core::Renderer Core::Route Core::Serializer
+Core::Session Core::Template
+)
+]);
+
+}
+
+register_exception ('Test',
+                    message_pattern => "test - %s",
+                   );
+
+register_exception ('InvalidCredentials',
+                    message_pattern => "invalid credentials : %s",
+                   );
+
+register_exception ('InvalidPassword',
+                    composed_from => [qw(Test InvalidCredentials)],
+                    message_pattern => "wrong password",
+                   );
+
+register_exception ('InvalidLogin',
+                    composed_from => [qw(Test InvalidCredentials)],
+                    message_pattern => "wrong login (login was %s)",
+                   );
+
+register_exception ('HarmlessInvalidLogin',
+                    composed_from => [qw(InvalidLogin)],
+                    message_pattern => "ignored invalid login",
+                   );
+
+{
+    my $registered = [ registered_exceptions ];
+    is_deeply($registered, [
+        qw(
+Base Core Core::App Core::Config Core::Deprecation Core::Engine Core::Factory
+Core::Factory::Hook Core::Fileutils Core::Handler Core::Handler::PSGI
+Core::Hook Core::Plugin Core::Renderer Core::Route Core::Serializer
+Core::Session Core::Template
+HarmlessInvalidLogin InvalidCredentials InvalidLogin InvalidPassword Test
+)
+    ]);
+}
+
+{
+    my $v1 = 0;
+    my $e;
+    eval {
+        try {
+            $v1 = 1;
+            raise InvalidLogin => 'douglas'
+        } continuation {
+            $v1 = 3;
+        } catch {
+            $e = shift;
+            $v1 = 2;
+        };
+    };
+    ok(! $@);
+    is($e, 'test - invalid credentials : wrong login (login was douglas)');
+    # check stringification works in other cases
+    ok($e eq 'test - invalid credentials : wrong login (login was douglas)');
+    ok('test - invalid credentials : wrong login (login was douglas)' eq $e);
+    ok($e->does('InvalidLogin'));
+    is($v1, 2);
+}
+
+done_testing;
diff --git a/t/lib/TestApp.pm b/t/lib/TestApp.pm
index 359836bdf..9cf1e4fbf 100644
--- a/t/lib/TestApp.pm
+++ b/t/lib/TestApp.pm
@@ -75,4 +75,12 @@ get '/forward_to_unavailable_route' => sub {
     forward "/some_route_that_does_not_exist"
 };
 
+get '/issues/499/true' => sub {
+    "OK" if system('true') == 0  
+};
+
+get '/issues/499/false' => sub {
+    "OK" if system('false') != 0  
+};
+
 true;