X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=dd9ff770a1827ca393dd4361509222461135f1b7;hb=193575767582376e4a70c5d4af176dab84b2b0ee;hp=b55f7b924ec8309d148a5e3660212b1bae344771;hpb=50d74fd61a4ecccaf8d3ecac58ef4ec1f8e48b52;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index b55f7b9..dd9ff77 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -1,14 +1,17 @@ package Maypole; -use base qw(Class::Accessor Class::Data::Inheritable); +use base qw(Class::Accessor::Fast Class::Data::Inheritable); use attributes (); use UNIVERSAL::require; use strict; use warnings; -our $VERSION = "1.7"; +use Maypole::Config; +our $VERSION = '2.0'; __PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); -__PACKAGE__->mk_accessors ( qw( ar params query objects model_class -args action template )); -__PACKAGE__->config({}); +__PACKAGE__->mk_accessors( + qw( ar params query objects model_class template_args output path + args action template error document_encoding content_type table) +); +__PACKAGE__->config( Maypole::Config->new() ); __PACKAGE__->init_done(0); use Maypole::Constants; @@ -18,117 +21,172 @@ sub setup { my $calling_class = shift; $calling_class = ref $calling_class if ref $calling_class; { - no strict 'refs'; - # Naughty. - *{$calling_class."::handler"} = sub { Maypole::handler($calling_class, @_) }; + no strict 'refs'; + + # Naughty. + *{ $calling_class . "::handler" } = + sub { Maypole::handler( $calling_class, @_ ) }; } my $config = $calling_class->config; - $config->{model} ||= "Maypole::Model::CDBI"; - $config->{model}->require; - die "Couldn't load the model class $config->{model}: $@" if $@; - $config->{model}->setup_database($config, $calling_class, @_); - for my $subclass (@{$config->{classes}}) { + $config->model || $config->model("Maypole::Model::CDBI"); + $config->model->require; + die "Couldn't load the model class $config->model: $@" if $@; + $config->model->setup_database( $config, $calling_class, @_ ); + for my $subclass ( @{ $config->classes } ) { no strict 'refs'; - unshift @{$subclass."::ISA"}, $config->{model}; - $config->{model}->adopt($subclass) - if $config->{model}->can("adopt"); + unshift @{ $subclass . "::ISA" }, $config->model; + $config->model->adopt($subclass) + if $config->model->can("adopt"); } } sub init { - my $class = shift; + my $class = shift; my $config = $class->config; - $config->{view} ||= "Maypole::View::TT"; - $config->{view}->require; - die "Couldn't load the view class $config->{view}: $@" if $@; - $config->{display_tables} ||= [ @{$class->config->{tables}} ]; - $class->view_object($class->config->{view}->new); + $config->view || $config->view("Maypole::View::TT"); + $config->view->require; + die "Couldn't load the view class " . $config->view . ": $@" if $@; + $config->display_tables + || $config->display_tables( [ $class->config->tables ] ); + $class->view_object( $class->config->view->new ); $class->init_done(1); } sub handler { + # See Maypole::Workflow before trying to understand this. - my $class = shift; + my ( $class, $req ) = @_; $class->init unless $class->init_done; my $r = bless { config => $class->config }, $class; - $r->get_request(@_); + $r->get_request($req); $r->parse_location(); my $status = $r->handler_guts(); return $status unless $status == OK; - $r->{content_type} ||= "text/html"; $r->send_output; return $status; } +# The root of all evil sub handler_guts { my $r = shift; - $r->model_class($r->config->{model}->class_of($r, $r->{table})); - my $status = $r->is_applicable; - if ($status == OK) { - $status = $r->call_authenticate; - if ($r->debug and $status != OK and $status != DECLINED) { - $r->view_object->error($r, - "Got unexpected status $status from calling authentication"); - } - return $status unless $status == OK; - $r->additional_data(); - - $r->model_class->process($r); - } else { - # Otherwise, it's just a plain template. + $r->model_class( $r->config->model->class_of( $r, $r->{table} ) ); + my $applicable = $r->is_applicable; + unless ( $applicable == OK ) { + + # It's just a plain template delete $r->{model_class}; - $r->{path} =~ s{/}{}; # De-absolutify - $r->template($r->{path}); + $r->{path} =~ s{/$}{}; # De-absolutify + $r->template( $r->{path} ); + } + + # We authenticate every request, needed for proper session management + my $status; + eval { $status = $r->call_authenticate }; + if ( my $error = $@ ) { + $status = $r->call_exception($error); + if ( $status != OK ) { + warn "caught authenticate error: $error"; + return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + } + } + if ( $r->debug and $status != OK and $status != DECLINED ) { + $r->view_object->error( $r, + "Got unexpected status $status from calling authentication" ); } - if (!$r->{output}) { # You might want to do it yourself - return $r->view_object->process($r); - } else { return OK; } + return $status unless $status == OK; + + # We run additional_data for every request + $r->additional_data; + if ( $applicable == OK ) { + eval { $r->model_class->process($r) }; + if ( my $error = $@ ) { + $status = $r->call_exception($error); + if ( $status != OK ) { + warn "caught model error: $error"; + return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + } + } + } + if ( !$r->{output} ) { # You might want to do it yourself + eval { $status = $r->view_object->process($r) }; + if ( my $error = $@ ) { + $status = $r->call_exception($error); + if ( $status != OK ) { + warn "caught view error: $error" if $r->debug; + return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + } + } + return $status; + } + else { return OK; } } sub is_applicable { - my $self = shift; + my $self = shift; my $config = $self->config; - $config->{ok_tables} ||= $config->{display_tables}; - $config->{ok_tables} = {map {$_=>1} @{$config->{ok_tables}}} - if ref $config->{ok_tables} eq "ARRAY"; + $config->ok_tables || $config->ok_tables( $config->display_tables ); + $config->ok_tables( { map { $_ => 1 } @{ $config->ok_tables } } ) + if ref $config->ok_tables eq "ARRAY"; warn "We don't have that table ($self->{table})" - if $self->debug and not $config->{ok_tables}{$self->{table}}; - return DECLINED() unless exists $config->{ok_tables}{$self->{table}}; + if $self->debug + and not $config->ok_tables->{ $self->{table} }; + return DECLINED() unless exists $config->ok_tables->{ $self->{table} }; # Does the action method exist? - my $cv = $self->model_class->can($self->{action}); - warn "We don't have that action ($self->{action})" - if $self->debug and not $cv; + my $cv = $self->model_class->can( $self->{action} ); + warn "We don't have that action ($self->{action})" + if $self->debug and not $cv; return DECLINED() unless $cv; # Is it exported? $self->{method_attribs} = join " ", attributes::get($cv); - do { warn "$self->{action} not exported" if $self->debug; - return DECLINED() - } unless $self->{method_attribs} =~ /\bExported\b/i; + do { + warn "$self->{action} not exported" if $self->debug; + return DECLINED(); + } unless $self->{method_attribs} =~ /\bExported\b/i; return OK(); } sub call_authenticate { my $self = shift; - return $self->model_class->authenticate($self) if - $self->model_class->can("authenticate"); - return $self->authenticate($self); # Interface consistency is a Good Thing + + # Check if we have a model class + if ( $self->{model_class} ) { + return $self->model_class->authenticate($self) + if $self->model_class->can("authenticate"); + } + return $self->authenticate($self); # Interface consistency is a Good Thing +} + +sub call_exception { + my $self = shift; + my ($error) = @_; + + # Check if we have a model class + if ( $self->{model_class} + && $self->model_class->can('exception') ) + { + my $status = $self->model_class->exception( $self, $error ); + return $status if $status == OK; + } + return $self->exception($error); } -sub additional_data {} +sub additional_data { } sub authenticate { return OK } +sub exception { return ERROR } + sub parse_path { my $self = shift; $self->{path} ||= "frontpage"; my @pi = split /\//, $self->{path}; shift @pi while @pi and !$pi[0]; - $self->{table} = shift @pi; + $self->{table} = shift @pi; $self->{action} = shift @pi; - $self->{args} = \@pi; + $self->{args} = \@pi; } =head1 NAME @@ -163,9 +221,9 @@ for the designers to customize, and then write an Apache handler like this: package ProductDatabase; - use base 'Apache::MVC'; + use base 'Maypole::Application'; __PACKAGE__->set_database("dbi:mysql:products"); - ProductDatabase->config->{uri_base} = "http://your.site/catalogue/"; + ProductDatabase->config->uri_base = "http://your.site/catalogue/"; ProductDatabase::Product->has_a("category" => ProductDatabase::Category); # ... @@ -223,7 +281,7 @@ subclass the model class, and configure your class slightly differently: Then your top-level application package should change the model class: (Before calling C) - ProductDatabase->config->{model} = "ProductDatabase::Model"; + ProductDatabase->config->model("ProductDatabase::Model"); (The C<:Exported> attribute means that the method can be called via the URL C/supersearch/...>.) @@ -247,7 +305,8 @@ You should probably not use Maypole directly. Maypole is an abstract class which does not specify how to communicate with the outside world. The most popular subclass of Maypole is L, which interfaces the Maypole framework to Apache mod_perl; another important one is -L. +L. However, if you just don't care, use Maypole::Application, +and it will choose the right one for you. If you are implementing Maypole subclasses, you need to provide at least the C and C methods. You may also want to @@ -257,9 +316,15 @@ L documentation for what these are expected to do. =cut sub get_template_root { "." } -sub get_request { } -sub parse_location { die "Do not use Maypole directly; use Apache::MVC or similar" } -sub send_output{ die "Do not use Maypole directly; use Apache::MVC or similar" } +sub get_request { } + +sub parse_location { + die "Do not use Maypole directly; use Apache::MVC or similar"; +} + +sub send_output { + die "Do not use Maypole directly; use Apache::MVC or similar"; +} =head1 SEE ALSO @@ -267,12 +332,21 @@ There's more documentation, examples, and a wiki at the Maypole web site: http://maypole.simon-cozens.org/ -L, L. +L,L, L. + +=head1 MAINTAINER + +Sebastian Riedel, c =head1 AUTHOR Simon Cozens, C +=head1 THANK YOU + +Danijel Milicevic, Jesse Scheidlower, Jody Belka, Marcus Ramberg, +Mickael Joanne, Simon Flack, Veljko Vidovic and all the others who've helped. + =head1 LICENSE You may distribute this code under the same terms as Perl itself. @@ -280,4 +354,3 @@ You may distribute this code under the same terms as Perl itself. =cut 1; -