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