X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=02ecadecea777e22da44581f75987b0aef5638fe;hb=78ca407e1a819f514cbb45f0dbd085411066ab54;hp=4633b1f2a508f114d528d1eb03db3b65dedaa4cb;hpb=a183ff6bda2ae98ef8f4a4f979647052e0020dea;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 4633b1f..02ecade 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -3,6 +3,7 @@ use base qw(Class::Accessor::Fast Class::Data::Inheritable); use UNIVERSAL::require; use strict; use warnings; +use Data::Dumper; use Maypole::Config; use Maypole::Constants; use Maypole::Headers; @@ -254,7 +255,7 @@ Some packages respond to higher debug levels, try increasing it to 2 or 3. =cut -sub debug { 0 } +sub debug { 1 } =item config @@ -274,7 +275,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, ... @@ -400,11 +401,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; } @@ -444,26 +450,22 @@ sub handler : method { # initialise the request $self->headers_out(Maypole::Headers->new); $self->get_request($req); + $self->parse_location; - + # hook useful for declining static requests e.g. images, or perhaps for # sanitizing request parameters $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; } @@ -478,18 +480,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; } @@ -558,17 +573,14 @@ sub handler_guts $self->__load_request_model; my $applicable = $self->is_model_applicable == OK; - - $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"; @@ -576,35 +588,33 @@ sub handler_guts $self->view_object->error($self, $error) : ERROR; } } - 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 $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; @@ -614,6 +624,7 @@ sub handler_guts $self->{content_type} ||= $self->__get_mime_type(); $self->{document_encoding} ||= "utf-8"; + return $processed_view_ok; } @@ -626,11 +637,14 @@ my %filetypes = ( sub __get_mime_type { my $self = shift; - my $type; + my $type = 'text/html'; if ($self->path =~ m/.*\.(\w{3,4})$/) { $type = $filetypes{$1}; } else { - $type = $mmagic->checktype_contents($self->output); + my $output = $self->output; + if (defined $output) { + $type = $mmagic->checktype_contents($output); + } } return $type; } @@ -638,16 +652,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 "\n***Warning: No $mclass class appropriate to set as request model : $@***\n" + } } + # 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); @@ -660,27 +682,24 @@ sub __setup_plain_template # 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, "view"); - - if ( $status != OK ) - { - warn "caught view error: $error" if $self->debug; - return $self->debug ? - $self->view_object->error($self, $error) : ERROR; - } +sub __call_process_view { + my ($self) = @_; + + my $status = eval { $self->view_object->process($self) }; + + my $error = $@ || $self->{error}; + + if ( $error ) { + $status = $self->call_exception($error, "view"); + + if ( $status != OK ) { + warn "caught view error: $error" if $self->debug; + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; } - - return $status; + } + + return $status; } =item get_request @@ -917,7 +936,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; } @@ -944,8 +963,6 @@ sub send_output { } - - =back =head2 Path processing and manipulation @@ -966,13 +983,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'); @@ -1135,6 +1151,24 @@ 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'; @@ -1143,7 +1177,7 @@ Get/set a hash of template variables. =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 @@ -1437,8 +1471,7 @@ L, L, L. =head1 AUTHOR -Maypole is currently maintained by Aaron Trevena, David Baird, Dave Howorth and -Peter Speltz. +Maypole is currently maintained by Aaron Trevena. =head1 AUTHOR EMERITUS