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