X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=b9a608518ff8d6d12ed46b0704f003293fe662a3;hb=32ecafee815b0fd8043c0acc2c785f5748fc20ff;hp=858c1eb608aa1dfa264b5e1206dedbad78399e9a;hpb=3ed98309a0852fc198f9e4d0e6f70c5510c8282f;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 858c1eb..b9a6085 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -1,4 +1,5 @@ package Maypole; +use Class::C3; use base qw(Class::Accessor::Fast Class::Data::Inheritable); use UNIVERSAL::require; use strict; @@ -12,7 +13,7 @@ use URI::QueryParam; use NEXT; use File::MMagic::XS qw(:compat); -our $VERSION = '2.11'; +our $VERSION = '2.12'; our $mmagic = File::MMagic::XS->new(); # proposed privacy conventions: @@ -35,6 +36,9 @@ The canonical example used in the Maypole documentation is the beer database: # choose a frontend, initialise the config object, and load a plugin use Maypole::Application qw/Relationship/; + + # set everything up + __PACKAGE__->setup("dbi:SQLite:t/beerdb.db"); # get the empty config object created by Maypole::Application my $config = __PACKAGE__->config; @@ -62,8 +66,8 @@ The canonical example used in the Maypole documentation is the beer database: date => [ qw/date/], ); - # set everything up - __PACKAGE__->setup("dbi:SQLite:t/beerdb.db"); + # note : set up model before calling this method + BeerDB::Beer->required_columns([qw/name/]); 1; @@ -91,7 +95,7 @@ configuration (B calling setup.) Note that some details in some of these resources may be out of date. -=over 4 +=over 4 =item The Maypole Manual @@ -120,7 +124,7 @@ may be out of date. =item Web applications with Maypole A tutorial written by Simon Cozens for YAPC::EU 2005 - -http://www.droogs.org/perl/maypole/maypole-tutorial.pdf [228KB]. +http://www.aarontrevena.co.uk/opensource/maypole/maypole-tutorial.pdf [228KB]. =item A Database-Driven Web Application in 18 Lines of Code @@ -148,7 +152,7 @@ http://www.perl.com/pub/a/2004/04/15/maypole.html =item Authentication Some notes written by Simon Cozens. A little bit out of date, but still -very useful: http://www.droogs.org/perl/maypole/authentication.html +very useful: http://www.aarontrevena.co.uk/opensource/maypole/authentication.html =item CheatSheet @@ -173,30 +177,6 @@ http://cpanratings.perl.org/dist/Maypole =back -=head1 DEMOS - -A couple of demos are available, sometimes with source code and configs. - -=over 4 - -=item http://maypole.perl.org/beerdb/ - -The standard BeerDB example, using the TT factory templates supplied in the -distribution. - -=item beerdb.riverside-cms.co.uk - -The standard BeerDB example, running on Mason, using the factory templates -supplied in the L distribution. - -=item beerfb.riverside-cms.co.uk - -A demo of L. This site is running on the set of Mason -templates included in the L distribution. See the -synopsis of L for an example driver - -=back - =cut __PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded); @@ -255,7 +235,7 @@ Some packages respond to higher debug levels, try increasing it to 2 or 3. =cut -sub debug { 1 } +sub debug { 0 } =item config @@ -275,7 +255,7 @@ documentation. However here is the most usage of setup where Maypole::Model::CDBI is the base class. My::App->setup($data_source, $user, $password, - { opitons => { # These are DB connection options + { options => { # These are DB connection options AutoCommit => 0, RaiseError => 1, ... @@ -320,14 +300,10 @@ sub setup_model { # among other things, this populates $config->classes $config->model->setup_database($config, $class, @_); - foreach my $subclass ( @{ $config->classes } ) { - next if $subclass->isa("Maypole::Model::Base"); - no strict 'refs'; - unshift @{ $subclass . "::ISA" }, $config->model; - } + $config->model->add_model_superclass($config); # Load custom model code, if it exists - nb this must happen after the - # unshift, to allow code attributes to work, but before adopt(), + # adding the model superclass, to allow code attributes to work, but before adopt(), # in case adopt() calls overridden methods on $subclass foreach my $subclass ( @{ $config->classes } ) { $class->load_model_subclass($subclass) unless ($class->model_classes_loaded()); @@ -401,12 +377,16 @@ Constructs a very minimal new Maypole request object. sub new { my ($class) = @_; - my $self = bless { - template_args => {}, config => $class->config, }, $class; - + + $self->stash({}); + $self->params({}); + $self->query({}); + $self->template_args({}); + $self->args([]); + $self->objects([]); return $self; } @@ -453,20 +433,14 @@ sub handler : method { $self->status(Maypole::Constants::OK()); # set the default $self->__call_hook('start_request_hook'); return $self->status unless $self->status == Maypole::Constants::OK(); - die "status undefined after start_request_hook()" unless defined $self->status; - $self->get_session; $self->get_user; - my $status = $self->handler_guts; - return $status unless $status == OK; - # TODO: require send_output to return a status code $self->send_output; - return $status; } @@ -481,18 +455,31 @@ request. You'll need to set up actions and templates which return fragments of HTML rather than entire pages, but once you've done that, you can use the C method of the Maypole request object to call those actions. You may pass a query string in the usual URL style. + You should not fully qualify the Maypole URLs. +Note: any HTTP POST or URL parameters passed to the parent are not passed to the +component sub-request, only what is included in the url passed as an argyument +to the method + =cut sub component { my ( $r, $path ) = @_; - my $self = bless { parent => $r }, ref $r; + my $self = bless { parent => $r, config => $r->{config}, } , ref $r; + $self->stash({}); + $self->params({}); + $self->query({}); + $self->template_args({}); + $self->args([]); + $self->objects([]); + + $self->get_user; my $url = URI->new($path); + warn "path : $path\n"; $self->{path} = $url->path; $self->parse_path; $self->params( $url->query_form_hash ); - $self->query( $r->params ); $self->handler_guts; return $self->output; } @@ -562,18 +549,13 @@ sub handler_guts my $applicable = $self->is_model_applicable == OK; - warn "applicable : $applicable"; - - $self->__setup_plain_template unless $applicable; - my $status; + # handle authentication eval { $status = $self->call_authenticate }; - if ( my $error = $@ ) { $status = $self->call_exception($error, "authentication"); - if ( $status != OK ) { warn "caught authenticate error: $error"; @@ -581,7 +563,6 @@ sub handler_guts $self->view_object->error($self, $error) : ERROR; } } - if ( $self->debug and $status != OK and $status != DECLINED ) { $self->view_object->error( $self, @@ -592,40 +573,32 @@ sub handler_guts # We run additional_data for every request $self->additional_data; - - if ($applicable) - { - eval { $self->model_class->process($self) }; - - if ( my $error = $@ ) + + if ($applicable) { + eval { $self->model_class->process($self) }; + if ( my $error = $@ ) { - $status = $self->call_exception($error, "model"); - - if ( $status != OK ) + $status = $self->call_exception($error, "model"); + if ( $status != OK ) { - warn "caught model error: $error"; - return $self->debug ? - $self->view_object->error($self, $error) : ERROR; + warn "caught model error: $error"; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } } + } else { + $self->__setup_plain_template; } - + # less frequent path - perhaps output has been set to an error message return OK if $self->output; - -# warn "output before processing view : ", $self->output; # normal path - no output has been generated yet my $processed_view_ok = $self->__call_process_view; - warn "output after processing view : ", $self->output; - - warn "error after processing view : ", $self->{error}; - $self->{content_type} ||= $self->__get_mime_type(); $self->{document_encoding} ||= "utf-8"; - warn "made it to end, processed_view_ok : $processed_view_ok"; return $processed_view_ok; } @@ -654,16 +627,24 @@ sub __get_mime_type { sub __load_request_model { my ($self) = @_; - $self->model_class( $self->config->model->class_of($self, $self->table) ); + # We may get a made up class from class_of + my $mclass = $self->config->model->class_of($self, $self->table); + if ( eval {$mclass->isa('Maypole::Model::Base')} ) { + $self->model_class( $mclass ); + } + elsif ($self->debug) { + warn "***Warning: No $mclass class appropriate for model. @_"; + } } + # 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); @@ -696,6 +677,20 @@ sub __call_process_view { return $status; } +=item warn + +$r->warn('its all gone pete tong'); + +Warn must be implemented by the backend, i.e. Apache::MVC +and warn to stderr or appropriate logfile. + +You can also over-ride this in your Maypole driver, should you +want to use something like Log::Log4perl instead. + +=cut + +sub warn { } + =item get_request You should only need to define this method if you are writing a new @@ -813,9 +808,9 @@ sub is_model_applicable { if (not $ok) { - warn "We don't have that table ($table).\n" + $self->warn ("We don't have that table ($table).\n" . "Available tables are: " - . join( ",", keys %$ok_tables ) + . join( ",", keys %$ok_tables )) if $self->debug and not $ok_tables->{$table}; return DECLINED; @@ -825,7 +820,7 @@ sub is_model_applicable { my $action = $self->action; return OK if $self->model_class->is_public($action); - warn "The action '$action' is not applicable to the table '$table'" + $self->warn("The action '$action' is not applicable to the table '$table'") if $self->debug; return DECLINED; @@ -930,7 +925,7 @@ processed. sub exception { my ($self, $error, $when) = @_; - if ($self->view_object->can("report_error") and $self->debug) { + if (ref $self->view_object && $self->view_object->can("report_error") and $self->debug) { $self->view_object->report_error($self, $error, $when); return OK; } @@ -957,8 +952,6 @@ sub send_output { } - - =back =head2 Path processing and manipulation @@ -979,13 +972,12 @@ properties. Calls C before parsing path and setting properties. sub parse_path { my ($self) = @_; - + # Previous versions unconditionally set table, action and args to whatever # was in @pi (or else to defaults, if @pi is empty). # Adding preprocess_path(), and then setting table, action and args # conditionally, broke lots of tests, hence this: $self->$_(undef) for qw/action table args/; - $self->preprocess_path; $self->path || $self->path('frontpage'); @@ -1148,15 +1140,38 @@ 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 C list. See L for more information. + +=item object + +Alias to get/set the first/only model object. The object will be accessible +in the view templates. + +When used to set the object, will overwrite the request objects +with a single object. + +=cut + +sub object { + my ($r,$object) = @_; + $r->objects([$object]) if ($object); + return undef unless $r->objects(); + return $r->objects->[0]; +} + =item template_args $self->template_args->{foo} = 'bar'; Get/set a hash of template variables. +Maypole reserved words for template variables will over-ride values in template_variables. + +Reserved words are : r, request, object, objects, base, config and errors, as well as the +current class or object name. + =item stash -A place to put custom application data. Not used by Maypole itself. +A place to put custom application data. Not used by Maypole itself. =item template