From: Sebastian Riedel Date: Tue, 7 Sep 2004 19:31:24 +0000 (+0000) Subject: Apache2::MVC, Maypole::Application, parse_args() and much more... X-Git-Tag: 2.10~194 X-Git-Url: https://git.decadent.org.uk/gitweb/?p=maypole.git;a=commitdiff_plain;h=e1058b36db231a58f819075b0e5658a872e94f11 Apache2::MVC, Maypole::Application, parse_args() and much more... git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@168 48953598-375a-da11-a14b-00016c27c3ee --- diff --git a/Changes b/Changes index 94b1e43..ff7b9be 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,21 @@ Revision history for Perl extension Maypole +1.8 XXX XXX XX XX:XX:XX XXX XXXX + - Added parse_args() (Simon Flack) + - call additional_data() and authenticate() for plain templates + - added Apache2::MVC mod_perl2 front-end + - added Maypole::Application universal loader + - added Apache::MVC::Base base class for Apache front-ends + +1.7 Sat Jul 17 20:15:26 BST 2004 + - Emergency release - we lost the "use Maypole::Constants" from + CLI.pm somehow + +1.6 Fri Jul 16 23:51:21 BST 2004 + - Two very trivial fixes: + - Put ::Plain in the MANIFEST, so it actually ships this time + - Make CLI test == OK, not just true + 1.5 Mon Jun 21 14:36:54 BST 2004 - CLI mode correctly uses Constants module - Template footers as well as headers (Markus Ramberg) diff --git a/TODO b/TODO index 99a33ff..3444d0c 100644 --- a/TODO +++ b/TODO @@ -1,2 +1,2 @@ -TODO: -Write tests +See http://wiki.simon-cozens.org/?MaypoleToDo + diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index 21071de..5005eff 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,41 +1,24 @@ package Apache::MVC; -use base 'Maypole'; + +use base qw(Apache::MVC::Base Maypole); use Apache; use Apache::Request; use strict; use warnings; + our $VERSION = "0.3"; sub get_request { - shift->{ar} = Apache::Request->new(Apache->request); + shift->{ar} = Apache::Request->new( Apache->request ); } -sub parse_location { +sub parse_args { my $self = shift; - $self->{path} = $self->{ar}->uri; - my $loc = $self->{ar}->location; - no warnings 'uninitialized'; - $self->{path} =~ s/^($loc)?\///; - $self->parse_path; - $self->{params} = { $self->{ar}->content }; - while (my ($key, $value) = each %{$self->{params}}) { - $self->{params}{$key} = '' unless defined $value; + while ( my ( $key, $value ) = each %{ $self->{params} } ) { + $self->{params}{$key} = '' unless defined $value; } - $self->{query} = { $self->{ar}->args }; -} - -sub send_output { - my $r = shift; - $r->{ar}->content_type($r->{content_type}); - $r->{ar}->headers_out->set("Content-Length" => length $r->{output}); - $r->{ar}->send_http_header; - $r->{ar}->print($r->{output}); -} - -sub get_template_root { - my $r = shift; - $r->{ar}->document_root . "/". $r->{ar}->location; + $self->{query} = { $self->{ar}->args }; } 1; @@ -130,6 +113,7 @@ see L. =head1 AUTHOR Simon Cozens, C +Screwed up by Sebastian Riedel, C =head1 LICENSE diff --git a/lib/Apache/MVC/Base.pm b/lib/Apache/MVC/Base.pm new file mode 100644 index 0000000..996240d --- /dev/null +++ b/lib/Apache/MVC/Base.pm @@ -0,0 +1,50 @@ +package Apache::MVC::Base; + +use strict; +use warnings; + +sub parse_location { + my $self = shift; + $self->{path} = $self->{ar}->uri; + my $loc = $self->{ar}->location; + no warnings 'uninitialized'; + $self->{path} =~ s/^($loc)?\///; + $self->parse_path; + $self->parse_args; +} + +sub send_output { + my $r = shift; + $r->{ar}->content_type( $r->{content_type} ); + $r->{ar}->headers_out->set( "Content-Length" => length $r->{output} ); + $r->{ar}->send_http_header; + $r->{ar}->print( $r->{output} ); +} + +sub get_template_root { + my $r = shift; + $r->{ar}->document_root . "/" . $r->{ar}->location; +} + +1; + +=head1 NAME + +Apache::MVC::Base - Apache front-end base class + +=head1 SYNOPSIS + + use base 'Apache::Maypole::Base'; + +=head1 DESCRIPTION + +The base class for the Apache and Apache2 front-ends. + +=head1 AUTHOR + +Simon Cozens, C +Screwed up by Sebastian Riedel, C + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. diff --git a/lib/Apache2/MVC.pm b/lib/Apache2/MVC.pm new file mode 100644 index 0000000..2c6ceb7 --- /dev/null +++ b/lib/Apache2/MVC.pm @@ -0,0 +1,132 @@ +package Apache2::MVC; + +use base qw(Apache::MVC::Base Maypole); +use Apache2; +use Apache::RequestRec; +use Apache::RequestUtil; +use Apache::Request; +use APR::URI; +use strict; +use warnings; + +our $VERSION = "0.1"; + +sub get_request { + my ( $self, $r ) = @_; + $self->{ar} = Apache::Request->new($r); +} + +sub parse_args { + my $self = shift; + $self->{params} = { $self->_mod_perl_args( $self->{ar} ) }; + $self->{query} = { $self->_mod_perl_args( $self->{ar} ) }; +} + +sub _mod_perl_args { + my ( $self, $apr ) = @_; + my %args; + foreach my $key ( $apr->param ) { + my @values = $apr->param($key); + $args{$key} = @values == 1 ? $values[0] : \@values; + } + return %args; +} + +1; + +=head1 NAME + +Apache2::MVC - Apache2 front-end to Maypole + +=head1 SYNOPSIS + + package BeerDB; + use base 'Apache::MVC'; + BeerDB->setup("dbi:mysql:beerdb"); + BeerDB->config->{uri_base} = "http://your.site/"; + BeerDB->config->{display_tables} = [qw[beer brewery pub style]]; + # Now set up your database: + # has-a relationships + # untaint columns + + 1; + +=head1 DESCRIPTION + +Maypole is a Perl web application framework to Java's struts. It is +essentially completely abstracted, and so doesn't know anything about +how to talk to the outside world. C is a mod_perl2 based +subclass of Maypole. + +To use it, you need to create a package which represents your entire +application. In our example above, this is the C package. + +This needs to first inherit from C, and then call setup. +This will give your package an Apache-compatible C subroutine, +and then pass any parameters onto the C method of the +model class. The default model class for Maypole uses L to +map a database to classes, but this can be changed by messing with the +configuration. (B calling setup.) + +Next, you should configure your application through the C +method. Configuration parameters at present are: + +=over + +=item uri_base + +You B specify this; it is the base URI of the application, which +will be used to construct links. + +=item display_tables + +If you do not want all of the tables in the database to be accessible, +then set this to a list of only the ones you want to display + +=item rows_per_page + +List output is paged if you set this to a positive number of rows. + +=back + +You should also set up relationships between your classes, such that, +for instance, calling C on a C object returns an +object representing its associated brewery. + +For a full example, see the included "beer database" application. + +=head1 INSTALLATION + +Create a driver module like the one above. + +Put the following in your Apache config: + + + SetHandler perl-script + PerlHandler BeerDB + + +Copy the templates found in F into the +F directory off the web root. When the designers get +back to you with custom templates, they are to go in +F. If you need to do override templates on a +database-table-by-table basis, put the new template in +F>. + +This will automatically give you C, C, C, C and +C commands; for instance, a list of breweries, go to + + http://your.site/beer/brewery/list + +For more information about how the system works and how to extend it, +see L. + +=head1 AUTHOR + +Simon Cozens, C +Marcus Ramberg, C +Screwed up by Sebastian Riedel, C + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. diff --git a/lib/Maypole.pm b/lib/Maypole.pm index b55f7b9..e3a9252 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -4,7 +4,7 @@ use attributes (); use UNIVERSAL::require; use strict; use warnings; -our $VERSION = "1.7"; +our $VERSION = "1.8"; __PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); __PACKAGE__->mk_accessors ( qw( ar params query objects model_class args action template )); @@ -52,11 +52,10 @@ sub handler { my $class = shift; $class->init unless $class->init_done; my $r = bless { config => $class->config }, $class; - $r->get_request(@_); + $r->get_request(); $r->parse_location(); my $status = $r->handler_guts(); return $status unless $status == OK; - $r->{content_type} ||= "text/html"; $r->send_output; return $status; } @@ -64,23 +63,25 @@ sub handler { sub handler_guts { my $r = shift; $r->model_class($r->config->{model}->class_of($r, $r->{table})); - my $status = $r->is_applicable; - if ($status == OK) { - $status = $r->call_authenticate; - if ($r->debug and $status != OK and $status != DECLINED) { - $r->view_object->error($r, - "Got unexpected status $status from calling authentication"); - } - return $status unless $status == OK; - $r->additional_data(); - - $r->model_class->process($r); - } else { - # Otherwise, it's just a plain template. + my $applicable = $r->is_applicable; + unless ($applicable == OK) { + # It's just a plain template delete $r->{model_class}; $r->{path} =~ s{/}{}; # De-absolutify $r->template($r->{path}); } + # We authenticate every request, needed for proper session management + my $status = $r->call_authenticate; + if ($r->debug and $status != OK and $status != DECLINED) { + $r->view_object->error($r, + "Got unexpected status $status from calling authentication"); + } + return $status unless $status == OK; + # We run additional_data for every request + $r->additional_data; + if ($applicable == OK) { + $r->model_class->process($r); + } if (!$r->{output}) { # You might want to do it yourself return $r->view_object->process($r); } else { return OK; } @@ -112,8 +113,11 @@ sub is_applicable { sub call_authenticate { my $self = shift; - return $self->model_class->authenticate($self) if - $self->model_class->can("authenticate"); + # Check if we have a model class + if ($self->{model_class}) { + return $self->model_class->authenticate($self) if + $self->model_class->can("authenticate"); + } return $self->authenticate($self); # Interface consistency is a Good Thing } @@ -269,10 +273,18 @@ http://maypole.simon-cozens.org/ L, L. +=head1 MAINTAINER + +Sebastian Riedel, c + =head1 AUTHOR Simon Cozens, C +=head1 THANK YOU + +Jesse Scheildlower, Jody Belka, Markus Ramberg, Mickael Joanne, Simon Flack and all the others who've helped. + =head1 LICENSE You may distribute this code under the same terms as Perl itself. @@ -280,4 +292,3 @@ You may distribute this code under the same terms as Perl itself. =cut 1; - diff --git a/lib/Maypole/Application.pm b/lib/Maypole/Application.pm new file mode 100644 index 0000000..2727c9a --- /dev/null +++ b/lib/Maypole/Application.pm @@ -0,0 +1,43 @@ +package Maypole::Application; + +use strict; +use warnings; + +if ( $ENV{MOD_PERL} ) { + require mod_perl; + if ( $mod_perl::VERSION >= 1.99 ) { + require Apache2::MVC; + our @ISA = qw(Apache2::MVC); + } + else { + require Apache::MVC; + our @ISA = qw(Apache::MVC); + } +} +else { + require CGI::Maypole; + our @ISA = qw(CGI::Maypole); +} + +1; + +=head1 NAME + +Maypole::Application - all in wonder front-end + +=head1 SYNOPSIS + + use base 'Maypole::Application'; + +=head1 DESCRIPTION + +The all in wonder front-end. + +=head1 AUTHOR + +Sebastian Riedel, C +Idea by Marcus Ramberg, C + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself.