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