[Catalyst-commits] r11155 - in trunk/misc: . exception_test_new_case exception_test_new_case/lib exception_test_new_case/lib/exception_test_new_case exception_test_new_case/lib/exception_test_new_case/Controller exception_test_new_case/root exception_test_new_case/script exception_test_new_case/t

ferz at dev.catalyst.perl.org ferz at dev.catalyst.perl.org
Tue Aug 18 11:28:37 GMT 2009


Author: ferz
Date: 2009-08-18 11:28:35 +0000 (Tue, 18 Aug 2009)
New Revision: 11155

Added:
   trunk/misc/exception_test_new_case/
   trunk/misc/exception_test_new_case/Makefile.PL
   trunk/misc/exception_test_new_case/exception_test_new_case.conf
   trunk/misc/exception_test_new_case/lib/
   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/
   trunk/misc/exception_test_new_case/lib/exception_test_new_case/Controller/
   trunk/misc/exception_test_new_case/lib/exception_test_new_case/Controller/Root.pm
   trunk/misc/exception_test_new_case/root/
   trunk/misc/exception_test_new_case/root/favicon.ico
   trunk/misc/exception_test_new_case/script/
   trunk/misc/exception_test_new_case/script/exception_test_new_case_server.pl
   trunk/misc/exception_test_new_case/script/exception_test_new_case_test.pl
   trunk/misc/exception_test_new_case/t/
   trunk/misc/exception_test_new_case/t/01app.t
Removed:
   trunk/misc/exception_test_case/
Log:
remove exception_test_case to start a cleaner exception_test_new_case.


Added: trunk/misc/exception_test_new_case/Makefile.PL
===================================================================
--- trunk/misc/exception_test_new_case/Makefile.PL	                        (rev 0)
+++ trunk/misc/exception_test_new_case/Makefile.PL	2009-08-18 11:28:35 UTC (rev 11155)
@@ -0,0 +1,20 @@
+# IMPORTANT: if you delete this file your app will not work as
+# expected.  you have been warned
+use inc::Module::Install;
+
+name 'exception_test_new_case';
+all_from 'lib/exception_test_new_case.pm';
+
+requires 'Catalyst::Runtime' => '5.80007';
+requires 'Catalyst::Plugin::ConfigLoader';
+requires 'Catalyst::Plugin::Static::Simple';
+requires 'Catalyst::Action::RenderView';
+requires 'parent';
+requires 'Config::General'; # This should reflect the config file format you've chosen
+                 # See Catalyst::Plugin::ConfigLoader for supported formats
+requires 'Exception::Class';
+catalyst;
+
+install_script glob('script/*.pl');
+auto_install;
+WriteAll;

Added: trunk/misc/exception_test_new_case/exception_test_new_case.conf
===================================================================
--- trunk/misc/exception_test_new_case/exception_test_new_case.conf	                        (rev 0)
+++ trunk/misc/exception_test_new_case/exception_test_new_case.conf	2009-08-18 11:28:35 UTC (rev 11155)
@@ -0,0 +1,3 @@
+# rename this file to exception_test_new_case.yml and put a : in front of "name" if
+# you want to use yaml like in old versions of Catalyst
+name exception_test_new_case

Added: trunk/misc/exception_test_new_case/lib/TestAppClassExceptionSimpleTest.pm
===================================================================
--- trunk/misc/exception_test_new_case/lib/TestAppClassExceptionSimpleTest.pm	                        (rev 0)
+++ trunk/misc/exception_test_new_case/lib/TestAppClassExceptionSimpleTest.pm	2009-08-18 11:28:35 UTC (rev 11155)
@@ -0,0 +1,169 @@
+package exception_test_new_case::Exceptions;
+
+use strict;
+use warnings;
+
+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;
+
+## 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 );
+
+sub as_string {
+    $DB::single=1;
+    my $str = "Error status: " . $_[0]->{status} . " - " . $_[0]->{message};
+    return $str;
+}
+
+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';
+}
+
+
+=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
+
+1;

