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