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