From d09e000fc977211b8bd1a77285a952421b60aa7a Mon Sep 17 00:00:00 2001 From: Simon Cozens Date: Wed, 11 Feb 2004 14:39:11 +0000 Subject: [PATCH] Move everything to Maypole. git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@54 48953598-375a-da11-a14b-00016c27c3ee --- lib/Maypole/Model/Base.pm | 102 +++++++++++++++++++ lib/Maypole/Model/CDBI.pm | 102 +++++++++++++++++++ lib/Maypole/View/TT.pm | 82 ++++++++++++++++ lib/Maypole/Workflow.pod | 200 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 486 insertions(+) create mode 100644 lib/Maypole/Model/Base.pm create mode 100644 lib/Maypole/Model/CDBI.pm create mode 100644 lib/Maypole/View/TT.pm create mode 100644 lib/Maypole/Workflow.pod diff --git a/lib/Maypole/Model/Base.pm b/lib/Maypole/Model/Base.pm new file mode 100644 index 0000000..908a2fc --- /dev/null +++ b/lib/Maypole/Model/Base.pm @@ -0,0 +1,102 @@ +package Apache::MVC::Model::Base; +our %remember; +sub MODIFY_CODE_ATTRIBUTES { $remember{$_[1]} = $_[2]; () } + +sub FETCH_CODE_ATTRIBUTES { $remember{$_[1]} } +sub view :Exported { } +sub edit :Exported { } + +sub process { + my ($class, $r) = @_; + $r->template( my $method = $r->action ); + $r->objects([ $class->retrieve(shift @{$r->{args}}) ]); + $class->$method($r); +} + +=head1 NAME + +Apache::MVC::Model::Base - Base class for model classes + +=head1 DESCRIPTION + +Anyone subclassing this for a different database abstraction mechanism +needs to provide the following methods: + +=head2 do_edit + +If there is an object in C<$r-Eobjects>, then it should be edited +with the parameters in C<$r-Eparams>; otherwise, a new object should +be created with those parameters, and put back into C<$r-Eobjects>. +The template should be changed to C, or C if there were any +errors. A hash of errors will be passed to the template. + +=cut + +sub do_edit { die "This is an abstract method" } + +=head2 retrieve + +This turns an ID into an object of the appropriate class. + +=head2 adopt + +This is called on an model class representing a table and allows the +master model class to do any set-up required. + +=head2 related + +This can go either in the master model class or in the individual +classes, and returns a list of has-many accessors. A brewery has many +beers, so C needs to return C. + +=head2 columns + +This is a list of the columns in a table. + +=head2 table + +This is the name of the table. + +=head2 Commands + +=over + +=item list + +The C method should fill C<< $r-> objects >> with all of the +objects in the class. You may want to page this using C or +similar. + +=back + +=cut + +sub list :Exported { die "This is an abstract method" }; + +=pod + +Also, see the exported commands in C. + +=head1 Other overrides + +Additionally, individual derived model classes may want to override the +following methods: + +=head2 column_names + +Return a hash mapping column names with human-readable equivalents. + +=cut + +sub column_names { my $class = shift; map { $_ => ucfirst $_ } $class->columns } + +=head2 description + +A description of the class to be passed to the template. + +=cut + +sub description { "A poorly defined class" } + +1; + diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm new file mode 100644 index 0000000..2d2aa2b --- /dev/null +++ b/lib/Maypole/Model/CDBI.pm @@ -0,0 +1,102 @@ +package Apache::MVC::Model::CDBI; +use base qw(Apache::MVC::Model::Base Class::DBI); +use Lingua::EN::Inflect::Number qw(to_PL); +use Class::DBI::AsForm; +use Class::DBI::FromCGI; +use Class::DBI::AbstractSearch; +use Class::DBI::Plugin::RetrieveAll; +use Class::DBI::Pager; +use CGI::Untaint; +use strict; + +=head1 NAME + +Apache::MVC::Model::CDBI - Model class based on Class::DBI + +=head1 DESCRIPTION + +This is a master model class which uses C to do all the hard +work of fetching rows and representing them as objects. It is a good +model to copy if you're replacing it with other database abstraction +modules. + +=cut + +sub related { + my ($self, $r) = @_; + # Has-many methods; XXX this is a hack + map {to_PL($_)} + grep { exists $r->{config}{ok_tables}{$_} } + map {$_->table} + keys %{shift->__hasa_list || {}} +} + +sub do_edit :Exported { + my ($self, $r) = @_; + my $h = CGI::Untaint->new(%{$r->{params}}); + my ($obj) = @{$r->objects}; + if ($obj) { + # We have something to edit + $obj->update_from_cgi($h); + warn "Updating an object ($obj) with ".Dumper($h); use Data::Dumper; + } else { + $obj = $self->create_from_cgi($h); + } + if (my %errors = $obj->cgi_update_errors) { + # Set it up as it was: + warn "There were errors: ".Dumper(\%errors)."\n"; + $r->{template_args}{cgi_params} = $r->{params}; + $r->{template_args}{errors} = \%errors; + $r->{template} = "edit"; + } else { + $r->{template} = "view"; + } + $r->objects([ $obj ]); +} + +sub delete :Exported { + my ($self, $r) = @_; + $_->SUPER::delete for @{ $r->objects }; + $r->objects([ $self->retrieve_all ]); + $r->{template} = "list"; +} + +sub adopt { + my ($self, $child) = @_; + $child->autoupdate(1); + $child->columns( Stringify => qw/ name / ); +} + +sub search :Exported { + return shift->SUPER::search(@_) if caller eq "Class::DBI"; # oops + my ($self, $r) = @_; + my %fields = map {$_ => 1 } $self->columns; + my $oper = "like"; # For now + use Carp; Carp::confess("Urgh") unless ref $r; + my %params = %{$r->{params}}; + my %values = map { $_ => {$oper, $params{$_} } } + grep { $params{$_} and $fields{$_} } keys %params; + + $r->objects([ %values ? $self->search_where(%values) : $self->retrieve_all ]); + $r->template("list"); + $r->{template_args}{search} = 1; +} + +sub list :Exported { + my ($self, $r) = @_; + my %ok_columns = map {$_ => 1} $self->columns; + if ( my $rows = $r->config->{rows_per_page}) { + $self = $self->pager($rows, $r->query->{page}); + $r->{template_args}{pager} = $self; + } + my $order; + if ($order = $r->query->{order} and $ok_columns{$order}) { + $r->objects([ $self->retrieve_all_sorted_by( $order. + ($r->query->{o2} eq "desc" && " DESC") + )]); + } else { + $r->objects([ $self->retrieve_all ]); + } +} +1; + diff --git a/lib/Maypole/View/TT.pm b/lib/Maypole/View/TT.pm new file mode 100644 index 0000000..babd0f4 --- /dev/null +++ b/lib/Maypole/View/TT.pm @@ -0,0 +1,82 @@ +package Apache::MVC::View::TT; +use Apache::Constants; +use Lingua::EN::Inflect; +use Template; +use File::Spec; +use UNIVERSAL::moniker; +use strict; + + +sub new { bless {}, shift } # Not worth having + +sub _tt { + my ($self, $r) = @_; + my $root = $r->{ar}->document_root . "/". $r->{ar}->location; + warn "Root was $root"; + Template->new({ INCLUDE_PATH => [ + $root, + ($r->model_class && File::Spec->catdir($root, $r->model_class->moniker)), + File::Spec->catdir($root, "custom"), + File::Spec->catdir($root, "factory") + ]}); +} + +sub _args { + my ($self, $r) = @_; + my $class = $r->model_class; + my %args = ( + request => $r, + objects => $r->objects, + base => $r->config->{uri_base}, + config => $r->config + # ... + ) ; + if ($class) { + $args{classmetadata} = { + name => $class, + columns => [ $class->columns ], + colnames => { $class->column_names }, + related_accessors => [ $class->related($r) ], + moniker => $class->moniker, + plural => $class->plural_moniker, + cgi => { $class->to_cgi }, + description => $class->description + }; + + # User-friendliness facility for custom template writers. + if (@{$r->objects || []} > 1) { + $args{$r->model_class->plural_moniker} = $r->objects; + } else { + ($args{$r->model_class->moniker}) = @{$r->objects}; + } + } + + # Overrides + %args = (%args, %{$r->{template_args}||{}}); + %args; +} + +sub process { + my ($self, $r) = @_; + my $template = $self->_tt($r); + my $output; + $template->process($r->template, { $self->_args($r) }, \$output) + || return $self->error($r, $template->error); + + $r->{ar}->content_type("text/html"); + $r->{ar}->headers_out->set("Content-Length" => length $output); + $r->{ar}->send_http_header; + $r->{ar}->print($output); + return 200; +} + +sub error { + my ($self, $r, $error) = @_; + warn $error; + if ($error =~ /not found$/) { return DECLINED } + $r->{ar}->send_http_header("text/plain"); + $r->{ar}->print($error); + exit; +} + +1; diff --git a/lib/Maypole/Workflow.pod b/lib/Maypole/Workflow.pod new file mode 100644 index 0000000..15d87c0 --- /dev/null +++ b/lib/Maypole/Workflow.pod @@ -0,0 +1,200 @@ +=pod + +=head1 NAME + +Apache::MVC::Workflow - Describes the progress of a request through Apache::MVC + +=head1 SYNOPSIS + + config $h + | + Apache::MVC $r + Apache::Request | + +---- $r->get_request ---+ + $ar | + | + $r->parse_location + | + $r->is_applicable + | + BeerDB::Beer $r->call_authenticate + ->authenticate ------------+------------ $r->authenticate + | + $r->additional_data + | + $r->model_class->process($r) + | + $r->view_object->process($r) + + +=head1 DESCRIPTION + +An application based on C will provide an Apache handler, +and eventually deliver a page. This document explains how that happens, +and how to influence it. We'll use the C project as our example. + +=head2 Initialize class + +When the first request comes in, the class will call its own +C method. This creates a new view object, sets up inheritance +relationships between the model classes and their parent, and so on. + +=head2 Construction + +Once we have initialized, the handler obtains the configuration for your +class, and puts it into a new object. We'll call this a request +I for the purposes of this document; it will be a new C +object. + +=head2 Getting the request + +Next, the handler calls C on the new object to have it +store a copy of the C. Of course, if you're not using +Apache, you might want to subclass this method to return something that +looks like an C object, and possibly also subclass the +next stage too to get more control over what methods are called on your +C-lookalike. C is expected to put the object in the +C slot of the request object. + +=head2 Handling the URL + +Typically, the details of the request will be passed in the URL. This is +done with the C method, which is expected to populate +several slots of the request object. First, C and C +should be populated with the name of the table and the action parts of +the URL. Any other arguments should be placed in a listref in the +C slot, and GET and POST parameters should be arranged into a hash +and placed in the C and C slots, respectively. + +Some people may not like the idea of passing everything around in the +URL; this is the method to override for you. Of course, you'll also need +to provide your own default templates to construct links using your +preferred format. + +=head2 Is this an applicable URL? + +Next, the C method works out if this is actually +something that C should care about - whether the class +exists in the application, whether it supports the given action, and so +on. The action is "supported" if it exists in the model class (or its +ancestors) and is marked with the C<:Exported> attribute; this stops web +users from firing off random subroutines in your code. + +This should return an Apache status code; C if the request should +proceed, C if it should be passed on to the default handlers, +or whatever other codes for permissions problems. + +=head2 Are we allowed to do this? + +We then look for an appropriate C method to call; first +it will try calling the C method of the model class, or, +if that does not exist, the C method on itself. By +default, this allows access to everyone for everything. Similarly, this +should return an Apache status code. + +=head2 Add any additional data to the request + +The open-ended C method allows any additional fiddling +with the request object before it is despatched. Specifically, it allows +you to add to the C slot, which is a hash of arguments to +be added to the template. + +=head2 Ask model for widget set + +Asking the model class to C the current request allows it to do +any work it needs for the given command, and populate the C and +C