X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FApache%2FMVC.pm;h=5d999be45e93d971dcb6a1586fef27cceb03b9d5;hb=b4c877459674a8da7943533c780f807f3a355906;hp=c9db3ae415008cf9dcf1613abdf95d90fe766515;hpb=ce6a4c9c85fd9ea388abc677089564bc46e687be;p=maypole.git diff --git a/lib/Apache/MVC.pm b/lib/Apache/MVC.pm index c9db3ae..5d999be 100644 --- a/lib/Apache/MVC.pm +++ b/lib/Apache/MVC.pm @@ -1,102 +1,13 @@ package Apache::MVC; -use base qw(Class::Accessor Class::Data::Inheritable); -use attributes (); -use Class::DBI::Loader; -use UNIVERSAL::require; -use Apache::Constants ":common"; +use base 'Maypole'; +use Apache; +use Apache::Request; use strict; use warnings; -our $VERSION = "0.1"; -__PACKAGE__->mk_classdata($_) for qw( _config init_done view_object ); -__PACKAGE__->mk_accessors ( qw( config ar params objects model_class -args action template )); -__PACKAGE__->config({}); -__PACKAGE__->init_done(0); - - -sub import { - my $real = shift; - if ($real ne "Apache::MVC") { - no strict 'refs'; - *{$real."::handler"} = sub { Apache::MVC::handler($real, @_) }; - } -} - -# This is really dirty. -sub config { - my $self = shift; - if (ref $self) { return $self->_config_accessor(@_) } - return $self->_config(@_); -} - -sub set_database { - my ($calling_class, $dsn) = @_; - $calling_class = ref $calling_class if ref $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}}) { - no strict 'refs'; - unshift @{$subclass."::ISA"}, $config->{model}; - $config->{model}->adopt($subclass) - if $config->{model}->can("adopt"); - } -} - -sub init { - 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); - $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; - $class->init unless $class->init_done; - my $r = bless { config => $class->config }, $class; - $r->get_request(); - $r->parse_location(); - - warn "Parsed location\n"; - $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 { - warn "Plain template $r->{path}"; - # Otherwise, it's just a plain template. - delete $r->{model_class}; - $r->{path} =~ s{/}{}; # De-absolutify - $r->template($r->{path}); - warn $r->template; - } - return $r->view_object->process($r); -} +our $VERSION = "0.3"; sub get_request { - my $self = shift; - require Apache; require Apache::Request; - $self->{ar} = Apache::Request->new(Apache->request); + shift->{ar} = Apache::Request->new(Apache->request); } sub parse_location { @@ -104,7 +15,7 @@ sub parse_location { $self->{path} = $self->{ar}->uri; my $loc = $self->{ar}->location; $self->{path} =~ s/^$loc//; # I shouldn't need to do this? - warn "Path is $self->{path}"; + $self->{path} ||= "frontpage"; my @pi = split /\//, $self->{path}; shift @pi while @pi and !$pi[0]; $self->{table} = shift @pi; @@ -112,40 +23,9 @@ sub parse_location { $self->{args} = \@pi; $self->{params} = { $self->{ar}->content }; + $self->{query} = { $self->{ar}->args }; } -sub is_applicable { - 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(); -} - -sub call_authenticate { - my $self = shift; - return $self->model_class->authenticate($self) if - $self->model_class->can("authenticate"); - return $self->authenticate(); -} - -sub additional_data {} - -sub authenticate { return OK } - 1; =head1 NAME @@ -166,7 +46,7 @@ Apache::MVC - Web front end to a data source 1; -=haed1 DESCRIPTION +=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 @@ -189,7 +69,86 @@ 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 MyCorp::ProductDatabase; + 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; + +You then put the following in your Apache config: + + + SetHandler perl-script + PerlHandler ProductDatabase + + +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 will automatically give you C, C, C, C and +C commands; for instance, a product list, go to + + http://your.site/catalogue/product/list + +For a full example, see the included "beer database" application. + +=head1 HOW IT WORKS + +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. + +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: + + package ProductDatabase::Model; + use base 'Apache::MVC::Model::CDBI'; + + sub supersearch :Exported { + my ($self, $request) = @_; + # Do stuff, get a bunch of objects back + $r->objects(\@objects); + $r->template("template_name"); + } + + ProductDatabase->config->{model_class} = "ProductDatabase::Model"; + +(The C<:Exported> attribute means that the method can be called via the +URL C/supersearch/...>.) + +Alternatively, you can put the method directly into the specific model +class for the table: + + sub ProductDatabase::Product::supersearch :Exported { ... } + +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. + +=head1 AUTHOR + +Simon Cozens, C + +=head1 LICENSE +You may distribute this code under the same terms as Perl itself.