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