[Catalyst-commits] r11157 - in
trunk/misc/exception_test_new_case/lib: .
exception_test_new_case/Controller
t0m at dev.catalyst.perl.org
t0m at dev.catalyst.perl.org
Tue Aug 18 13:58:12 GMT 2009
Author: t0m
Date: 2009-08-18 13:58:11 +0000 (Tue, 18 Aug 2009)
New Revision: 11157
Modified:
trunk/misc/exception_test_new_case/lib/TestAppClassExceptionSimpleTest.pm
trunk/misc/exception_test_new_case/lib/exception_test_new_case.pm
trunk/misc/exception_test_new_case/lib/exception_test_new_case/Controller/Root.pm
Log:
Chop up to test we get what we expect
Modified: trunk/misc/exception_test_new_case/lib/TestAppClassExceptionSimpleTest.pm
===================================================================
--- trunk/misc/exception_test_new_case/lib/TestAppClassExceptionSimpleTest.pm 2009-08-18 12:39:37 UTC (rev 11156)
+++ trunk/misc/exception_test_new_case/lib/TestAppClassExceptionSimpleTest.pm 2009-08-18 13:58:11 UTC (rev 11157)
@@ -5,27 +5,6 @@
BEGIN {
$Catalyst::Exception::CATALYST_EXCEPTION_CLASS = 'exception_test_new_case::Exception';
-
- my %classes = (
- 'exception_test_new_case::Exception' => {
- description => 'Generic exception',
- fields => [ qw( headers status status_message payload ) ],
- alias => 'throw'
- },
- 'exception_test_new_case::Exception::AccessDenied' => {
- isa => 'exception_test_new_case::Exception',
- description => '401 - Access Denied',
- },
-
- );
-
- my @exports = grep { defined } map { $classes{ $_ }->{ alias } } keys %classes;
-
- require Exception::Class;
- require Sub::Exporter;
-
- Exception::Class->import(%classes);
- Sub::Exporter->import( -setup => { exports => \@exports } );
}
package exception_test_new_case::Exception;
@@ -37,111 +16,12 @@
use warnings;
no warnings 'redefine';
-use HTTP::Headers ();
-use HTTP::Status ();
-use Scalar::Util qw( blessed );
+sub throw { die bless({ message => shift}, __PACKAGE__) }
sub as_string {
- $DB::single=1;
- my $str = "Error status: " . $_[0]->{status} . " - " . $_[0]->{message};
- return $str;
+ "Error status: " . $_[0]->{message};
}
-sub status {
- return $_[0]->{status} ||= 500;
-}
-
-sub is_info {
- return HTTP::Status::is_info( $_[0]->status );
-}
-
-sub is_success {
- return HTTP::Status::is_success( $_[0]->status );
-}
-
-sub is_redirect {
- return HTTP::Status::is_redirect( $_[0]->status );
-}
-
-
-sub is_error {
- return HTTP::Status::is_error( $_[0]->status );
-}
-
-sub is_client_error {
- return HTTP::Status::is_client_error( $_[0]->status );
-}
-
-sub is_server_error {
- return HTTP::Status::is_server_error( $_[0]->status );
-}
-
-sub status_line {
- return sprintf "%s %s", $_[0]->status, $_[0]->status_message;
-}
-
-sub status_message {
- return $_[0]->{status_message} ||= HTTP::Status::status_message( $_[0]->status );
-}
-
-my %messages = (
- 400 => 'Browser sent a request that this server could not understand.',
- 401 => 'The requested resource requires user authentication.',
- 403 => 'Insufficient permission to access the requested resource on this server.',
- 404 => 'The requested resource was not found on this server.',
- 405 => 'The requested method is not allowed.',
- 500 => 'The server encountered an internal error or misconfiguration and was unable to complete the request.',
- 501 => 'The server does not support the functionality required to fulfill the request.',
-);
-
-sub public_message {
- return $messages{ $_[0]->status } || 'An error occurred.';
-}
-
-sub as_public_html {
- my $self = shift;
- my $title = shift || $self->status_line;
- my $header = shift || $self->status_message;
- my $message = shift || $self->public_message;
-
-return <<EOF;
-<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
-<html>
- <head>
- <title>$title</title>
- </head>
- <body>
- <h1>$header</h1>
- <p>$message</p>
- </body>
-</html>
-EOF
-
-}
-
-sub has_headers {
- return defined $_[0]->{headers} ? 1 : 0;
-}
-
-sub has_payload {
- return defined $_[0]->{payload} && length $_[0]->{payload} ? 1 : 0;
-}
-
-sub has_status_message {
- return defined $_[0]->{status_message} ? 1 : 0;
-}
-
-sub full_message {
- my $self = shift;
- my $message = $self->message;
-
- if ( $self->has_payload ) {
- $message .= sprintf " %s.", $self->payload;
- }
-
- return $message;
-}
-
sub message {
return $_[0]->{message} ||= 'you meet a server error';
}
Modified: trunk/misc/exception_test_new_case/lib/exception_test_new_case/Controller/Root.pm
===================================================================
--- trunk/misc/exception_test_new_case/lib/exception_test_new_case/Controller/Root.pm 2009-08-18 12:39:37 UTC (rev 11156)
+++ trunk/misc/exception_test_new_case/lib/exception_test_new_case/Controller/Root.pm 2009-08-18 13:58:11 UTC (rev 11157)
@@ -28,31 +28,25 @@
sub index :Path :Args(0) {
my ( $self, $c ) = @_;
-
- $DB::single=1;
- exception_test_new_case::Exception->throw({message=>'Error', status=>412});
-# Catalyst::Exception->throw({message=>'Error', status=>403});
-# exception_test_new_case::Exception->throw({message=>'Error', status=>412});
-# Catalyst::Exception->throw("Go bang");
-
- # Hello World
- $c->response->body( $c->welcome_message );
+ Catalyst::Exception->throw({message=>'Error', status=>403});
}
-sub default :Path {
- my ( $self, $c ) = @_;
- $c->response->body( 'Page not found' );
- $c->response->status(404);
-
-}
-
=head2 end
Attempt to render a view, if needed.
=cut
-sub end : ActionClass('RenderView') {}
+sub end : Private {
+ my ( $self, $c ) = @_;
+ if ($c->error) {
+ $c->res->body($c->error->[0]);
+ $c->clear_errors;
+ }
+ else {
+ $c->res->body('OK');
+ }
+}
=head1 AUTHOR
Modified: trunk/misc/exception_test_new_case/lib/exception_test_new_case.pm
===================================================================
--- trunk/misc/exception_test_new_case/lib/exception_test_new_case.pm 2009-08-18 12:39:37 UTC (rev 11156)
+++ trunk/misc/exception_test_new_case/lib/exception_test_new_case.pm 2009-08-18 13:58:11 UTC (rev 11157)
@@ -7,134 +7,15 @@
use Catalyst::Runtime '5.80';
-# Set flags and add plugins for the application
-#
-# -Debug: activates the debug mode for very useful log messages
-# ConfigLoader: will load the configuration from a Config::General file in the
-# application's home directory
-# Static::Simple: will serve static files from the application's root
-# directory
-
-use parent qw/Catalyst/;
+use base qw/Catalyst/;
use Catalyst qw/-Debug
- ConfigLoader
- Static::Simple/;
+ /;
our $VERSION = '0.01';
-# Configure the application.
-#
-# Note that settings in exception_test_new_case.conf (or other external
-# configuration file that you set up manually) take precedence
-# over this when using ConfigLoader. Thus configuration
-# details given here can function as a default configuration,
-# with a external configuration file acting as an override for
-# local deployment.
-
__PACKAGE__->config( name => 'exception_test_new_case' );
# Start the application
__PACKAGE__->setup();
-sub finalize {
- my ( $c ) = shift;
- $DB::single=1;
- $c->handle_exception if @{ $c->error };
- $DB::single=1;
- $c->maybe::next::method( @_ );
-}
-
-sub handle_exception {
- my( $c ) = @_;
- my $error = $c->error->[ 0 ];
-
- $DB::single=1;
-
- if( ! Scalar::Util::blessed( $error ) or !$error->isa( 'exception_test_new_case::Exception' ) ) {
- $error = exception_test_new_case::Exception->new( message => "$error" );
- }
-
- # handle debug-mode forced-debug from RenderView
- if( $c->debug && $error->message =~ m{^forced debug} ) {
- return;
- }
-
- $c->clear_errors;
-
- if ( $error->is_error ) {
- $c->response->headers->remove_content_headers;
- }
-
- if ( $error->has_headers ) {
- $c->response->headers->merge( $error->headers );
- }
-
- # log the error
- if ( $error->is_server_error ) {
- $c->log->error( $error->as_string );
- }
- elsif ( $error->is_client_error ) {
- $c->log->warn( $error->as_string ) if $error->status =~ /^40[034]$/;
- }
-
- if( $error->is_redirect ) {
- # recent Catalyst will give us a default body for redirects
-
- if( $error->can( 'uri' ) ) {
- $c->response->redirect( $error->uri( $c ) );
- }
-
- return;
- }
-
- $c->log->debug($error);
- $c->log->debug($error->as_public_html );
-
- $c->response->status( $error->status );
- $c->response->content_type( 'text/html; charset=utf-8' );
- $DB::single=1;
- $c->response->body(
- qq( This is the error: )
- . $error->as_public_html
- );
- # processing the error has bombed. just send it back plainly.
- $c->response->body( $error->as_public_html ) if $@;
-}
-
-$SIG{ __DIE__ } = sub {
- return if Scalar::Util::blessed( $_[ 0 ] );
- # don't inflate detachments
- return if $_[ 0 ] eq $Catalyst::DETACH;
- exception_test_new_case::Exception->throw( message => join '', @_ );
-};
-
-
-
-=head1 NAME
-
-exception_test_new_case - Catalyst based application
-
-=head1 SYNOPSIS
-
- script/exception_test_new_case_server.pl
-
-=head1 DESCRIPTION
-
-[enter your description here]
-
-=head1 SEE ALSO
-
-L<exception_test_new_case::Controller::Root>, L<Catalyst>
-
-=head1 AUTHOR
-
-Ferruccio Zamuner
-
-=head1 LICENSE
-
-This library is free software, you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-
1;
More information about the Catalyst-commits
mailing list