X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole.pm;h=e3a92524a8f4a2d52bf458b0dc3c48f183f8b2d6;hb=e1058b36db231a58f819075b0e5658a872e94f11;hp=deb207193303e6f3366caed0786f78f8ce83fdbf;hpb=2317e7e16027c6fa312dbdff201d83084412a463;p=maypole.git diff --git a/lib/Maypole.pm b/lib/Maypole.pm index deb2071..e3a9252 100644 --- a/lib/Maypole.pm +++ b/lib/Maypole.pm @@ -2,23 +2,30 @@ package Maypole; use base qw(Class::Accessor Class::Data::Inheritable); use attributes (); use UNIVERSAL::require; -use Apache::Constants ":common"; use strict; use warnings; -our $VERSION = "0.2"; +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 )); __PACKAGE__->config({}); __PACKAGE__->init_done(0); +use Maypole::Constants; +sub debug { 0 } -sub set_database { +sub setup { my $calling_class = shift; $calling_class = ref $calling_class if ref $calling_class; + { + no strict 'refs'; + # Naughty. + *{$calling_class."::handler"} = sub { Maypole::handler($calling_class, @_) }; + } my $config = $calling_class->config; $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'; @@ -33,6 +40,7 @@ sub init { my $config = $class->config; $config->{view} ||= "Maypole::View::TT"; $config->{view}->require; + die "Couldn't load the view class $config->{view}: $@" if $@; $config->{display_tables} ||= [ @{$class->config->{tables}} ]; $class->view_object($class->config->{view}->new); $class->init_done(1); @@ -46,62 +54,58 @@ sub handler { my $r = bless { config => $class->config }, $class; $r->get_request(); $r->parse_location(); + my $status = $r->handler_guts(); + return $status unless $status == OK; + $r->send_output; + return $status; +} +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; - 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}); } - return $r->view_object->process($r); -} - -sub get_request { - my $self = shift; - require Apache; require Apache::Request; - $self->{ar} = Apache::Request->new(Apache->request); -} - -sub parse_location { - 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 }; + # 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; } } sub is_applicable { my $self = shift; my $config = $self->config; - $config->{ok_tables} = {map {$_ => 1} @{$config->{display_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})" - unless $config->{ok_tables}{$self->{table}}; + if $self->debug and not $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; + warn "We don't have that action ($self->{action})" + if $self->debug and not $cv; return DECLINED() unless $cv; # Is it exported? $self->{method_attribs} = join " ", attributes::get($cv); - do { warn "$self->{action} not exported"; + do { warn "$self->{action} not exported" if $self->debug; return DECLINED() } unless $self->{method_attribs} =~ /\bExported\b/i; return OK(); @@ -109,16 +113,27 @@ sub is_applicable { sub call_authenticate { my $self = shift; - return $self->model_class->authenticate($self) if - $self->model_class->can("authenticate"); - return $self->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 } sub additional_data {} sub authenticate { return OK } -1; +sub parse_path { + my $self = shift; + $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; +} =head1 NAME @@ -152,9 +167,9 @@ for the designers to customize, and then write an Apache handler like this: package ProductDatabase; - use base 'Maypole'; + use base 'Apache::MVC'; __PACKAGE__->set_database("dbi:mysql:products"); - BeerDB->config->{uri_base} = "http://your.site/catalogue/"; + ProductDatabase->config->{uri_base} = "http://your.site/catalogue/"; ProductDatabase::Product->has_a("category" => ProductDatabase::Category); # ... @@ -209,7 +224,10 @@ subclass the model class, and configure your class slightly differently: $r->template("template_name"); } - ProductDatabase->config->{model_class} = "ProductDatabase::Model"; +Then your top-level application package should change the model class: +(Before calling C) + + ProductDatabase->config->{model} = "ProductDatabase::Model"; (The C<:Exported> attribute means that the method can be called via the URL C/supersearch/...>.) @@ -227,10 +245,50 @@ 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. +=head1 USING MAYPOLE + +You should probably not use Maypole directly. Maypole is an abstract +class which does not specify how to communicate with the outside world. +The most popular subclass of Maypole is L, which interfaces +the Maypole framework to Apache mod_perl; another important one is +L. + +If you are implementing Maypole subclasses, you need to provide at least +the C and C methods. You may also want to +provide C and C. See the +L documentation for what these are expected to do. + +=cut + +sub get_template_root { "." } +sub get_request { } +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" } + +=head1 SEE ALSO + +There's more documentation, examples, and a wiki at the Maypole web site: + +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. + +=cut + +1;