Added: 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	                        (rev 0)
+++ trunk/misc/exception_test_new_case/lib/exception_test_new_case/Controller/Root.pm	2009-08-18 11:28:35 UTC (rev 11155)
@@ -0,0 +1,68 @@
+package exception_test_new_case::Controller::Root;
+
+use strict;
+use warnings;
+use parent 'Catalyst::Controller';
+
+#
+# Sets the actions in this controller to be registered with no prefix
+# so they function identically to actions created in MyApp.pm
+#
+__PACKAGE__->config->{namespace} = '';
+
+=head1 NAME
+
+exception_test_new_case::Controller::Root - Root Controller for exception_test_new_case
+
+=head1 DESCRIPTION
+
+[enter your description here]
+
+=head1 METHODS
+
+=cut
+
+=head2 index
+
+=cut
+
+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 );
+}
+
+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') {}
+
+=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;

Added: trunk/misc/exception_test_new_case/lib/exception_test_new_case.pm
===================================================================
--- trunk/misc/exception_test_new_case/lib/exception_test_new_case.pm	                        (rev 0)
+++ trunk/misc/exception_test_new_case/lib/exception_test_new_case.pm	2009-08-18 11:28:35 UTC (rev 11155)
@@ -0,0 +1,140 @@
+package exception_test_new_case;
+
+use strict;
+use warnings;
+
+use TestAppClassExceptionSimpleTest;
+
+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 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;

Added: trunk/misc/exception_test_new_case/root/favicon.ico
===================================================================
(Binary files differ)


Property changes on: trunk/misc/exception_test_new_case/root/favicon.ico
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream

Added: trunk/misc/exception_test_new_case/script/exception_test_new_case_server.pl
===================================================================
--- trunk/misc/exception_test_new_case/script/exception_test_new_case_server.pl	                        (rev 0)
+++ trunk/misc/exception_test_new_case/script/exception_test_new_case_server.pl	2009-08-18 11:28:35 UTC (rev 11155)
@@ -0,0 +1,114 @@
+#!/usr/pkg/bin/perl -w
+
+BEGIN { 
+    $ENV{CATALYST_ENGINE} ||= 'HTTP';
+    $ENV{CATALYST_SCRIPT_GEN} = 31;
+    require Catalyst::Engine::HTTP;
+}  
+
+use strict;
+use warnings;
+use Getopt::Long;
+use Pod::Usage;
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+
+my $debug             = 0;
+my $fork              = 0;
+my $help              = 0;
+my $host              = undef;
+my $port              = $ENV{EXCEPTION_TEST_NEW_CASE_PORT} || $ENV{CATALYST_PORT} || 3000;
+my $keepalive         = 0;
+my $restart           = $ENV{EXCEPTION_TEST_NEW_CASE_RELOAD} || $ENV{CATALYST_RELOAD} || 0;
+my $restart_delay     = 1;
+my $restart_regex     = '(?:/|^)(?!\.#).+(?:\.yml$|\.yaml$|\.conf|\.pm)$';
+my $restart_directory = undef;
+my $follow_symlinks   = 0;
+
+my @argv = @ARGV;
+
+GetOptions(
+    'debug|d'             => \$debug,
+    'fork'                => \$fork,
+    'help|?'              => \$help,
+    'host=s'              => \$host,
+    'port=s'              => \$port,
+    'keepalive|k'         => \$keepalive,
+    'restart|r'           => \$restart,
+    'restartdelay|rd=s'   => \$restart_delay,
+    'restartregex|rr=s'   => \$restart_regex,
+    'restartdirectory=s@' => \$restart_directory,
+    'followsymlinks'      => \$follow_symlinks,
+);
+
+pod2usage(1) if $help;
+
+if ( $restart && $ENV{CATALYST_ENGINE} eq 'HTTP' ) {
+    $ENV{CATALYST_ENGINE} = 'HTTP::Restarter';
+}
+if ( $debug ) {
+    $ENV{CATALYST_DEBUG} = 1;
+}
+
+# This is require instead of use so that the above environment
+# variables can be set at runtime.
+require exception_test_new_case;
+
+exception_test_new_case->run( $port, $host, {
+    argv              => \@argv,
+    'fork'            => $fork,
+    keepalive         => $keepalive,
+    restart           => $restart,
+    restart_delay     => $restart_delay,
+    restart_regex     => qr/$restart_regex/,
+    restart_directory => $restart_directory,
+    follow_symlinks   => $follow_symlinks,
+} );
+
+1;
+
+=head1 NAME
+
+exception_test_new_case_server.pl - Catalyst Testserver
+
+=head1 SYNOPSIS
+
+exception_test_new_case_server.pl [options]
+
+ Options:
+   -d -debug          force debug mode
+   -f -fork           handle each request in a new process
+                      (defaults to false)
+   -? -help           display this help and exits
+      -host           host (defaults to all)
+   -p -port           port (defaults to 3000)
+   -k -keepalive      enable keep-alive connections
+   -r -restart        restart when files get modified
+                      (defaults to false)
+   -rd -restartdelay  delay between file checks
+   -rr -restartregex  regex match files that trigger
+                      a restart when modified
+                      (defaults to '\.yml$|\.yaml$|\.conf|\.pm$')
+   -restartdirectory  the directory to search for
+                      modified files, can be set mulitple times
+                      (defaults to '[SCRIPT_DIR]/..')
+   -follow_symlinks   follow symlinks in search directories
+                      (defaults to false. this is a no-op on Win32)
+ See also:
+   perldoc Catalyst::Manual
+   perldoc Catalyst::Manual::Intro
+
+=head1 DESCRIPTION
+
+Run a Catalyst Testserver for this application.
+
+=head1 AUTHORS
+
+Catalyst Contributors, see Catalyst.pm
+
+=head1 COPYRIGHT
+
+This library is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut


