view exceptions and some code cleaning

git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@196 48953598-375a-da11-a14b-00016c27c3ee

diff --git a/lib/CGI/Maypole.pm b/lib/CGI/Maypole.pm
index b937d8279a6774e58edf5f99ae0aa1c2fd1ed804..bc313216d0e9adc268abf5fcd9db2f254a7bf35b 100644 (file)
--- a/lib/CGI/Maypole.pm
+++ b/lib/CGI/Maypole.pm
@@ -40,7 +40,7 @@ sub send_output {
     my $r = shift;
     print $r->{cgi}->header(
         -type           => $r->{content_type},
-        -charset       => $r->{document_encoding},
+        -charset        => $r->{document_encoding},
         -content_length => length $r->{output},
     );
     print $r->{output};

diff --git a/lib/Maypole.pm b/lib/Maypole.pm
index 53e9be59cbe4afb0dcda50a24bfb1da219a54f03..4a5201127794ab8c8936cd322eeeb62de83395b1 100644 (file)
--- a/lib/Maypole.pm
+++ b/lib/Maypole.pm
@@ -83,7 +83,7 @@ sub handler_guts {
     if ( my $error = $@ ) {
         $status = $r->call_exception($error);
         if ( $status != OK ) {
-            warn "caught model error: $error";
+            warn "caught authenticate error: $error";
             return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
         }
     }
@@ -106,7 +106,15 @@ sub handler_guts {
         }
     }
     if ( !$r->{output} ) {    # You might want to do it yourself
-        return $r->view_object->process($r);
+        eval { $status = $r->view_object->process($r) };
+        if ( my $error = $@ ) {
+            $status = $r->call_exception($error);
+            if ( $status != OK ) {
+                warn "caught view error: $error";
+                return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
+            }
+        }
+        return $status;
     }
     else { return OK; }
 }

diff --git a/lib/Maypole/CLI.pm b/lib/Maypole/CLI.pm
index b08aab17fe838b17171b2e725ea6b5b8f2000435..fec6f5e8739929565c624f7b9e27499a9ef2abee 100644 (file)
--- a/lib/Maypole/CLI.pm
+++ b/lib/Maypole/CLI.pm
@@ -1,27 +1,29 @@
 package Maypole::CLI;
 use UNIVERSAL::require;
-use URI; use URI::QueryParam;
+use URI;
+use URI::QueryParam;
 use Maypole::Constants;
 
 use strict;
 use warnings;
 my $package;
 our $buffer;
