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