X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=2f609d8b0496b1838e5069b403e1f5273afcdc1b;hb=f19715f56244cc6d862169c2dd656b8a2f3845b5;hp=119a85a29127c9908581bfa6afb34b667d0bd5c9;hpb=a02686080acb66fce170e9657e110761b09e62a2;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 119a85a..2f609d8 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -6,9 +6,12 @@ use warnings; use Maypole::Config; use Maypole::Constants; use Maypole::Headers; +use Maypole::Components; use URI(); +use File::MMagic::XS qw(:compat); our $VERSION = '2.11'; +our $mmagic = File::MMagic::XS->new(); # proposed privacy conventions: # - no leading underscore - public to custom application code and plugins @@ -194,7 +197,7 @@ synopsis of L for an example driver =cut -__PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); +__PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded); __PACKAGE__->mk_accessors( qw( params query objects model_class template_args output path @@ -206,6 +209,8 @@ __PACKAGE__->config( Maypole::Config->new() ); __PACKAGE__->init_done(0); +__PACKAGE__->model_classes_loaded(0); + =head1 HOOKABLE METHODS As a framework, Maypole provides a number of B - methods that are @@ -306,15 +311,16 @@ sub setup_model foreach my $subclass ( @{ $config->classes } ) { - no strict 'refs'; - unshift @{ $subclass . "::ISA" }, $config->model; - - # Load custom model code, if it exists - nb this must happen after the - # unshift, to allow code attributes to work, but before adopt(), - # in case adopt() calls overridden methods on $subclass - $class->load_model_subclass($subclass); - - $config->model->adopt($subclass) if $config->model->can("adopt"); + next if $subclass->isa("Maypole::Model::Base"); + no strict 'refs'; + unshift @{ $subclass . "::ISA" }, $config->model; + + # Load custom model code, if it exists - nb this must happen after the + # unshift, to allow code attributes to work, but before adopt(), + # in case adopt() calls overridden methods on $subclass + $class->load_model_subclass($subclass) unless ($class->model_classes_loaded()); + + $config->model->adopt($subclass) if $config->model->can("adopt"); } } @@ -416,41 +422,46 @@ leaves the dirty work to C. # 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) = @_; +sub handler : method { + # See Maypole::Workflow before trying to understand this. + my ($class, $req) = @_; - $class->init unless $class->init_done; + $class->init unless $class->init_done; - my $self = $class->new; + my $self = $class->new; - # initialise the request - $self->headers_out(Maypole::Headers->new); - $self->get_request($req); - $self->parse_location; + # 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(); + # 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; + die "status undefined after start_request_hook()" unless defined + $self->status; - $self->get_session; - $self->get_user; + $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; + my $status = $self->handler_guts; + return $status unless $status == OK; - return $status; + # TODO: require send_output to return a status code + $self->send_output; + + return $status; +} + +sub component { + my $component = Maypole::Components->new(@_); + return $component->handler; } + # Instead of making plugin authors use the NEXT::DISTINCT hoopla to ensure other # plugins also get to call the hook, we can cycle through the application's # @ISA and call them all here. Doesn't work for setup() though, because it's @@ -550,9 +561,32 @@ sub handler_guts # 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; + my $processed_view_ok = $self->__call_process_view; + + $self->{content_type} ||= $self->__get_mime_type(); + $self->{document_encoding} ||= "utf-8"; + + return $processed_view_ok; +} + +my %filetypes = ( + 'js' => 'text/javascript', + 'css' => 'text/css', + 'htm' => 'text/html', + 'html' => 'text/html', + ); + +sub __get_mime_type { + my $self = shift; + my $type; + if ($self->path =~ m/.*\.(\w{3,4})$/) { + $type = $filetypes{$1}; + } else { + $type = $mmagic->checktype_contents($self->output); + } + return $type; } sub __load_request_model @@ -738,7 +772,7 @@ sub is_model_applicable return 1 if $self->model_class->is_public($action); warn "The action '$action' is not applicable to the table '$table'" - if $self->debug; + if $self->debug; return 0; }