[Catalyst-commits] r10806 - in trunk/misc/exception_test_case: .
lib t
t0m at dev.catalyst.perl.org
t0m at dev.catalyst.perl.org
Tue Jul 7 08:20:49 GMT 2009
Author: t0m
Date: 2009-07-07 08:20:48 +0000 (Tue, 07 Jul 2009)
New Revision: 10806
Added:
trunk/misc/exception_test_case/lib/
trunk/misc/exception_test_case/lib/AraExceptions.pm
trunk/misc/exception_test_case/lib/TestAppClassException.pm
trunk/misc/exception_test_case/t/
trunk/misc/exception_test_case/t/dead_test2_class_exception.t
Log:
Initial commit of currently needed code. Needs more stripping in a bit
Added: trunk/misc/exception_test_case/lib/AraExceptions.pm
===================================================================
--- trunk/misc/exception_test_case/lib/AraExceptions.pm (rev 0)
+++ trunk/misc/exception_test_case/lib/AraExceptions.pm 2009-07-07 08:20:48 UTC (rev 10806)
@@ -0,0 +1,224 @@
+package TestAppClassException::Exceptions;
+
+use strict;
+use warnings;
+
+BEGIN {
+ $Catalyst::Exception::CATALYST_EXCEPTION_CLASS = 'TestAppClassException::Exception';
+
+ my %classes = (
+ 'TestAppClassException::Exception' => {
+ description => 'Generic exception',
+ fields => [ qw( headers status status_message payload ) ],
+ alias => 'throw'
+ },
+ 'TestAppClassException::Exception::SeeOther'=> {
+ isa => 'TestAppClassException::Exception',
+ description => '303 - See Other',
+ },
+ 'TestAppClassException::Exception::BadRequest' => {
+ isa => 'TestAppClassException::Exception',
+ description => '400 - Bad request',
+ },
+ 'TestAppClassException::Exception::AccessDenied' => {
+ isa => 'TestAppClassException::Exception',
+ description => '401 - Access Denied',
+ },
+ 'TestAppClassException::Exception::InsufficientPermission' => {
+ isa => 'TestAppClassException::Exception',
+ description => '403 - Insufficient Permission',
+ },
+ 'TestAppClassException::Exception::FileNotFound' => {
+ isa => 'TestAppClassException::Exception',
+ description => '404 - File Not Found',
+ },
+ 'TestAppClassException::Exception::PreconditionFailed' => {
+ isa => 'TestAppClassException::Exception',
+ description => '412 - Precondition Failed',
+ },
+ );
+
+ 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 TestAppClassException::Exception;
+
+## thank to Brian
+## http://bricas.vox.com/library/post/catalyst-exceptionclass.html
+
+use strict;
+use warnings;
+no warnings 'redefine';
+
+use HTTP::Headers ();
+use HTTP::Status ();
+use Scalar::Util qw( blessed );
+#use parent 'Exception::Class';
+
+sub headers {
+ my $self = shift;
+ my $headers = $self->{headers};
+
+ unless ( defined $headers ) {
+ return undef;
+ }
+
+ if ( blessed $headers && $headers->isa('HTTP::Headers') ) {
+ return $headers;
+ }
+
+ if ( ref $headers eq 'ARRAY' ) {
+ return $self->{headers} = HTTP::Headers->new( @{ $headers } );
+ }
+
+ if ( ref $headers eq 'HASH' ) {
+ return $self->{headers} = HTTP::Headers->new( %{ $headers } );
+ }
+
+
+ AraException->throw(
+ message => qq(Can't coerce a '$headers' into a HTTP::Headers instance.)
+ );
+}
+
+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 {
+ $DB::single=1;
+ 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;
+ $DB::single=1;
+ 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;
+}
+
+
+package TestAppClassException::Exception::FileNotFound;
+
+sub status {
+ return $_[0]->{status} ||= 404;
+}
+
+package TestAppClassException::Exception::AccessDenied;
+
+sub status {
+ return $_[0]->{status} ||= 401;
+}
+
+package TestAppClassException::Exception::InsufficientPermission;
+
+sub status {
+ return $_[0]->{status} ||= 403;
+}
+
+package TestAppClassException::Exception::PreconditionFailed;
+
+sub status {
+ return $_[0]->{status} ||= 412;
+}
+
+package TestAppClassException::Exception::SeeOther;
+
+sub status {
+ return $_[0]->{status} ||= 303;
+}
+
+package TestAppClassException::Exception::BadRequest;
+
+sub status {
+ return $_[0]->{status} ||= 400;
+}
+
+
+1;
Added: trunk/misc/exception_test_case/lib/TestAppClassException.pm
===================================================================
--- trunk/misc/exception_test_case/lib/TestAppClassException.pm (rev 0)
+++ trunk/misc/exception_test_case/lib/TestAppClassException.pm 2009-07-07 08:20:48 UTC (rev 10806)
@@ -0,0 +1,343 @@
+package TestAppClassException::Exceptions;
+
+use strict;
+use warnings;
+
+BEGIN {
+ $Catalyst::Exception::CATALYST_EXCEPTION_CLASS = 'TestAppClassException::Exception';
+
+ my %classes = (
+ 'TestAppClassException::Exception' => {
+ description => 'Generic exception',
+ fields => [ qw( headers status status_message payload ) ],
+ alias => 'throw'
+ },
+ 'TestAppClassException::Exception::SeeOther'=> {
+ isa => 'TestAppClassException::Exception',
+ description => '303 - See Other',
+ },
+ 'TestAppClassException::Exception::BadRequest' => {
+ isa => 'TestAppClassException::Exception',
+ description => '400 - Bad request',
+ },
+ 'TestAppClassException::Exception::AccessDenied' => {
+ isa => 'TestAppClassException::Exception',
+ description => '401 - Access Denied',
+ },
+ 'TestAppClassException::Exception::InsufficientPermission' => {
+ isa => 'TestAppClassException::Exception',
+ description => '403 - Insufficient Permission',
+ },
+ 'TestAppClassException::Exception::FileNotFound' => {
+ isa => 'TestAppClassException::Exception',
+ description => '404 - File Not Found',
+ },
+ 'TestAppClassException::Exception::PreconditionFailed' => {
+ isa => 'TestAppClassException::Exception',
+ description => '412 - Precondition Failed',
+ },
+ );
+
+ 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 TestAppClassException::Exception;
+
+## thank to Brian
+## http://bricas.vox.com/library/post/catalyst-exceptionclass.html
+
+use strict;
+use warnings;
+no warnings 'redefine';
+
+use HTTP::Headers ();
+use HTTP::Status ();
+use Scalar::Util qw( blessed );
+#use parent 'Exception::Class';
+
+sub headers {
+ my $self = shift;
+ my $headers = $self->{headers};
+
+ unless ( defined $headers ) {
+ return undef;
+ }
+
+ if ( blessed $headers && $headers->isa('HTTP::Headers') ) {
+ return $headers;
+ }
+
+ if ( ref $headers eq 'ARRAY' ) {
+ return $self->{headers} = HTTP::Headers->new( @{ $headers } );
+ }
+
+ if ( ref $headers eq 'HASH' ) {
+ return $self->{headers} = HTTP::Headers->new( %{ $headers } );
+ }
+
+
+ AraException->throw(
+ message => qq(Can't coerce a '$headers' into a HTTP::Headers instance.)
+ );
+}
+
+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 {
+ $DB::single=1;
+ 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;
+ $DB::single=1;
+ 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;
+}
+
+
+package TestAppClassException::Exception::FileNotFound;
+
+sub status {
+ return $_[0]->{status} ||= 404;
+}
+
+package TestAppClassException::Exception::AccessDenied;
+
+sub status {
+ return $_[0]->{status} ||= 401;
+}
+
+package TestAppClassException::Exception::InsufficientPermission;
+
+sub status {
+ return $_[0]->{status} ||= 403;
+}
+
+package TestAppClassException::Exception::PreconditionFailed;
+
+sub status {
+ return $_[0]->{status} ||= 412;
+}
+
+package TestAppClassException::Exception::SeeOther;
+
+sub status {
+ return $_[0]->{status} ||= 303;
+}
+
+package TestAppClassException::Exception::BadRequest;
+
+sub status {
+ return $_[0]->{status} ||= 400;
+}
+
+#########
+
+package TestAppClassException;
+
+use strict;
+use warnings;
+
+
+use AraExceptions;
+
+use Scalar::Util ();
+use Catalyst::Runtime '5.80';
+
+use Catalyst qw/ -Debug StackTrace /;
+
+our $VERSION = '0.01_1';
+
+# Start the application
+__PACKAGE__->setup;
+
+=head1 NAME
+
+TestAppClassException - Catalyst based application
+
+=head1 SYNOPSIS
+
+ script/TestAppClassException_server.pl
+
+=head1 DESCRIPTION
+
+[enter your description here]
+
+=head1 SEE ALSO
+
+L<TestAppClassException::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
+
+sub finalize {
+ my ( $c ) = shift;
+ $DB::single=1;
+ $c->handle_exception if @{ $c->error };
+
+ $c->maybe::next::method( @_ );
+}
+
+sub handle_exception {
+ my( $c ) = @_;
+ my $error = $c->error->[ 0 ];
+
+ $c->log->debug("baseurl:" . $c->stash->{baseurl});
+ $DB::single=1;
+
+ if( ! Scalar::Util::blessed( $error ) or !$error->isa( 'TestAppClassException::Exception' ) ) {
+ $error = TestAppClassException::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' );
+ $c->response->body(
+ $c->view( 'TT' )->render( $c, 'error.tt2', { baseurl=> $c->stash->{baseurl}, error => $error, message=>$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;
+ TestAppClassException::Exception->throw( message => join '', @_ );
+};
+
+
+1;
Added: trunk/misc/exception_test_case/t/dead_test2_class_exception.t
===================================================================
--- trunk/misc/exception_test_case/t/dead_test2_class_exception.t (rev 0)
+++ trunk/misc/exception_test_case/t/dead_test2_class_exception.t 2009-07-07 08:20:48 UTC (rev 10806)
@@ -0,0 +1,15 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use FindBin qw/$Bin/;
+use lib "$Bin/lib";
+use Test::More tests => 1;
+use Test::Exception;
+
+lives_ok {
+ require TestAppClassException;
+} 'Can load application';
+
+1;
+
More information about the Catalyst-commits
mailing list