lib/Maypole.pm

   1 package Maypole;
   2 use base qw(Class::Accessor Class::Data::Inheritable);
   3 use attributes ();
   4 use UNIVERSAL::require;
   5 use strict;
   6 use warnings;
   7 our $VERSION = "1.2";
   8 __PACKAGE__->mk_classdata($_) for qw( config init_done view_object );
   9 __PACKAGE__->mk_accessors ( qw( ar params query objects model_class
  10 args action template ));
  11 __PACKAGE__->config({});
  12 __PACKAGE__->init_done(0);
  13
  14 # Ape Apache::Constants interface
  15 use constant OK => 0;
  16 use constant DECLINED => -1;
  17
  18 sub debug { 0 }
  19
  20 sub setup {
  21     my $calling_class = shift;
  22     $calling_class = ref $calling_class if ref $calling_class;
  23     {
  24       no strict 'refs';
  25       # Naughty.
  26       *{$calling_class."::handler"} = sub { Maypole::handler($calling_class, @_) };
  27     }
  28     my $config = $calling_class->config;
  29     $config->{model} ||= "Maypole::Model::CDBI";
  30     $config->{model}->require;
  31     $config->{model}->setup_database($config, $calling_class, @_);
  32     for my $subclass (@{$config->{classes}}) {
  33         no strict 'refs';
  34         unshift @{$subclass."::ISA"}, $config->{model};
  35         $config->{model}->adopt($subclass)
  36            if $config->{model}->can("adopt");
  37     }
  38 }
  39
  40 sub init {
  41     my $class = shift;
  42     my $config = $class->config;
  43     $config->{view}  ||= "Maypole::View::TT";
  44     $config->{view}->require;
  45     $config->{display_tables} ||= [ @{$class->config->{tables}} ];
  46     $class->view_object($class->config->{view}->new);
  47     $class->init_done(1);
  48
  49 }
  50
  51 sub handler {
  52     # See Maypole::Workflow before trying to understand this.
  53     my $class = shift;
  54     $class->init unless $class->init_done;
  55     my $r = bless { config => $class->config }, $class;
  56     $r->get_request();
  57     $r->parse_location();
  58
  59     $r->model_class($r->config->{model}->class_of($r, $r->{table}));
  60     my $status = $r->is_applicable;
  61     if ($status == OK) {
  62         $status = $r->call_authenticate;
  63         if ($r->debug and $status != OK and $status != DECLINED) {
  64             $r->view_object->error($r,
  65                 "Got unexpected status $status from calling authentication");
  66         }
  67         return $status unless $status == OK;
  68         $r->additional_data();
  69
  70         $r->model_class->process($r);
  71     } else {
  72         # Otherwise, it's just a plain template.
  73         $r->call_authenticate; # No harm in it
  74         delete $r->{model_class};
  75         $r->{path} =~ s{/}{}; # De-absolutify
  76         $r->template($r->{path});
  77     }
  78     $status = OK;
  79     if (!$r->{output}) { # You might want to do it yourself
  80         $status = $r->view_object->process($r);
  81     }
  82     $r->send_output;
  83     return $status;
  84 }
  85
  86 sub is_applicable {
  87     my $self = shift;
  88     my $config = $self->config;
  89     $config->{ok_tables} = {map {$_ => 1} @{$config->{display_tables}}};
  90     warn "We don't have that table ($self->{table})"
  91         if $self->debug and not $config->{ok_tables}{$self->{table}};
  92     return DECLINED() unless exists $config->{ok_tables}{$self->{table}};
  93
  94     # Does the action method exist?
  95     my $cv = $self->model_class->can($self->{action});
  96     warn "We don't have that action ($self->{action})"
  97         if $self->debug and not $cv;
  98     return DECLINED() unless $cv;
  99
 100     # Is it exported?
 101     $self->{method_attribs} = join " ", attributes::get($cv);
 102     do { warn "$self->{action} not exported" if $self->debug;
 103     return DECLINED()
 104      } unless $self->{method_attribs} =~ /\bExported\b/i;
 105     return OK();
 106 }
 107
 108 sub call_authenticate {
 109     my $self = shift;
 110     return $self->model_class->authenticate($self) if
 111         $self->model_class->can("authenticate");
 112     return $self->authenticate($self); # Interface consistency is a Good Thing
 113 }
 114
 115 sub additional_data {}
 116
 117 sub authenticate { return OK }
 118
 119 =head1 NAME
 120
 121 Maypole - MVC web application framework
 122
 123 =head1 SYNOPSIS
 124
 125 See L<Maypole>.
 126
 127 =head1 DESCRIPTION
 128
 129 A large number of web programming tasks follow the same sort of pattern:
 130 we have some data in a datasource, typically a relational database. We
 131 have a bunch of templates provided by web designers. We have a number of
 132 things we want to be able to do with the database - create, add, edit,
 133 delete records, view records, run searches, and so on. We have a web
 134 server which provides input from the user about what to do. Something in
 135 the middle takes the input, grabs the relevant rows from the database,
 136 performs the action, constructs a page, and spits it out.
 137
 138 Maypole aims to be the most generic and extensible "something in the
 139 middle" - an MVC-based web application framework.
 140
 141 An example would help explain this best. You need to add a product
 142 catalogue to a company's web site. Users need to list the products in
 143 various categories, view a page on each product with its photo and
 144 pricing information and so on, and there needs to be a back-end where
 145 sales staff can add new lines, change prices, and delete out of date
 146 records. So, you set up the database, provide some default templates
 147 for the designers to customize, and then write an Apache handler like
 148 this:
 149
 150     package ProductDatabase;
 151     use base 'Apache::MVC';
 152     __PACKAGE__->set_database("dbi:mysql:products");
 153     ProductDatabase->config->{uri_base} = "http://your.site/catalogue/";
 154     ProductDatabase::Product->has_a("category" => ProductDatabase::Category);
 155     # ...
 156
 157     sub authenticate {
 158         my ($self, $request) = @_;
 159         return OK if $request->{ar}->get_remote_host() eq "sales.yourcorp.com";
 160         return OK if $request->{action} =~ /^(view|list)$/;
 161         return DECLINED;
 162     }
 163     1;
 164
 165 You then put the following in your Apache config:
 166
 167     <Location /catalogue>
 168         SetHandler perl-script
 169         PerlHandler ProductDatabase
 170     </Location>
 171
 172 And copy the templates found in F<templates/factory> into the
 173 F<catalogue/factory> directory off the web root. When the designers get
 174 back to you with custom templates, they are to go in
 175 F<catalogue/custom>. If you need to do override templates on a
 176 database-table-by-table basis, put the new template in
 177 F<catalogue/I<table>>.
 178
 179 This will automatically give you C<add>, C<edit>, C<list>, C<view> and
 180 C<delete> commands; for instance, a product list, go to
 181
 182     http://your.site/catalogue/product/list
 183
 184 For a full example, see the included "beer database" application.
 185
 186 =head1 HOW IT WORKS
 187
 188 There's some documentation for the workflow in L<Maypole::Workflow>,
 189 but the basic idea is that a URL part like C<product/list> gets
 190 translated into a call to C<ProductDatabase::Product-E<gt>list>. This
 191 propagates the request with a set of objects from the database, and then
 192 calls the C<list> template; first, a C<product/list> template if it
 193 exists, then the C<custom/list> and finally C<factory/list>.
 194
 195 If there's another action you want the system to do, you need to either
 196 subclass the model class, and configure your class slightly differently:
 197
 198     package ProductDatabase::Model;
 199     use base 'Maypole::Model::CDBI';
 200
 201     sub supersearch :Exported {
 202         my ($self, $request) = @_;
 203         # Do stuff, get a bunch of objects back
 204         $r->objects(\@objects);
 205         $r->template("template_name");
 206     }
 207
 208 Then your top-level application package should change the model class:
 209 (Before calling C<setup>)
 210
 211     ProductDatabase->config->{model} = "ProductDatabase::Model";
 212
 213 (The C<:Exported> attribute means that the method can be called via the
 214 URL C</I<table>/supersearch/...>.)
 215
 216 Alternatively, you can put the method directly into the specific model
 217 class for the table:
 218
 219     sub ProductDatabase::Product::supersearch :Exported { ... }
 220
 221 By default, the view class uses Template Toolkit as the template
 222 processor, and the model class uses C<Class::DBI>; it may help you to be
 223 familiar with these modules before going much further with this,
 224 although I expect there to be other subclasses for other templating
 225 systems and database abstraction layers as time goes on. The article at
 226 C<http://www.perl.com/pub/a/2003/07/15/nocode.html> is a great
 227 introduction to the process we're trying to automate.
 228
 229 =head1 USING MAYPOLE
 230
 231 You should probably not use Maypole directly. Maypole is an abstract
 232 class which does not specify how to communicate with the outside world.
 233 The most popular subclass of Maypole is L<Apache::MVC>, which interfaces
 234 the Maypole framework to Apache mod_perl.
 235
 236 If you are implementing Maypole subclasses, you need to provide at least
 237 the C<parse_location> and C<send_output> methods. You may also want to
 238 provide C<get_request> and C<get_template_root>. See the
 239 L<Maypole::Workflow> documentation for what these are expected to do.
 240
 241 =cut
 242
 243 sub get_template_root { "." }
 244 sub get_request { }
 245 sub parse_location { die "Do not use Maypole directly; use Apache::MVC or similar" }
 246 sub send_output{ die "Do not use Maypole directly; use Apache::MVC or similar" }
 247
 248 =head1 SEE ALSO
 249
 250 There's more documentation, examples, and a wiki at the Maypole web site:
 251
 252 http://maypole.simon-cozens.org/
 253
 254 =head1 AUTHOR
 255
 256 Simon Cozens, C<simon@cpan.org>
 257
 258 =head1 LICENSE
 259
 260 You may distribute this code under the same terms as Perl itself.
 261
 262 =cut
 263
 264 1;
 265