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