lib/Maypole.pm

   1 package Maypole;
   2 use base qw(Class::Accessor::Fast Class::Data::Inheritable);
   3 use UNIVERSAL::require;
   4 use strict;
   5 use warnings;
   6 use Maypole::Config;
   7 use Maypole::Constants;
   8 use Maypole::Headers;
   9
  10 our $VERSION = '2.10';
  11
  12 __PACKAGE__->mk_classdata($_) for qw( config init_done view_object );
  13 __PACKAGE__->mk_accessors(
  14     qw( params query objects model_class template_args output path
  15         args action template error document_encoding content_type table
  16         headers_in headers_out )
  17 );
  18 __PACKAGE__->config( Maypole::Config->new() );
  19 __PACKAGE__->init_done(0);
  20
  21 sub debug { 0 }
  22
  23 sub setup
  24 {
  25     my $calling_class = shift;
  26
  27     $calling_class = ref $calling_class if ref $calling_class;
  28
  29     my $config = $calling_class->config;
  30
  31     $config->model || $config->model('Maypole::Model::CDBI');
  32
  33     $config->model->require or die
  34         "Couldn't load the model class $config->{model}: $@";
  35
  36     $config->model->setup_database($config, $calling_class, @_);
  37
  38     foreach my $subclass ( @{ $config->classes } )
  39     {
  40         no strict 'refs';
  41         unshift @{ $subclass . "::ISA" }, $config->model;
  42         $config->model->adopt($subclass)
  43           if $config->model->can("adopt");
  44     }
  45 }
  46
  47 sub init
  48 {
  49     my $class  = shift;
  50     my $config = $class->config;
  51     $config->view || $config->view("Maypole::View::TT");
  52     $config->view->require;
  53     die "Couldn't load the view class " . $config->view . ": $@" if $@;
  54     $config->display_tables
  55       || $config->display_tables( $class->config->tables );
  56     $class->view_object( $class->config->view->new );
  57     $class->init_done(1);
  58
  59 }
  60
  61 # handler() has a method attribute so that mod_perl will invoke
  62 # BeerDB->handler() as a method rather than a plain function
  63 # BeerDB::handler() and so this inherited implementation will be
  64 # found. See e.g. "Practical mod_perl"  by Bekman & Cholet for
  65 # more information <http://modperlbook.org/html/ch25_01.html>
  66 sub handler : method
  67 {
  68     # See Maypole::Workflow before trying to understand this.
  69     my ($class, $req) = @_;
  70
  71     $class->init unless $class->init_done;
  72
  73     # Create the request object
  74     my $r = bless {
  75         template_args => {},
  76         config        => $class->config
  77     }, $class;
  78     $r->headers_out(Maypole::Headers->new);
  79     $r->get_request($req);
  80     $r->parse_location();
  81     my $status = $r->handler_guts();
  82     return $status unless $status == OK;
  83     $r->send_output;
  84     return $status;
  85 }
  86
  87 # The root of all evil
  88 sub handler_guts {
  89     my $r = shift;
  90     $r->model_class( $r->config->model->class_of( $r, $r->{table} ) );
  91
  92     my $applicable = $r->is_applicable;
  93     unless ( $applicable == OK ) {
  94
  95         # It's just a plain template
  96         delete $r->{model_class};
  97         $r->{path} =~ s{/$}{};    # De-absolutify
  98         $r->template( $r->{path} );
  99     }
 100
 101     # We authenticate every request, needed for proper session management
 102     my $status;
 103     eval { $status = $r->call_authenticate };
 104     if ( my $error = $@ ) {
 105         $status = $r->call_exception($error);
 106         if ( $status != OK ) {
 107             warn "caught authenticate error: $error";
 108             return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
 109         }
 110     }
 111     if ( $r->debug and $status != OK and $status != DECLINED ) {
 112         $r->view_object->error( $r,
 113             "Got unexpected status $status from calling authentication" );
 114     }
 115     return $status unless $status == OK;
 116
 117     # We run additional_data for every request
 118     $r->additional_data;
 119     if ( $applicable == OK ) {
 120         eval { $r->model_class->process($r) };
 121         if ( my $error = $@ ) {
 122             $status = $r->call_exception($error);
 123             if ( $status != OK ) {
 124                 warn "caught model error: $error";
 125                 return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
 126             }
 127         }
 128     }
 129     if ( !$r->{output} ) {    # You might want to do it yourself
 130         eval { $status = $r->view_object->process($r) };
 131         if ( my $error = $@ ) {
 132             $status = $r->call_exception($error);
 133             if ( $status != OK ) {
 134                 warn "caught view error: $error" if $r->debug;
 135                 return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
 136             }
 137         }
 138         return $status;
 139     }
 140     else { return OK; }
 141 }
 142
 143 sub is_applicable {
 144     my $self   = shift;
 145     my $config = $self->config;
 146     $config->ok_tables || $config->ok_tables( $config->display_tables );
 147     $config->ok_tables( { map { $_ => 1 } @{ $config->ok_tables } } )
 148       if ref $config->ok_tables eq "ARRAY";
 149     warn "We don't have that table ($self->{table}).\n"
 150       . "Available tables are: "
 151       . join( ",", @{ $config->{display_tables} } )
 152       if $self->debug
 153       and not $config->ok_tables->{ $self->{table} }
 154       and $self->{action};
 155     return DECLINED() unless exists $config->ok_tables->{ $self->{table} };
 156
 157     # Is it public?
 158     return DECLINED unless $self->model_class->is_public( $self->{action} );
 159     return OK();
 160 }
 161
 162 sub call_authenticate {
 163     my $self = shift;
 164
 165     # Check if we have a model class
 166     if ( $self->{model_class} ) {
 167         return $self->model_class->authenticate($self)
 168           if $self->model_class->can("authenticate");
 169     }
 170     return $self->authenticate($self);   # Interface consistency is a Good Thing
 171 }
 172
 173 sub call_exception {
 174     my $self = shift;
 175     my ($error) = @_;
 176
 177     # Check if we have a model class
 178     if (   $self->{model_class}
 179         && $self->model_class->can('exception') )
 180     {
 181         my $status = $self->model_class->exception( $self, $error );
 182         return $status if $status == OK;
 183     }
 184     return $self->exception($error);
 185 }
 186
 187 sub additional_data { }
 188
 189 sub authenticate { return OK }
 190
 191 sub exception { return ERROR }
 192
 193 sub parse_path {
 194     my $self = shift;
 195     $self->{path} ||= "frontpage";
 196     my @pi = $self->{path} =~ m{([^/]+)/?}g;
 197     $self->{table}  = shift @pi;
 198     $self->{action} = shift @pi;
 199     $self->{action} ||= "index";
 200     $self->{args}   = \@pi;
 201 }
 202
 203 sub param { # like CGI::param(), but read-only
 204     my $r = shift;
 205     my ($key) = @_;
 206     if (defined $key) {
 207         unless (exists $r->{params}{$key}) {
 208             return wantarray() ? () : undef;
 209         }
 210         my $val = $r->{params}{$key};
 211         if (wantarray()) {
 212             return ref $val ? @$val : $val;
 213         } else {
 214             return ref $val ? $val->[0] : $val;
 215         }
 216     } else {
 217         return keys %{$r->{params}};
 218     }
 219 }
 220
 221 sub get_template_root { "." }
 222 sub get_request       { }
 223
 224 sub parse_location {
 225     die "Do not use Maypole directly; use Apache::MVC or similar";
 226 }
 227
 228 sub send_output {
 229     die "Do not use Maypole directly; use Apache::MVC or similar";
 230 }
 231
 232 # Session and Repeat Submission Handling
 233
 234 sub make_random_id {
 235     use Maypole::Session;
 236     return Maypole::Session::generate_unique_id();
 237 }
 238
 239 =head1 NAME
 240
 241 Maypole - MVC web application framework
 242
 243 =head1 SYNOPSIS
 244
 245 See L<Maypole::Application>.
 246
 247 =head1 DESCRIPTION
 248
 249 This documents the Maypole request object. See the L<Maypole::Manual>, for a
 250 detailed guide to using Maypole.
 251
 252 Maypole is a Perl web application framework similar to Java's struts. It is
 253 essentially completely abstracted, and so doesn't know anything about
 254 how to talk to the outside world.
 255
 256 To use it, you need to create a package which represents your entire
 257 application. In our example above, this is the C<BeerDB> package.
 258
 259 This needs to first use L<Maypole::Application> which will make your package
 260 inherit from the appropriate platform driver such as C<Apache::MVC> or
 261 C<CGI::Maypole>, and then call setup.  This sets up the model classes and
 262 configures your application. The default model class for Maypole uses
 263 L<Class::DBI> to map a database to classes, but this can be changed by altering
 264 configuration. (B<Before> calling setup.)
 265
 266 =head2 CLASS METHODS
 267
 268 =head3 config
 269
 270 Returns the L<Maypole::Config> object
 271
 272 =head3 setup
 273
 274     My::App->setup($data_source, $user, $password, \%attr);
 275
 276 Initialise the maypole application and model classes. Your application should
 277 call this after setting configuration via L<"config">
 278
 279 =head3 init
 280
 281 You should not call this directly, but you may wish to override this to
 282 add
 283 application-specific initialisation.
 284
 285 =head3 view_object
 286
 287 Get/set the Maypole::View object
 288
 289 =head3 debug
 290
 291     sub My::App::debug {1}
 292
 293 Returns the debugging flag. Override this in your application class to
 294 enable/disable debugging.
 295
 296 =head2 INSTANCE METHODS
 297
 298 =head3 parse_location
 299
 300 Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a
 301 Maypole
 302 request. It does this by setting the C<path>, and invoking C<parse_path>
 303 and
 304 C<parse_args>.
 305
 306 You should only need to define this method if you are writing a new
 307 Maypole
 308 backend.
 309
 310 =head3 path
 311
 312 Returns the request path
 313
 314 =head3 parse_path
 315
 316 Parses the request path and sets the C<args>, C<action> and C<table>
 317 properties
 318
 319 =head3 table
 320
 321 The table part of the Maypole request path
 322
 323 =head3 action
 324
 325 The action part of the Maypole request path
 326
 327 =head3 args
 328
 329 A list of remaining parts of the request path after table and action
 330 have been
 331 removed
 332
 333 =head3 headers_in
 334
 335 A L<Maypole::Headers> object containing HTTP headers for the request
 336
 337 =head3 headers_out
 338
 339 A L<HTTP::Headers> object that contains HTTP headers for the output
 340
 341 =head3 parse_args
 342
 343 Turns post data and query string paramaters into a hash of C<params>.
 344
 345 You should only need to define this method if you are writing a new
 346 Maypole
 347 backend.
 348
 349 =head3 param
 350
 351 An accessor for request parameters. It behaves similarly to CGI::param() for
 352 accessing CGI parameters.
 353
 354 =head3 params
 355
 356 Returns a hash of request parameters. The source of the parameters may vary
 357 depending on the Maypole backend, but they are usually populated from request
 358 query string and POST data.
 359
 360 B<Note:> Where muliple values of a parameter were supplied, the
 361 C<params>
 362 value
 363 will be an array reference.
 364
 365 =head3 get_template_root
 366
 367 Implementation-specific path to template root.
 368
 369 You should only need to define this method if you are writing a new
 370 Maypole
 371 backend. Otherwise, see L<Maypole::Config/"template_root">
 372
 373 =head3 get_request
 374
 375 You should only need to define this method if you are writing a new
 376 Maypole backend. It should return something that looks like an Apache
 377 or CGI request object, it defaults to blank.
 378
 379
 380 =head3 is_applicable
 381
 382 Returns a Maypole::Constant to indicate whether the request is valid.
 383
 384 The default implementation checks that C<$r-E<gt>table> is publicly
 385 accessible
 386 and that the model class is configured to handle the C<$r-E<gt>action>
 387
 388 =head3 authenticate
 389
 390 Returns a Maypole::Constant to indicate whether the user is
 391 authenticated for
 392 the Maypole request.
 393
 394 The default implementation returns C<OK>
 395
 396 =head3 model_class
 397
 398 Returns the perl package name that will serve as the model for the
 399 request. It corresponds to the request C<table> attribute.
 400
 401 =head3 additional_data
 402
 403 Called before the model processes the request, this method gives you a
 404 chance
 405 to do some processing for each request, for example, manipulating
 406 C<template_args>.
 407
 408 =head3 objects
 409
 410 Get/set a list of model objects. The objects will be accessible in the
 411 view
 412 templates.
 413
 414 If the first item in C<$r-E<gt>args> can be C<retrieve()>d by the model
 415 class,
 416 it will be removed from C<args> and the retrieved object will be added
 417 to the
 418 C<objects> list. See L<Maypole::Model> for more information.
 419
 420 =head3 template_args
 421
 422     $r->template_args->{foo} = 'bar';
 423
 424 Get/set a hash of template variables.
 425
 426 =head3 template
 427
 428 Get/set the template to be used by the view. By default, it returns
 429 C<$r-E<gt>action>
 430
 431 =head3 exception
 432
 433 This method is called if any exceptions are raised during the
 434 authentication
 435 or
 436 model/view processing. It should accept the exception as a parameter and
 437 return
 438 a Maypole::Constant to indicate whether the request should continue to
 439 be
 440 processed.
 441
 442 =head3 error
 443
 444 Get/set a request error
 445
 446 =head3 output
 447
 448 Get/set the response output. This is usually populated by the view
 449 class. You
 450 can skip view processing by setting the C<output>.
 451
 452 =head3 document_encoding
 453
 454 Get/set the output encoding. Default: utf-8.
 455
 456 =head3 content_type
 457
 458 Get/set the output content type. Default: text/html
 459
 460 =head3 send_output
 461
 462 Sends the output and additional headers to the user.
 463
 464 =head3 call_authenticate
 465
 466 This method first checks if the relevant model class
 467 can authenticate the user, or falls back to the default
 468 authenticate method of your Maypole application.
 469
 470
 471 =head3 call_exception
 472
 473 This model is called to catch exceptions, first after authenticate, then after
 474 processing the model class, and finally to check for exceptions from the view
 475 class.
 476
 477 This method first checks if the relevant model class
 478 can handle exceptions the user, or falls back to the default
 479 exception method of your Maypole application.
 480
 481 =head3 make_random_id
 482
 483 returns a unique id for this request can be used to prevent or detect repeat submissions.
 484
 485 =head3 handler
 486
 487 This method sets up the class if it's not done yet, sets some
 488 defaults and leaves the dirty work to handler_guts.
 489
 490 =head3 handler_guts
 491
 492 This is the core of maypole. You don't want to know.
 493
 494 =head1 SEE ALSO
 495
 496 There's more documentation, examples, and a information on our mailing lists
 497 at the Maypole web site:
 498
 499 L<http://maypole.perl.org/>
 500
 501 L<Maypole::Application>, L<Apache::MVC>, L<CGI::Maypole>.
 502
 503 =head1 AUTHOR
 504
 505 Maypole is currently maintained by Simon Flack C<simonflk#cpan.org>
 506
 507 =head1 AUTHOR EMERITUS
 508
 509 Simon Cozens, C<simon#cpan.org>
 510
 511 Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
 512
 513 =head1 THANKS TO
 514
 515 Sebastian Riedel, Danijel Milicevic, Dave Slack, Jesse Sheidlower, Jody Belka,
 516 Marcus Ramberg, Mickael Joanne, Randal Schwartz, Simon Flack, Steve Simms,
 517 Veljko Vidovic and all the others who've helped.
 518
 519 =head1 LICENSE
 520
 521 You may distribute this code under the same terms as Perl itself.
 522
 523 =cut
 524
 525 1;