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