From f19715f56244cc6d862169c2dd656b8a2f3845b5 Mon Sep 17 00:00:00 2001 From: Aaron Trevena Date: Wed, 11 Jan 2006 17:14:56 +0000 Subject: [PATCH] Fixed mime type setting, fixed errors in revision 445, folded in Maypole::Component as Maypole::Components git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@447 48953598-375a-da11-a14b-00016c27c3ee --- Changes | 2 + MANIFEST | 1 + META.yml | 3 +- Makefile.PL | 5 +- README | 6 +-- lib/Maypole.pm | 87 ++++++++++++++++++++++----------- lib/Maypole/Components.pm | 63 ++++++++++++++++++++++++ lib/Maypole/Model/Base.pm | 34 +++++++------ lib/Maypole/Model/CDBI.pm | 37 ++------------ lib/Maypole/Model/CDBI/Plain.pm | 2 +- lib/Maypole/View/Base.pm | 3 +- 11 files changed, 155 insertions(+), 88 deletions(-) create mode 100644 lib/Maypole/Components.pm diff --git a/Changes b/Changes index 2c36970..0792dae 100644 --- a/Changes +++ b/Changes @@ -40,6 +40,8 @@ API additions and enhancements: - added make_path() - added make_uri() - improved exception handling + - now uses File::MMagic::XS to guess mime type of output unless already set + - new component method provides Maypole::Component functionality Maypole::Model - do_delete, do_search in place of delete/search actions Maypole::View::TT: diff --git a/MANIFEST b/MANIFEST index a578fbb..e744e36 100644 --- a/MANIFEST +++ b/MANIFEST @@ -11,6 +11,7 @@ lib/Maypole/Config.pm lib/Maypole/Constants.pm lib/Maypole/Headers.pm lib/Maypole/Session.pm +lib/Maypole/Components.pm lib/Maypole/Manual.pod lib/Maypole/Manual/About.pod lib/Maypole/Manual/Install.pod diff --git a/META.yml b/META.yml index 8461737..1b91c7e 100644 --- a/META.yml +++ b/META.yml @@ -17,9 +17,8 @@ requires: Class::DBI::Plugin::RetrieveAll: 0 Class::DBI::SQLite: 0 Digest::MD5: 0 + HTTP::Body: 0.5 HTTP::Headers: 1.59 - HTTP::Server::Simple: 0.02 - HTTP::Server::Simple::Static: 0.01 Template: 0 Template::Plugin::Class: 0 Test::MockModule: 0 diff --git a/Makefile.PL b/Makefile.PL index e5833cb..37f3ad9 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -27,14 +27,15 @@ WriteMakefile( Template => 0, Template::Plugin::Class => 0, Test::MockModule => 0, - Digest::MD5 => 0, + Digest::MD5 => 0, + File::MMagic::XS => 0.08, }, # e.g., Module::Name => 1.1 ( $] >= 5.005 ? ## Add these new keywords supported since 5.005 ( ABSTRACT_FROM => 'lib/Maypole.pm', # retrieve abstract from module - AUTHOR => 'Simon flack ' + AUTHOR => 'Aaron TEEJAY Trevena ' ) : () ), diff --git a/README b/README index c8d7503..c4721a4 100644 --- a/README +++ b/README @@ -3,9 +3,9 @@ NAME DESCRIPTION Maypole is a Perl framework for MVC-oriented web applications, similar - to Jakarta's Struts. Maypole is designed to minimize coding requirements - for creating simple web interfaces to databases, while remaining flexible - enough to support enterprise web applications. + to Jakarta's Struts or Ruby on Rails. Maypole is designed to minimize + coding requirements for creating simple web interfaces to databases, + while remaining flexible enough to support enterprise web applications. QUICK START Maypole ships with a basic demo application, the Beer Database. diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 5d3e259..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 @@ -419,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; - - # initialise the request - $self->headers_out(Maypole::Headers->new); - $self->get_request($req); - $self->parse_location; + my $self = $class->new; - # 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(); + # initialise the request + $self->headers_out(Maypole::Headers->new); + $self->get_request($req); + $self->parse_location; - die "status undefined after start_request_hook()" unless defined - $self->status; + # 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(); - $self->get_session; - $self->get_user; + die "status undefined after start_request_hook()" unless defined + $self->status; - my $status = $self->handler_guts; - return $status unless $status == OK; + $self->get_session; + $self->get_user; - # 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 @@ -553,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 @@ -741,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; } diff --git a/lib/Maypole/Components.pm b/lib/Maypole/Components.pm new file mode 100644 index 0000000..b679e8d --- /dev/null +++ b/lib/Maypole/Components.pm @@ -0,0 +1,63 @@ +package Maypole::Components; +use base 'Maypole'; +use strict; +use warnings; +use URI; +use URI::QueryParam; + +sub new { + my ($class,$r, $path) = @_; + my $self = bless { config => $r->config, parent => $r }, $class; +} + +sub handler { + my $self = shift; + my $url = URI->new($path); + $self->{path} = $url->path; + $self->parse_path; + $self->{query} = $url->query_form_hash; + $self->handler_guts; + return $self->{output}; +} + +sub get_template_root { shift->{parent}->get_template_root } +sub view_object { shift->{parent}->view_object } + +1; +__END__ + +=head1 NAME + +Maypole::Components - Run Maypole sub-requests as components + +=head1 SYNOPSIS + + package BeerDB; + use base qw(Maypole); + + + + [% request.component("/beer/view_as_component/20") %] + +=head1 DESCRIPTION + +This subclass of Maypole allows you to integrate the results of a Maypole +request into an existing 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. + +=head1 SEE ALSO + +http://maypole.perl.org/ + +=head1 AUTHOR + +Simon Cozens, Esimon@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004 by Simon Cozens + +=cut diff --git a/lib/Maypole/Model/Base.pm b/lib/Maypole/Model/Base.pm index 338f0e8..de33ac9 100644 --- a/lib/Maypole/Model/Base.pm +++ b/lib/Maypole/Model/Base.pm @@ -189,19 +189,22 @@ Defaults to checking if the sub has the C<:Exported> attribute. =cut -sub is_public -{ - my ($self, $action) = @_; - - my %attrs = map {$_ => 1} $self->method_attrs($action); - - return 1 if $attrs{Exported}; - - warn "'$action' not exported"; - - return 0; +sub is_public { + my ( $self, $action, $attrs ) = @_; + my $cv = $self->can($action); + warn "is_public failed . action is $action. self is $self" and return 0 unless $cv; + + my %attrs = (ref $attrs) ? %$attrs : map {$_ => 1} $self->method_attrs($action,$cv) ; + + do { + warn "is_public failed. $action not exported. attributes are : ", %attrs; + return 0; + } unless $attrs{Exported}; + return 1; } + + =head2 method_attrs Returns the list of attributes defined for a method. Maypole itself only @@ -209,16 +212,15 @@ defines the C attribute. =cut -sub method_attrs -{ - my ($class, $method) = @_; +sub method_attrs { + my ($class, $method, $cv) = @_; - my $cv = $class->can($method); + $cv ||= $class->can($method); return unless $cv; my @attrs = attributes::get($cv); - + return @attrs; } diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm index dd9af06..a5c65f6 100644 --- a/lib/Maypole/Model/CDBI.pm +++ b/lib/Maypole/Model/CDBI.pm @@ -29,7 +29,7 @@ use Class::DBI::Plugin::RetrieveAll; use Class::DBI::Pager; use Lingua::EN::Inflect::Number qw(to_PL); - +use attributes (); ############################################################################### # Helper methods @@ -301,29 +301,6 @@ sub adopt { } } -=head2 is_public - -Should return true if a certain action is supported, or false otherwise. -Defaults to checking if the sub has the C<:Exported> attribute. - -=cut - -sub is_public { - my ( $self, $action, $attrs ) = @_; - my $cv = $self->can($action); - warn "is_public failed . action is $action. self is $self" and return 0 unless $cv; - unless ($attrs) { - my @attrs = attributes::get($cv) || (); - $attrs = join " ", @attrs; - } - do { - warn "is_public failed .$action not exported" if Maypole->debug; - return 0; - } unless $attrs =~ /\bExported\b/i; - return 1; -} - - =head2 is_class Tell if action is a class method (See Maypole::Plugin::Menu) @@ -333,7 +310,7 @@ Tell if action is a class method (See Maypole::Plugin::Menu) sub is_class { my ( $self, $method, $attrs ) = @_; die "Usage: method must be passed as first arg" unless $method; - $attrs = $self->method_attrs($method) unless ($attrs); + $attrs = join(' ',$self->method_attrs($method)) unless ($attrs); return 1 if $attrs =~ /\bClass\b/i; return 1 if $method =~ /^list$/; # default class actions return 0; @@ -348,20 +325,12 @@ Tell if action is a object method (See Maypole::Plugin::Menu) sub is_object { my ( $self, $method, $attrs ) = @_; die "Usage: method must be passed as first arg" unless $method; - $attrs = $self->method_attrs($method) unless ($attrs); + $attrs = join(' ',$self->method_attrs($method)) unless ($attrs); return 1 if $attrs =~ /\bObject\b/i; return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions return 0; } -# Get string of joined attributes for matching -sub method_attrs { - my ($class, $method) = @_; - my $cv = $class->can($method); - return 0 unless $cv; - my @attrs = attributes::get($cv) || (); - return join " ", @attrs; -} =head2 related diff --git a/lib/Maypole/Model/CDBI/Plain.pm b/lib/Maypole/Model/CDBI/Plain.pm index b76cff3..9f149ed 100644 --- a/lib/Maypole/Model/CDBI/Plain.pm +++ b/lib/Maypole/Model/CDBI/Plain.pm @@ -10,7 +10,7 @@ Maypole::Config->mk_accessors(qw(table_to_class)); sub setup_database { my ( $self, $config, $namespace, $classes ) = @_; $config->{classes} = $classes; - foreach my $class (@$classes) { $namespace->load_model_subclass(); } + foreach my $class (@$classes) { $namespace->load_model_subclass($class); } $namespace->model_classes_loaded(1); $config->{table_to_class} = { map { $_->table => $_ } @$classes }; $config->{tables} = [ keys %{ $config->{table_to_class} } ]; diff --git a/lib/Maypole/View/Base.pm b/lib/Maypole/View/Base.pm index afba7a0..ece5d98 100644 --- a/lib/Maypole/View/Base.pm +++ b/lib/Maypole/View/Base.pm @@ -25,6 +25,7 @@ sub paths { push(@output, File::Spec->catdir( $path, "custom" )); push(@output, File::Spec->catdir( $path, "factory" )); } + return @output; } @@ -73,8 +74,6 @@ sub vars { sub process { my ( $self, $r ) = @_; - $r->{content_type} ||= "text/html"; - $r->{document_encoding} ||= "utf-8"; my $status = $self->template($r); return $self->error($r) if $status != OK; return OK; -- 2.39.2