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