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