-sub import { 
+
+sub import {
     $package = $_[1];
     $package->require;
     die "Couldn't require $package - $@" if $@;
     no strict 'refs';
-    unshift @{$package."::ISA"}, "Maypole::CLI";
+    unshift @{ $package . "::ISA" }, "Maypole::CLI";
 }
 
-sub get_request {}
+sub get_request       { }
 sub get_template_root { $ENV{MAYPOLE_TEMPLATES} || "." }
 
 sub parse_location {
     my $self = shift;
-    my $url = URI->new(shift @ARGV);
-    my $root = URI->new($self->config->{uri_base})->path;
+    my $url  = URI->new( shift @ARGV );
+    my $root = URI->new( $self->config->{uri_base} )->path;
     $self->{path} = $url->path;
     $self->{path} =~ s/^$root//i if $root;
     $self->parse_path;
@@ -29,22 +31,25 @@ sub parse_location {
 }
 
 sub parse_args {
-    my ($self,$url) = @_;
+    my ( $self, $url ) = @_;
     $self->{params} = $url->query_form_hash;
-    $self->{query} = $url->query_form_hash;
+    $self->{query}  = $url->query_form_hash;
 }
 
 sub send_output { $buffer = shift->{output} }
 
 sub call_url {
-       my $self =shift;
-       @ARGV=@_;
-    $package->handler() == OK and return $buffer; 
+    my $self = shift;
+    @ARGV = @_;
+    $package->handler() == OK and return $buffer;
 }
+
 # Do it!
-CHECK { if ((caller(0))[1] eq "-e") { 
-            $package->handler() == OK and print $buffer; 
-       } }
+CHECK {
+    if ( ( caller(0) )[1] eq "-e" ) {
+        $package->handler() == OK and print $buffer;
+    }
+}
 
 1;
 

diff --git a/lib/Maypole/Constants.pm b/lib/Maypole/Constants.pm
index 7bddbacfaa709af2c869ffa6536a1d0c5e5d39be..a758584c1a3e0aba0bb3d58a82f35400b473f5ca 100644 (file)
--- a/lib/Maypole/Constants.pm
+++ b/lib/Maypole/Constants.pm
@@ -1,7 +1,7 @@
 package Maypole::Constants;
 use base 'Exporter';
-use constant OK => 0;
+use constant OK       => 0;
 use constant DECLINED => -1;
-use constant ERROR => -1;
+use constant ERROR    => -1;
 our @EXPORT = qw(OK DECLINED ERROR);
 1;

diff --git a/lib/Maypole/Model/Base.pm b/lib/Maypole/Model/Base.pm
index 6e60aea7f9c3f4505b93263eaa31fcef4dc240d2..804f23519d0a808b1000d621660fe2b010d4f0fc 100644 (file)
--- a/lib/Maypole/Model/Base.pm
+++ b/lib/Maypole/Model/Base.pm
@@ -1,27 +1,31 @@
 package Maypole::Model::Base;
 our %remember;
-sub MODIFY_CODE_ATTRIBUTES { $remember{$_[1]} = $_[2]; () }
+sub MODIFY_CODE_ATTRIBUTES { $remember{ $_[1] } = $_[2]; () }
 
-sub FETCH_CODE_ATTRIBUTES { $remember{$_[1]} } 
-sub view :Exported { }
-sub edit :Exported { }
+sub FETCH_CODE_ATTRIBUTES { $remember{ $_[1] } }
+
+sub view : Exported {
+}
+
+sub edit : Exported {
+}
 
 sub process {
-    my ($class, $r) = @_;
+    my ( $class, $r ) = @_;
     my $method = $r->action;
-    return if $r->{template}; # Authentication has set this, we're done.
+    return if $r->{template};    # Authentication has set this, we're done.
 
     $r->{template} = $method;
-    $r->objects([]);
+    $r->objects( [] );
     my $obj = $class->retrieve( $r->{args}->[0] );
     if ($obj) {
-        $r->objects([ $obj ]);
-        shift @{$r->{args}};
+        $r->objects( [$obj] );
+        shift @{ $r->{args} };
     }
-    $class->$method($r, $obj, @{$r->{args}});
+    $class->$method( $r, $obj, @{ $r->{args} } );
 }
 
-sub display_columns { 
+sub display_columns {
     sort shift->columns;
 }
 
@@ -106,7 +110,10 @@ similar.
 
 sub class_of       { die "This is an abstract method" }
 sub setup_database { die "This is an abstract method" }
-sub list :Exported { die "This is an abstract method" };
+
+sub list : Exported {
+    die "This is an abstract method";
+}
 
 =pod
 
@@ -123,10 +130,14 @@ Return a hash mapping column names with human-readable equivalents.
 
 =cut
 
-sub column_names { my $class = shift; map { 
+sub column_names {
+    my $class = shift;
+    map {
         my $col = $_;
         $col =~ s/_+(\w)?/ \U$1/g;
-        $_ => ucfirst $col } $class->columns }
+        $_ => ucfirst $col
+    } $class->columns;
+}
 
 =head2 description
 

diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm
index 2a79850805008930c4f461e734c5bcb5a15d0161..e1d665291f55afb16b78451c2f4ffa60b50315ea 100644 (file)
--- a/lib/Maypole/Model/CDBI.pm
+++ b/lib/Maypole/Model/CDBI.pm
@@ -25,131 +25,144 @@ modules.
 =cut
 
 sub related {
-    my ($self, $r) = @_;
-    return keys %{$self->meta_info('has_many') || {}};
+    my ( $self, $r ) = @_;
+    return keys %{ $self->meta_info('has_many') || {} };
 }
 
-sub do_edit :Exported {
-    my ($self, $r) = @_;
-    my $h = CGI::Untaint->new(%{$r->{params}});
+sub do_edit : Exported {
+    my ( $self, $r ) = @_;
+    my $h        = CGI::Untaint->new( %{ $r->{params} } );
     my $creating = 0;
-    my ($obj) = @{$r->objects || []};
+    my ($obj) = @{ $r->objects || [] };
     if ($obj) {
+
         # We have something to edit
-        $obj->update_from_cgi($h => {
-           required => $r->{config}{$r->{table}}{required_cols} || [],
-                                    });
-    } else {
-        $obj = $self->create_from_cgi($h => {
-           required => $r->{config}{$r->{table}}{required_cols} || [],
-                                    });
+        $obj->update_from_cgi( $h =>
+              { required => $r->{config}{ $r->{table} }{required_cols} || [], }
+        );
+    }
+    else {
+        $obj =
+          $self->create_from_cgi( $h =>
+              { required => $r->{config}{ $r->{table} }{required_cols} || [], }
+          );
         $creating++;
     }
-    if (my %errors = $obj->cgi_update_errors) {
+    if ( my %errors = $obj->cgi_update_errors ) {
+
         # Set it up as it was:
         $r->{template_args}{cgi_params} = $r->{params};
-        $r->{template_args}{errors} = \%errors;
-        $r->{template} = "edit";
-        undef $obj if $creating; # Couldn't create
-    } else {
+        $r->{template_args}{errors}     = \%errors;
+        $r->{template}                  = "edit";
+        undef $obj if $creating;    # Couldn't create
+    }
+    else {
         $r->{template} = "view";
     }
-    $r->objects([ $obj ]);
+    $r->objects( [$obj] );
 }
 
-sub delete :Exported {
+sub delete : Exported {
     return shift->SUPER::delete(@_) if caller ne "Maypole::Model::Base";
-    my ($self, $r) = @_;
+    my ( $self, $r ) = @_;
     $_->SUPER::delete for @{ $r->objects || [] };
-    $r->objects([ $self->retrieve_all ]);
+    $r->objects( [ $self->retrieve_all ] );
     $r->{template} = "list";
     $self->list($r);
 }
 
 sub stringify_column {
     my $class = shift;
-    return ($class->columns("Stringify"),
-                (grep { /(name|title)/i } $class->columns),
-                (grep { !/id$/i } $class->primary_columns),
-               )[0];
+    return (
+        $class->columns("Stringify"),
+        ( grep { /(name|title)/i } $class->columns ),
+        ( grep { !/id$/i } $class->primary_columns ),
+    )[0];
 }
 
 sub adopt {
-    my ($self, $child) = @_;
+    my ( $self, $child ) = @_;
     $child->autoupdate(1);
-    if (my $col = $child->stringify_column) {
+    if ( my $col = $child->stringify_column ) {
         $child->columns( Stringify => $col );
     }
 }
 
-sub search :Exported {
+sub search : Exported {
     return shift->SUPER::search(@_) if caller ne "Maypole::Model::Base";
-                                    # A real CDBI search.
-    my ($self, $r) = @_;
-    my %fields = map {$_ => 1 } $self->columns;
-    my $oper = "like"; # For now
-    my %params = %{$r->{params}};
-    my %values = map { $_ => {$oper, $params{$_} } }
-                 grep { $params{$_} and $fields{$_} } keys %params;
+
+    # A real CDBI search.
+    my ( $self, $r ) = @_;
+    my %fields = map { $_ => 1 } $self->columns;
+    my $oper   = "like";                                # For now
+    my %params = %{ $r->{params} };
+    my %values = map { $_ => { $oper, $params{$_} } }
+      grep { $params{$_} and $fields{$_} } keys %params;
 
     $r->template("list");
-    if (!%values) { return $self->list($r) }
+    if ( !%values ) { return $self->list($r) }
     my $order = $self->order($r);
     $self = $self->do_pager($r);
-    $r->objects([ $self->search_where(\%values), 
-                  ($order ? { order => $order } : ())  
-                ]);
+    $r->objects(
+        [
+            $self->search_where( \%values ),
+            ( $order ? { order => $order } : () )
+        ]
+    );
     $r->{template_args}{search} = 1;
 }
 
 sub do_pager {
-    my ($self, $r) = @_;
-    if ( my $rows = $r->config->{rows_per_page}) {
-        return $r->{template_args}{pager} = $self->pager($rows, $r->query->{page});
-    } else { return $self } 
+    my ( $self, $r ) = @_;
+    if ( my $rows = $r->config->{rows_per_page} ) {
+        return $r->{template_args}{pager} =
+          $self->pager( $rows, $r->query->{page} );
+    }
+    else { return $self }
 }
 
 sub order {
-    my ($self, $r) = @_;
+    my ( $self, $r ) = @_;
     my $order;
-    my %ok_columns = map {$_ => 1} $self->columns;
-    if ($order = $r->query->{order} and $ok_columns{$order}) {
-       $order .= ($r->query->{o2} eq "desc" && " DESC")
+    my %ok_columns = map { $_ => 1 } $self->columns;
+    if ( $order = $r->query->{order} and $ok_columns{$order} ) {
+        $order .= ( $r->query->{o2} eq "desc" && " DESC" );
     }
     $order;
 }
 
-sub list :Exported {
-    my ($self, $r) = @_;
+sub list : Exported {
+    my ( $self, $r ) = @_;
     my $order = $self->order($r);
     $self = $self->do_pager($r);
-    if ($order) { 
-        $r->objects([ $self->retrieve_all_sorted_by( $order )]);
-    } else {
-        $r->objects([ $self->retrieve_all ]);
+    if ($order) {
+        $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
+    }
+    else {
+        $r->objects( [ $self->retrieve_all ] );
     }
 }
 
 sub setup_database {
-    my ($self, $config, $namespace, $dsn, $u, $p, $opts) = @_;
+    my ( $self, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
     $dsn  ||= $config->{dsn};
     $u    ||= $config->{user};
     $p    ||= $config->{pass};
     $opts ||= $config->{opts};
-    $config->{dsn} = $dsn;
+    $config->{dsn}    = $dsn;
     $config->{loader} = Class::DBI::Loader->new(
         namespace => $namespace,
-        dsn => $dsn,
-        user => $u,
-        password => $p,
-        options => $opts,
+        dsn       => $dsn,
+        user      => $u,
+        password  => $p,
+        options   => $opts,
     );
     $config->{classes} = [ $config->{loader}->classes ];
     $config->{tables}  = [ $config->{loader}->tables ];
 }
 
 sub class_of {
-    my ($self, $r, $table) = @_;
+    my ( $self, $r, $table ) = @_;
     return $r->config->{loader}->_table2class($table);
 }
 

diff --git a/lib/Maypole/Model/CDBI/Plain.pm b/lib/Maypole/Model/CDBI/Plain.pm
index 05aad180c6ee1f0394da56ec0a9c0ff04ef45d55..114eb884b830813363772ce69026ef6fb5a6ad9a 100644 (file)
--- a/lib/Maypole/Model/CDBI/Plain.pm
+++ b/lib/Maypole/Model/CDBI/Plain.pm
@@ -1,14 +1,15 @@
 package Maypole::Model::CDBI::Plain;
 use base 'Maypole::Model::CDBI';
+
 sub setup_database {
-    my ($self, $config, $namespace, $classes) = @_;
-    $config->{classes} = $classes;
-    $config->{table_to_class}  = { map { $_->table => $_ } @$classes };
-    $config->{tables} = [ keys %{$config->{table_to_class}} ];
+    my ( $self, $config, $namespace, $classes ) = @_;
+    $config->{classes}        = $classes;
+    $config->{table_to_class} = { map { $_->table => $_ } @$classes };
+    $config->{tables}         = [ keys %{ $config->{table_to_class} } ];
 }
 
 sub class_of {
-    my ($self, $r, $table) = @_;
+    my ( $self, $r, $table ) = @_;
     return $r->config->{table_to_class}->{$table};
 }
 
@@ -36,3 +37,4 @@ of the classes you're going to use, and Maypole will work out the
 tables and set up the inheritance relationships as normal.
 
 =cut
+

diff --git a/lib/Maypole/View/Base.pm b/lib/Maypole/View/Base.pm
index 51c2cb6dcbc3601d9567d4b725db06017c73ce4d..61c887d3ef0bba3c91922a06ec66de8eb5cecc9c 100644 (file)
--- a/lib/Maypole/View/Base.pm
+++ b/lib/Maypole/View/Base.pm
@@ -4,73 +4,78 @@ use UNIVERSAL::moniker;
 use strict;
 use Maypole::Constants;
 
-sub new { bless {}, shift } # By default, do nothing.
+sub new { bless {}, shift }    # By default, do nothing.
 
 sub paths {
-    my ($self, $r) = @_;
+    my ( $self, $r ) = @_;
     my $root = $r->{config}{template_root} || $r->get_template_root;
     return (
         $root,
-        ($r->model_class && 
-            File::Spec->catdir($root, $r->model_class->moniker)),
-        File::Spec->catdir($root, "custom"),
-        File::Spec->catdir($root, "factory")
+        (
+            $r->model_class
+              && File::Spec->catdir( $root, $r->model_class->moniker )
+        ),
+        File::Spec->catdir( $root, "custom" ),
+        File::Spec->catdir( $root, "factory" )
     );
 }
 
 sub vars {
-    my ($self, $r) = @_;
+    my ( $self, $r ) = @_;
     my $class = $r->model_class;
-    my $base = $r->{config}->{uri_base};
+    my $base  = $r->{config}->{uri_base};
     $base =~ s/\/+$//;
     my %args = (
         request => $r,
         objects => $r->objects,
         base    => $base,
         config  => $r->config
-        # ...
-    ) ;
-    if ($class) { 
+
+          # ...
+    );
+    if ($class) {
         $args{classmetadata} = {
-            name => $class,
-            table => $class->table,
-            columns => [ $class->display_columns ],
-            colnames => { $class->column_names },
+            name              => $class,
+            table             => $class->table,
+            columns           => [ $class->display_columns ],
+            colnames          => { $class->column_names },
             related_accessors => [ $class->related($r) ],
-            moniker => $class->moniker,
-            plural  => $class->plural_moniker,
-            cgi => { $class->to_cgi },
+            moniker           => $class->moniker,
+            plural            => $class->plural_moniker,
+            cgi               => { $class->to_cgi },
         };
 
         # User-friendliness facility for custom template writers.
-        if (@{$r->objects || []} > 1) { 
-            $args{$r->model_class->plural_moniker} = $r->objects;
-        } else {
-            ($args{$r->model_class->moniker}) = @{$r->objects ||[]};
+        if ( @{ $r->objects || [] } > 1 ) {
+            $args{ $r->model_class->plural_moniker } = $r->objects;
+        }
+        else {
+            ( $args{ $r->model_class->moniker } ) = @{ $r->objects || [] };
         }
     }
 
     # Overrides
-    %args = (%args, %{$r->{template_args}||{}});
+    %args = ( %args, %{ $r->{template_args} || {} } );
     %args;
 }
 
 sub process {
-    my ($self, $r) = @_;
+    my ( $self, $r ) = @_;
     my $status = $self->template($r);
     return $self->error($r) if $status != OK;
-    $r->{content_type} ||= "text/html";
+    $r->{content_type}      ||= "text/html";
     $r->{document_encoding} ||= "utf-8";
     return OK;
 }
 
 sub error {
-    my ($self, $r) = @_;
+    my ( $self, $r ) = @_;
     warn $r->{error};
-    if ($r->{error} =~ /not found$/) { 
+    if ( $r->{error} =~ /not found$/ ) {
+
         # This is a rough test to see whether or not we're a template or
         # a static page
-        return -1 unless @{$r->{objects}||[]}; 
+        return -1 unless @{ $r->{objects} || [] };
 
         $r->{error} = <<EOF;
 
@@ -91,15 +96,15 @@ Looking for template <B>@{[$r->{template}]}</B> in paths:
 </PRE>
 EOF
         $r->{content_type} = "text/html";
-        $r->{output} = $r->{error};
+        $r->{output}       = $r->{error};
         return OK;
     }
     $r->{content_type} = "text/plain";
-    $r->{output} = $r->{error};
+    $r->{output}       = $r->{error};
     $r->send_output;
     return ERROR;
 }
 
-sub template { die shift()." didn't define a decent template method!" }
+sub template { die shift() . " didn't define a decent template method!" }
 
 1;

diff --git a/lib/Maypole/View/TT.pm b/lib/Maypole/View/TT.pm
index 0e8d89fbc1b2476f992c7aee9c57a1f7eafd3ea3..9142f3ebe51bdbda78ffbde8f2a37e5de11f9f50 100644 (file)
--- a/lib/Maypole/View/TT.pm
+++ b/lib/Maypole/View/TT.pm
@@ -4,13 +4,14 @@ use Maypole::Constants;
 use Template;
 
 sub template {
-    my ($self, $r) = @_;
-    my $template = Template->new({ INCLUDE_PATH => [ $self->paths($r) ]});
+    my ( $self, $r ) = @_;
+    my $template = Template->new( { INCLUDE_PATH => [ $self->paths($r) ] } );
     my $output;
-    if ($template->process($r->template, { $self->vars($r) }, \$output)) {
+    if ( $template->process( $r->template, { $self->vars($r) }, \$output ) ) {
         $r->{output} = $output;
         return OK;
-    } else {
+    }
+    else {
         $r->{error} = $template->error;
         return ERROR;
     }
@@ -39,3 +40,4 @@ components are resolved.
 Simon Cozens
 
 =cut
+