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