Property changes on: trunk/misc/exception_test_new_case/script/exception_test_new_case_server.pl
___________________________________________________________________
Name: svn:executable
   + *

Added: trunk/misc/exception_test_new_case/script/exception_test_new_case_test.pl
===================================================================
--- trunk/misc/exception_test_new_case/script/exception_test_new_case_test.pl	                        (rev 0)
+++ trunk/misc/exception_test_new_case/script/exception_test_new_case_test.pl	2009-08-18 11:28:35 UTC (rev 11155)
@@ -0,0 +1,53 @@
+#!/usr/pkg/bin/perl -w
+
+use strict;
+use warnings;
+use Getopt::Long;
+use Pod::Usage;
+use FindBin;
+use lib "$FindBin::Bin/../lib";
+use Catalyst::Test 'exception_test_new_case';
+
+my $help = 0;
+
+GetOptions( 'help|?' => \$help );
+
+pod2usage(1) if ( $help || !$ARGV[0] );
+
+print request($ARGV[0])->content . "\n";
+
+1;
+
+=head1 NAME
+
+exception_test_new_case_test.pl - Catalyst Test
+
+=head1 SYNOPSIS
+
+exception_test_new_case_test.pl [options] uri
+
+ Options:
+   -help    display this help and exits
+
+ Examples:
+   exception_test_new_case_test.pl http://localhost/some_action
+   exception_test_new_case_test.pl /some_action
+
+ See also:
+   perldoc Catalyst::Manual
+   perldoc Catalyst::Manual::Intro
+
+=head1 DESCRIPTION
+
+Run a Catalyst action from the command line.
+
+=head1 AUTHORS
+
+Catalyst Contributors, see Catalyst.pm
+
+=head1 COPYRIGHT
+
+This library is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut


Property changes on: trunk/misc/exception_test_new_case/script/exception_test_new_case_test.pl
___________________________________________________________________
Name: svn:executable
   + *

Added: trunk/misc/exception_test_new_case/t/01app.t
===================================================================
--- trunk/misc/exception_test_new_case/t/01app.t	                        (rev 0)
+++ trunk/misc/exception_test_new_case/t/01app.t	2009-08-18 11:28:35 UTC (rev 11155)
@@ -0,0 +1,7 @@
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+BEGIN { use_ok 'Catalyst::Test', 'exception_test_new_case' }
+
+ok( request('/')->is_success, 'Request should succeed' );




More information about the Catalyst-commits mailing list