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