X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=587bdc7f56174babce89a7b31d69389bc598bbc0;hb=1ea25ed1ecc3c2baa71a985e8a94a55bb8f871f2;hp=55aa509c1f84def086eccc44ebabc10136a994e7;hpb=dc05783cf83b60a298f12e52ac6d67c489f35868;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index 55aa509..587bdc7 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -1,143 +1,233 @@ package Maypole; -use base qw(Class::Accessor Class::Data::Inheritable); -use attributes (); -use Class::DBI::Loader; +use base qw(Class::Accessor::Fast Class::Data::Inheritable); use UNIVERSAL::require; -use Apache::Constants ":common"; use strict; use warnings; -our $VERSION = "0.2"; +use Maypole::Config; +use Maypole::Constants; +use Maypole::Headers; + +our $VERSION = '2.10_pre2'; + __PACKAGE__->mk_classdata($_) for qw( config init_done view_object ); -__PACKAGE__->mk_accessors ( qw( ar params query objects model_class -args action template )); -__PACKAGE__->config({}); +__PACKAGE__->mk_accessors( + qw( ar params query objects model_class template_args output path + args action template error document_encoding content_type table + headers_in headers_out ) +); +__PACKAGE__->config( Maypole::Config->new() ); __PACKAGE__->init_done(0); +sub debug { 0 } -sub import { - my $real = shift; - if ($real ne "Apache::MVC") { +sub setup { + my $calling_class = shift; + $calling_class = ref $calling_class if ref $calling_class; + { no strict 'refs'; - *{$real."::handler"} = sub { Apache::MVC::handler($real, @_) }; - } -} + no warnings 'redefine'; -sub set_database { - my ($calling_class, $dsn) = @_; - $calling_class = ref $calling_class if ref $calling_class; + # Naughty. + *{ $calling_class . "::handler" } = + sub { Maypole::handler( $calling_class, @_ ) }; + } my $config = $calling_class->config; - $config->{model} ||= "Apache::MVC::Model::CDBI"; - $config->{model}->require; - $config->{dsn} = $dsn; - $config->{loader} = Class::DBI::Loader->new( - namespace => $calling_class, - dsn => $dsn - ); - $config->{classes} = [ $config->{loader}->classes ]; - for my $subclass (@{$config->{classes}}) { + $config->model || $config->model("Maypole::Model::CDBI"); + $config->model->require; + die "Couldn't load the model class $config->{model}: $@" if $@; + $config->model->setup_database( $config, $calling_class, @_ ); + for my $subclass ( @{ $config->classes } ) { no strict 'refs'; - unshift @{$subclass."::ISA"}, $config->{model}; - $config->{model}->adopt($subclass) - if $config->{model}->can("adopt"); + unshift @{ $subclass . "::ISA" }, $config->model; + $config->model->adopt($subclass) + if $config->model->can("adopt"); } } sub init { - my $class = shift; + my $class = shift; my $config = $class->config; - $config->{view} ||= "Apache::MVC::View::TT"; - $config->{view}->require; - $config->{display_tables} ||= [ $class->config->{loader}->tables ]; - $class->view_object($class->config->{view}->new); + $config->view || $config->view("Maypole::View::TT"); + $config->view->require; + die "Couldn't load the view class " . $config->view . ": $@" if $@; + $config->display_tables + || $config->display_tables( $class->config->tables ); + $class->view_object( $class->config->view->new ); $class->init_done(1); } -sub class_of { - my ($self, $table) = @_; - return $self->config->{loader}->_table2class($table); -} - sub handler { - # See Apache::MVC::Workflow before trying to understand this. - my $class = shift; + + # See Maypole::Workflow before trying to understand this. + my ( $class, $req ) = @_; $class->init unless $class->init_done; - my $r = bless { config => $class->config }, $class; - $r->get_request(); + + # Create the request object + my $r = bless { + template_args => {}, + config => $class->config + }, $class; + $r->headers_out(Maypole::Headers->new); + $r->get_request($req); $r->parse_location(); + my $status = $r->handler_guts(); + return $status unless $status == OK; + $r->send_output; + return $status; +} + +# The root of all evil +sub handler_guts { + my $r = shift; + $r->model_class( $r->config->model->class_of( $r, $r->{table} ) ); + + my $applicable = $r->is_applicable; + unless ( $applicable == OK ) { - $r->model_class($r->class_of($r->{table})); - my $status = $r->is_applicable; - if ($status == OK) { - $status = $r->call_authenticate; - return $status unless $status == OK; - $r->additional_data(); - - $r->model_class->process($r); - } else { - # Otherwise, it's just a plain template. + # It's just a plain template delete $r->{model_class}; - $r->{path} =~ s{/}{}; # De-absolutify - $r->template($r->{path}); + $r->{path} =~ s{/$}{}; # De-absolutify + $r->template( $r->{path} ); + } + + # We authenticate every request, needed for proper session management + my $status; + eval { $status = $r->call_authenticate }; + if ( my $error = $@ ) { + $status = $r->call_exception($error); + if ( $status != OK ) { + warn "caught authenticate error: $error"; + return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + } + } + 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 ) { + eval { $r->model_class->process($r) }; + if ( my $error = $@ ) { + $status = $r->call_exception($error); + if ( $status != OK ) { + warn "caught model error: $error"; + return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + } + } } - return $r->view_object->process($r); + if ( !$r->{output} ) { # You might want to do it yourself + eval { $status = $r->view_object->process($r) }; + if ( my $error = $@ ) { + $status = $r->call_exception($error); + if ( $status != OK ) { + warn "caught view error: $error" if $r->debug; + return $r->debug ? $r->view_object->error( $r, $error ) : ERROR; + } + } + return $status; + } + else { return OK; } } -sub get_request { - my $self = shift; - require Apache; require Apache::Request; - $self->{ar} = Apache::Request->new(Apache->request); +sub is_applicable { + my $self = shift; + my $config = $self->config; + $config->ok_tables || $config->ok_tables( $config->display_tables ); + $config->ok_tables( { map { $_ => 1 } @{ $config->ok_tables } } ) + if ref $config->ok_tables eq "ARRAY"; + warn "We don't have that table ($self->{table}).\n" + . "Available tables are: " + . join( ",", @{ $config->{display_tables} } ) + if $self->debug + and not $config->ok_tables->{ $self->{table} } + and $self->{action}; + return DECLINED() unless exists $config->ok_tables->{ $self->{table} }; + + # Is it public? + return DECLINED unless $self->model_class->is_public( $self->{action} ); + return OK(); } -sub parse_location { +sub call_authenticate { my $self = shift; - $self->{path} = $self->{ar}->uri; - my $loc = $self->{ar}->location; - $self->{path} =~ s/^$loc//; # I shouldn't need to do this? - $self->{path} ||= "frontpage"; - my @pi = split /\//, $self->{path}; - shift @pi while @pi and !$pi[0]; - $self->{table} = shift @pi; - $self->{action} = shift @pi; - $self->{args} = \@pi; - $self->{params} = { $self->{ar}->content }; - $self->{query} = { $self->{ar}->args }; + # 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 } -sub is_applicable { +sub call_exception { my $self = shift; - my $config = $self->config; - $config->{ok_tables} = {map {$_ => 1} @{$config->{display_tables}}}; - warn "We don't have that table ($self->{table})" - unless $config->{ok_tables}{$self->{table}}; - return DECLINED() unless exists $config->{ok_tables}{$self->{table}}; - - # Does the action method exist? - my $cv = $self->model_class->can($self->{action}); - warn "We don't have that action ($self->{action})" unless $cv; - return DECLINED() unless $cv; - - # Is it exported? - $self->{method_attribs} = join " ", attributes::get($cv); - do { warn "$self->{action} not exported"; - return DECLINED() - } unless $self->{method_attribs} =~ /\bExported\b/i; - return OK(); + my ($error) = @_; + + # Check if we have a model class + if ( $self->{model_class} + && $self->model_class->can('exception') ) + { + my $status = $self->model_class->exception( $self, $error ); + return $status if $status == OK; + } + return $self->exception($error); } -sub call_authenticate { +sub additional_data { } + +sub authenticate { return OK } + +sub exception { return ERROR } + +sub parse_path { my $self = shift; - return $self->model_class->authenticate($self) if - $self->model_class->can("authenticate"); - return $self->authenticate(); + $self->{path} ||= "frontpage"; + my @pi = $self->{path} =~ m{([^/]+)/?}g; + $self->{table} = shift @pi; + $self->{action} = shift @pi; + $self->{action} ||= "index"; + $self->{args} = \@pi; } -sub additional_data {} +sub param { # like CGI::param(), but read-only + my $r = shift; + my ($key) = @_; + if (defined $key) { + unless (exists $r->{params}{$key}) { + return wantarray() ? () : undef; + } + my $val = $r->{params}{$key}; + if (wantarray()) { + return ref $val ? @$val : $val; + } else { + return ref $val ? $val->[0] : $val; + } + } else { + return keys %{$r->{params}}; + } +} -sub authenticate { return OK } +sub get_template_root { "." } +sub get_request { } -1; +sub parse_location { + die "Do not use Maypole directly; use Apache::MVC or similar"; +} + +sub send_output { + die "Do not use Maypole directly; use Apache::MVC or similar"; +} + +# Session and Repeat Submission Handling + +sub make_random_id { + use Maypole::Session; + return Maypole::Session::generate_unique_id(); +} =head1 NAME @@ -145,111 +235,284 @@ Maypole - MVC web application framework =head1 SYNOPSIS -See L. +See L. =head1 DESCRIPTION -A large number of web programming tasks follow the same sort of pattern: -we have some data in a datasource, typically a relational database. We -have a bunch of templates provided by web designers. We have a number of -things we want to be able to do with the database - create, add, edit, -delete records, view records, run searches, and so on. We have a web -server which provides input from the user about what to do. Something in -the middle takes the input, grabs the relevant rows from the database, -performs the action, constructs a page, and spits it out. - -Maypole aims to be the most generic and extensible "something in the -middle" - an MVC-based web application framework. - -An example would help explain this best. You need to add a product -catalogue to a company's web site. Users need to list the products in -various categories, view a page on each product with its photo and -pricing information and so on, and there needs to be a back-end where -sales staff can add new lines, change prices, and delete out of date -records. So, you set up the database, provide some default templates -for the designers to customize, and then write an Apache handler like -this: - - package ProductDatabase; - use base 'Apache::MVC'; - __PACKAGE__->set_database("dbi:mysql:products"); - BeerDB->config->{uri_base} = "http://your.site/catalogue/"; - ProductDatabase::Product->has_a("category" => ProductDatabase::Category); - # ... - - sub authenticate { - my ($self, $request) = @_; - return OK if $request->{ar}->get_remote_host() eq "sales.yourcorp.com"; - return OK if $request->{action} =~ /^(view|list)$/; - return DECLINED; - } - 1; +This documents the Maypole request object. See the L, for a +detailed guide to using Maypole. -You then put the following in your Apache config: +Maypole is a Perl web application framework similar to Java's struts. It is +essentially completely abstracted, and so doesn't know anything about +how to talk to the outside world. - - SetHandler perl-script - PerlHandler ProductDatabase - +To use it, you need to create a package which represents your entire +application. In our example above, this is the C package. -And 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 needs to first use L which will make your package +inherit from the appropriate platform driver such as C or +C, and then call setup. This sets up the model classes and +configures your application. The default model class for Maypole uses +L to map a database to classes, but this can be changed by altering +configuration. (B calling setup.) -This will automatically give you C, C, C, C and -C commands; for instance, a product list, go to +=head2 CLASS METHODS - http://your.site/catalogue/product/list +=head3 config -For a full example, see the included "beer database" application. +Returns the L object -=head1 HOW IT WORKS +=head3 setup -There's some documentation for the workflow in L, -but the basic idea is that a URL part like C gets -translated into a call to Clist>. This -propagates the request with a set of objects from the database, and then -calls the C template; first, a C template if it -exists, then the C and finally C. + My::App->setup($data_source, $user, $password, \%attr); -If there's another action you want the system to do, you need to either -subclass the model class, and configure your class slightly differently: +Initialise the maypole application and model classes. Your application should +call this after setting configuration via L<"config"> - package ProductDatabase::Model; - use base 'Apache::MVC::Model::CDBI'; +=head3 init - sub supersearch :Exported { - my ($self, $request) = @_; - # Do stuff, get a bunch of objects back - $r->objects(\@objects); - $r->template("template_name"); - } +You should not call this directly, but you may wish to override this to +add +application-specific initialisation. + +=head3 view_object + +Get/set the Maypole::View object + +=head3 debug + + sub My::App::debug {1} + +Returns the debugging flag. Override this in your application class to +enable/disable debugging. + +=head2 INSTANCE METHODS + +=head3 parse_location + +Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a +Maypole +request. It does this by setting the C, and invoking C +and +C. + +You should only need to define this method if you are writing a new +Maypole +backend. + +=head3 path + +Returns the request path + +=head3 parse_path + +Parses the request path and sets the C, C and C +properties + +=head3 table + +The table part of the Maypole request path + +=head3 action + +The action part of the Maypole request path - ProductDatabase->config->{model_class} = "ProductDatabase::Model"; +=head3 args -(The C<:Exported> attribute means that the method can be called via the -URL C/supersearch/...>.) +A list of remaining parts of the request path after table and action +have been +removed -Alternatively, you can put the method directly into the specific model -class for the table: +=head3 headers_in - sub ProductDatabase::Product::supersearch :Exported { ... } +A L object containing HTTP headers for the request -By default, the view class uses Template Toolkit as the template -processor, and the model class uses C; it may help you to be -familiar with these modules before going much further with this, -although I expect there to be other subclasses for other templating -systems and database abstraction layers as time goes on. The article at -C is a great -introduction to the process we're trying to automate. +=head3 headers_out + +A L object that contains HTTP headers for the output + +=head3 parse_args + +Turns post data and query string paramaters into a hash of C. + +You should only need to define this method if you are writing a new +Maypole +backend. + +=head3 param + +An accessor for request parameters. It behaves similarly to CGI::param() for +accessing CGI parameters. + +=head3 params + +Returns a hash of request parameters. The source of the parameters may vary +depending on the Maypole backend, but they are usually populated from request +query string and POST data. + +B Where muliple values of a parameter were supplied, the +C +value +will be an array reference. + +=head3 get_template_root + +Implementation-specific path to template root. + +You should only need to define this method if you are writing a new +Maypole +backend. Otherwise, see L + +=head3 get_request + +You should only need to define this method if you are writing a new +Maypole backend. It should return something that looks like an Apache +or CGI request object, it defaults to blank. + + +=head3 is_applicable + +Returns a Maypole::Constant to indicate whether the request is valid. + +The default implementation checks that C<$r-Etable> is publicly +accessible +and that the model class is configured to handle the C<$r-Eaction> + +=head3 authenticate + +Returns a Maypole::Constant to indicate whether the user is +authenticated for +the Maypole request. + +The default implementation returns C + +=head3 model_class + +Returns the perl package name that will serve as the model for the +request. It corresponds to the request C
attribute. + +=head3 additional_data + +Called before the model processes the request, this method gives you a +chance +to do some processing for each request, for example, manipulating +C. + +=head3 objects + +Get/set a list of model objects. The objects will be accessible in the +view +templates. + +If the first item in C<$r-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. + +=head3 template_args + + $r->template_args->{foo} = 'bar'; + +Get/set a hash of template variables. + +=head3 template + +Get/set the template to be used by the view. By default, it returns +C<$r-Eaction> + +=head3 exception + +This method is called if any exceptions are raised during the +authentication +or +model/view processing. It should accept the exception as a parameter and +return +a Maypole::Constant to indicate whether the request should continue to +be +processed. + +=head3 error + +Get/set a request error + +=head3 output + +Get/set the response output. This is usually populated by the view +class. You +can skip view processing by setting the C. + +=head3 document_encoding + +Get/set the output encoding. Default: utf-8. + +=head3 content_type + +Get/set the output content type. Default: text/html + +=head3 send_output + +Sends the output and additional headers to the user. + +=head3 call_authenticate + +This method first checks if the relevant model class +can authenticate the user, or falls back to the default +authenticate method of your Maypole application. + + +=head3 call_exception + +This model is called to catch exceptions, first after authenticate, then after +processing the model class, and finally to check for exceptions from the view +class. + +This method first checks if the relevant model class +can handle exceptions the user, or falls back to the default +exception method of your Maypole application. + +=head3 make_random_id + +returns a unique id for this request can be used to prevent or detect repeat submissions. + +=head3 handler + +This method sets up the class if it's not done yet, sets some +defaults and leaves the dirty work to handler_guts. + +=head3 handler_guts + +This is the core of maypole. You don't want to know. + +=head1 SEE ALSO + +There's more documentation, examples, and a information on our mailing lists +at the Maypole web site: + +L + +L, L, L. =head1 AUTHOR -Simon Cozens, C +Maypole is currently maintained by Simon Flack C + +=head1 AUTHOR EMERITUS + +Simon Cozens, C + +Sebastian Riedel, C maintained Maypole from 1.99_01 to 2.04 + +=head1 THANKS TO + +Sebastian Riedel, Danijel Milicevic, Dave Slack, Jesse Sheidlower, Jody Belka, +Marcus Ramberg, Mickael Joanne, Randal Schwartz, Simon Flack, Steve Simms, +Veljko Vidovic and all the others who've helped. =head1 LICENSE You may distribute this code under the same terms as Perl itself. + +=cut + +1;