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