X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=blobdiff_plain;f=lib%2FMaypole.pm;h=1a86f53ad515c57afb82fa1d1b381f0abcb10b54;hp=bc41335cd5758aa76565f18c8670f29f2f5acff9;hb=dd425b2cb6384f804cc1eea9e45660ed6baeb2f1;hpb=2c5d6782f89dc1532398b1b79c8f67b982c758ac diff --git a/lib/Maypole.pm b/lib/Maypole.pm index bc41335..1a86f53 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -1,5 +1,4 @@ package Maypole; -use Class::C3; use base qw(Class::Accessor::Fast Class::Data::Inheritable); use UNIVERSAL::require; use strict; @@ -13,7 +12,7 @@ use URI::QueryParam; use NEXT; use File::MMagic::XS qw(:compat); -our $VERSION = '2.12'; +our $VERSION = '2.13'; our $mmagic = File::MMagic::XS->new(); # proposed privacy conventions: @@ -184,10 +183,11 @@ __PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes __PACKAGE__->mk_accessors( qw( params query objects model_class template_args output path args action template error document_encoding content_type table - headers_in headers_out stash status parent build_form_elements) + headers_in headers_out stash status parent build_form_elements + user session) ); -__PACKAGE__->config( Maypole::Config->new() ); +__PACKAGE__->config( Maypole::Config->new({additional => { }, request_options => { }, view_options => { },}) ); __PACKAGE__->init_done(0); @@ -435,8 +435,12 @@ sub handler : method { 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 $session = $self->get_session; + $self->session($self->{session} || $session); + my $user = $self->get_user; + $self->user($self->{user} || $user); + my $status = $self->handler_guts; return $status unless $status == OK; # TODO: require send_output to return a status code @@ -459,7 +463,7 @@ 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 +component sub-request, only what is included in the url passed as an argument to the method =cut @@ -474,7 +478,9 @@ sub component { $self->args([]); $self->objects([]); - $self->get_user; + $self->session($self->get_session); + $self->user($self->get_user); + my $url = URI->new($path); $self->{path} = $url->path; $self->parse_path; @@ -567,14 +573,17 @@ sub handler_guts { # We run additional_data for every request $self->additional_data; + # process request with model if applicable and template not set. if ($applicable) { - eval { $self->model_class->process($self) }; - if ( my $error = $@ ) { - $status = $self->call_exception($error, "model"); - if ( $status != OK ) { - $self->warn("caught model error: $error"); - return $self->debug ? - $self->view_object->error($self, $error) : ERROR; + unless ($self->{template}) { + eval { $self->model_class->process($self) }; + if ( my $error = $@ ) { + $status = $self->call_exception($error, "model"); + if ( $status != OK ) { + $self->warn("caught model error: $error"); + return $self->debug ? + $self->view_object->error($self, $error) : ERROR; + } } } } else { @@ -582,7 +591,11 @@ sub handler_guts { } # less frequent path - perhaps output has been set to an error message - return OK if $self->output; + if ($self->output) { + $self->{content_type} ||= $self->__get_mime_type(); + $self->{document_encoding} ||= "utf-8"; + return OK; + } # normal path - no output has been generated yet my $processed_view_ok = $self->__call_process_view; @@ -603,7 +616,7 @@ my %filetypes = ( sub __get_mime_type { my $self = shift; my $type = 'text/html'; - if ($self->path =~ m/.*\.(\w{3,4})$/) { + if ($self->path =~ m/.*\.(\w{2,4})$/) { $type = $filetypes{$1}; } else { my $output = $self->output; @@ -636,15 +649,16 @@ sub __setup_plain_template my ($self) = @_; # It's just a plain template + $self->build_form_elements(0); $self->model_class(undef); - # FIXME: this is likely to be redundant and is definately causing problems. - - my $path = $self->path; - $path =~ s{/$}{}; # De-absolutify - $self->path($path); - - $self->template($self->path); + unless ($self->template) { + # FIXME: this is likely to be redundant and is definately causing problems. + 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), @@ -973,8 +987,7 @@ properties. Calls C before parsing path and setting properties. =cut -sub parse_path -{ +sub parse_path { my ($self) = @_; # Previous versions unconditionally set table, action and args to whatever @@ -999,19 +1012,32 @@ sub parse_path =item preprocess_path Sometimes when you don't want to rewrite or over-ride parse_path but -want to rewrite urls or extract data from them before it is parsed. +want to rewrite urls or extract data from them before it is parsed, +the preprocess_path/location methods allow you to munge paths and urls +before maypole maps them to actions, classes, etc. This method is called after parse_location has populated the request information and before parse_path has populated the model and action information, and is passed the request object. You can set action, args or table in this method and parse_path will -then leave those values in place or populate them if not present +then leave those values in place or populate them based on the current +value of the path attribute if they are not present. =cut sub preprocess_path { }; +=item preprocess_location + +This method is called at the start of parse_location, after the headers in, and allows you +to rewrite the url used by maypole, or dynamically set configuration +like the base_uri based on the hostname or path. + +=cut + +sub preprocess_location { }; + =item make_path( %args or \%args or @args ) This is the counterpart to C. It generates a path to use @@ -1035,6 +1061,7 @@ string. =cut + sub make_path { my $r = shift; @@ -1284,9 +1311,9 @@ sub param $self->params->{$key} = $new_val; } - return ref $val ? @$val : ($val) if wantarray; + return (ref $val eq 'ARRAY') ? @$val : ($val) if wantarray; - return ref $val ? $val->[0] : $val; + return (ref $val eq 'ARRAY') ? $val->[0] : $val; }