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