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