X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=908662f844431fdfa6ca4dc2664abb672f9a8b86;hb=808f88dcc99bd004c98cbefb759da90512da58eb;hp=49281f890ee054c6f54f76d877e840a1a1365fdc;hpb=89c581d3ee5960c3f1271d38e7f053642466648d;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 49281f8..908662f 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -7,11 +7,17 @@ use Maypole::Config; use Maypole::Constants; use Maypole::Headers; -our $VERSION = '2.10_pre1'; +our $VERSION = '2.10'; + +# proposed privacy conventions: +# - no leading underscore - public to custom application code and plugins +# - single leading underscore - private to the main Maypole stack - *not* +# including plugins +# - double leading underscore - private to the current package __PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); __PACKAGE__->mk_accessors( - qw( ar params query objects model_class template_args output path + qw( params query objects model_class template_args output path args action template error document_encoding content_type table headers_in headers_out ) ); @@ -20,23 +26,23 @@ __PACKAGE__->init_done(0); sub debug { 0 } -sub setup { +sub setup +{ my $calling_class = shift; + $calling_class = ref $calling_class if ref $calling_class; - { - no strict 'refs'; - no warnings 'redefine'; - - # Naughty. - *{ $calling_class . "::handler" } = - sub { Maypole::handler( $calling_class, @_ ) }; - } + my $config = $calling_class->config; - $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 } ) { + + $config->model || $config->model('Maypole::Model::CDBI'); + + $config->model->require or die sprintf + "Couldn't load the model class %s: %s", $config->model, $@; + + $config->model->setup_database($config, $calling_class, @_); + + foreach my $subclass ( @{ $config->classes } ) + { no strict 'refs'; unshift @{ $subclass . "::ISA" }, $config->model; $config->model->adopt($subclass) @@ -44,7 +50,8 @@ sub setup { } } -sub init { +sub init +{ my $class = shift; my $config = $class->config; $config->view || $config->view("Maypole::View::TT"); @@ -57,123 +64,224 @@ sub init { } -sub handler { +sub new +{ + my ($class) = @_; + + my $self = bless { + template_args => {}, + config => $class->config, + }, $class; + + return $self; +} +# handler() has a method attribute so that mod_perl will invoke +# BeerDB->handler() as a method rather than a plain function +# BeerDB::handler() and so this inherited implementation will be +# found. See e.g. "Practical mod_perl" by Bekman & Cholet for +# more information +sub handler : method +{ # See Maypole::Workflow before trying to understand this. - my ( $class, $req ) = @_; + my ($class, $req) = @_; + $class->init unless $class->init_done; - # Create the request object - my $r = bless { - template_args => {}, - config => $class->config - }, $class; - $r->headers_out(Maypole::Headers->new); - $r->get_request($req); - $r->parse_location(); - my $status = $r->handler_guts(); + my $self = $class->new; + + # initialise the request + $self->headers_out(Maypole::Headers->new); + $self->get_request($req); + $self->parse_location; + + my $status = $self->handler_guts; + + # moving this here causes unit test failures - need to check why + # before committing the move + #$status = $self->__call_process_view unless $self->output; + return $status unless $status == OK; - $r->send_output; + + $self->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 $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} ); - } - +sub handler_guts +{ + my ($self) = @_; + + $self->__load_model; + + my $applicable = __to_boolean( $self->is_applicable ); + + $self->__setup_plain_template unless $applicable; + # 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 ) { + + eval { $status = $self->call_authenticate }; + + if ( my $error = $@ ) + { + $status = $self->call_exception($error); + + if ( $status != OK ) + { warn "caught authenticate error: $error"; - return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } } - if ( $r->debug and $status != OK and $status != DECLINED ) { - $r->view_object->error( $r, + + if ( $self->debug and $status != OK and $status != DECLINED ) + { + $self->view_object->error( $self, "Got unexpected status $status from calling authentication" ); } + 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 ) { + $self->additional_data; + + if ($applicable) + { + eval { $self->model_class->process($self) }; + + if ( my $error = $@ ) + { + $status = $self->call_exception($error); + + if ( $status != OK ) + { warn "caught model error: $error"; - return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + return $self->debug ? + $self->view_object->error($self, $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; - } + + # less frequent path - perhaps output has been set to an error message + return OK if $self->output; + + # normal path - no output has been generated yet + return $self->__call_process_view; +} + +# is_applicable() returned false, so set up a plain template. Model processing +# will be skipped, but need to remove the model anyway so the template can't +# access it. +sub __setup_plain_template +{ + my ($self) = @_; + + # It's just a plain template + $self->model_class(undef); + + my $path = $self->path; + $path =~ s{/$}{}; # De-absolutify + $self->path($path); + + $self->template($self->path); +} + +# The model has been processed or skipped (if is_applicable returned false), +# any exceptions have been handled, and there's no content in $self->output +sub __call_process_view +{ + my ($self) = @_; + + my $status; + + eval { $status = $self->view_object->process($self) }; + + if ( my $error = $@ ) + { + $status = $self->call_exception($error); + + if ( $status != OK ) + { + warn "caught view error: $error" if $self->debug; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } - return $status; } - else { return OK; } + + return $status; } -sub is_applicable { - my $self = shift; +sub __load_model +{ + my ($self) = @_; + $self->model_class( $self->config->model->class_of($self, $self->table) ); +} + +# is_applicable() should return true or false, not OK or DECLINED, because +# the return value is never used as the return value from handler(). There's +# probably a lot of code out there supplying the return codes though, so +# instead of changing is_applicable() to return 0 or 1, the return value is +# passed through __to_boolean. I think it helps handler_guts() if we don't +# have multiple sets of return codes being checked for different things -drb. +sub is_applicable +{ + my ($self) = @_; + my $config = $self->config; + $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}).\n" - . "Available tables are: " - . join( ",", @{ $config->{display_tables} } ) - if $self->debug - and not $config->ok_tables->{ $self->{table} } - and $self->{action}; - return DECLINED() unless exists $config->ok_tables->{ $self->{table} }; + if ref $config->ok_tables eq "ARRAY"; + + my $table = $self->table; + + warn "We don't have that table ($table).\n" + . "Available tables are: " + . join( ",", @{ $config->display_tables } ) + if $self->debug + and not $config->ok_tables->{$table} + and $self->action; # this is probably always true + + return DECLINED unless exists $config->ok_tables->{$table}; # Is it public? - return DECLINED unless $self->model_class->is_public( $self->{action} ); - return OK(); + return DECLINED unless $self->model_class->is_public($self->action); + + return OK; } -sub call_authenticate { - my $self = shift; - - # 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 +# *only* intended for translating the return code from is_applicable() +sub __to_boolean { $_[0] == OK ? 1 : 0 } + +sub call_authenticate +{ + my ($self) = @_; + + # Check if we have a model class with an authenticate() to delegate to + return $self->model_class->authenticate($self) + if $self->model_class and $self->model_class->can('authenticate'); + + # Interface consistency is a Good Thing - + # the invocant and the argument may one day be different things + # (i.e. controller and request), like they are when authenticate() + # is called on a model class (i.e. model and request) + return $self->authenticate($self); } -sub call_exception { - my $self = shift; - my ($error) = @_; +sub call_exception +{ + my ($self, $error) = @_; - # Check if we have a model class - if ( $self->{model_class} - && $self->model_class->can('exception') ) + # Check if we have a model class with an exception() to delegate to + 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); } @@ -183,35 +291,38 @@ sub authenticate { return OK } sub exception { return ERROR } -sub parse_path { - my $self = shift; - $self->{path} ||= "frontpage"; - my @pi = $self->{path} =~ m{([^/]+)/?}g; - $self->{table} = shift @pi; - $self->{action} = shift @pi; - $self->{action} ||= "index"; - $self->{args} = \@pi; +sub parse_path +{ + my ($self) = @_; + + $self->path || $self->path('frontpage'); + + my @pi = grep {length} split '/', $self->path; + + $self->table(shift @pi); + + $self->action( shift @pi or 'index' ); + + $self->args(\@pi); } -sub param { # like CGI::param(), but read-only - my $r = shift; - my ($key) = @_; - if (defined $key) { - unless (exists $r->{params}{$key}) { - return wantarray() ? () : undef; - } - my $val = $r->{params}{$key}; - if (wantarray()) { - return ref $val ? @$val : $val; - } else { - return ref $val ? $val->[0] : $val; - } - } else { - return keys %{$r->{params}}; - } +# like CGI::param(), but read only +sub param +{ + my ($self, $key) = @_; + + return keys %{$self->params} unless defined $key; + + return unless exists $self->params->{$key}; + + my $val = $self->params->{$key}; + + return ref $val ? @$val : ($val) if wantarray; + + return ref $val ? $val->[0] : $val; } -sub get_template_root { "." } +sub get_template_root {'.'} sub get_request { } sub parse_location { @@ -275,6 +386,10 @@ You should not call this directly, but you may wish to override this to add application-specific initialisation. +=head3 new + +Constructs a very minimal new Maypole request object. + =head3 view_object Get/set the Maypole::View object @@ -374,9 +489,9 @@ or CGI request object, it defaults to blank. Returns a Maypole::Constant to indicate whether the request is valid. -The default implementation checks that C<$r-Etable> is publicly +The default implementation checks that C<$self-Etable> is publicly accessible -and that the model class is configured to handle the C<$r-Eaction> +and that the model class is configured to handle the C<$self-Eaction> =head3 authenticate @@ -404,7 +519,7 @@ Get/set a list of model objects. The objects will be accessible in the view templates. -If the first item in C<$r-Eargs> can be Cd by the model +If the first item in C<$self-Eargs> can be Cd by the model class, it will be removed from C and the retrieved object will be added to the @@ -412,14 +527,14 @@ C list. See L for more information. =head3 template_args - $r->template_args->{foo} = 'bar'; + $self->template_args->{foo} = 'bar'; Get/set a hash of template variables. =head3 template Get/set the template to be used by the view. By default, it returns -C<$r-Eaction> +C<$self-Eaction> =head3 exception @@ -473,7 +588,8 @@ exception method of your Maypole application. =head3 make_random_id -returns a unique id for this request can be used to prevent or detect repeat submissions. +returns a unique id for this request can be used to prevent or detect repeat +submissions. =head3 handler