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->{action} = "index" unless $self->{action};
 189     $self->{args}   = \@pi;
 190 }
 191
 192 sub get_template_root { "." }
 193 sub get_request       { }
 194
 195 sub parse_location {
 196     die "Do not use Maypole directly; use Apache::MVC or similar";
 197 }
 198
 199 sub send_output {
 200     die "Do not use Maypole directly; use Apache::MVC or similar";
 201 }
 202
 203 =head1 NAME
 204
 205 Maypole - MVC web application framework
 206
 207 =head1 SYNOPSIS
 208
 209 See L<Maypole::Application>.
 210
 211 =head1 DESCRIPTION
 212
 213 This documents the Maypole request object. For user documentation, see
 214 L<Maypole::Manual>.
 215
 216 =head2 CLASS METHODS
 217
 218 =head3 config
 219
 220 Returns the L<Maypole::Config> object
 221
 222 =head3 setup
 223
 224     My::App->setup($data_source, $user, $password, \%attr);
 225
 226 Initialise the maypole application and model classes. Your application should
 227 call this after setting configuration via L<"config">
 228
 229 =head3 init
 230
 231 You should not call this directly, but you may wish to override this to
 232 add
 233 application-specific initialisation.
 234
 235 =head3 view_object
 236
 237 Get/set the Maypole::View object
 238
 239 =head3 debug
 240
 241     sub My::App::debug {1}
 242
 243 Returns the debugging flag. Override this in your application class to
 244 enable/disable debugging.
 245
 246 =head2 INSTANCE METHODS
 247
 248 =head3 parse_location
 249
 250 Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a
 251 Maypole
 252 request. It does this by setting the C<path>, and invoking C<parse_path>
 253 and
 254 C<parse_args>.
 255
 256 You should only need to define this method if you are writing a new
 257 Maypole
 258 backend.
 259
 260 =head3 path
 261
 262 Returns the request path
 263
 264 =head3 parse_path
 265
 266 Parses the request path and sets the C<args>, C<action> and C<table>
 267 properties
 268
 269 =head3 table
 270
 271 The table part of the Maypole request path
 272
 273 =head3 action
 274
 275 The action part of the Maypole request path
 276
 277 =head3 args
 278
 279 A list of remaining parts of the request path after table and action
 280 have been
 281 removed
 282
 283 =head3 headers_in
 284
 285 A L<Maypole::Headers> object containing HTTP headers for the request
 286
 287 =head3 headers_out
 288
 289 A L<HTTP::Headers> object that contains HTTP headers for the output
 290
 291 =head3 parse_args
 292
 293 Turns post data and query string paramaters into a hash of C<params>.
 294
 295 You should only need to define this method if you are writing a new
 296 Maypole
 297 backend.
 298
 299 =head3 params
 300
 301 Returns a hash of request parameters. The source of the parameters may
 302 vary
 303 depending on the Maypole backend, but they are usually populated from
 304 request
 305 query string and POST data.
 306
 307 B<Note:> Where muliple values of a parameter were supplied, the
 308 C<params>
 309 value
 310 will be an array reference.
 311
 312 =head3 get_template_root
 313
 314 Implimentation-specific path to template root.
 315
 316 You should only need to define this method if you are writing a new
 317 Maypole
 318 backend. Otherwise, see L<Maypole::Config/"template_root">
 319
 320 =head3 get_request
 321
 322 You should only need to define this method if you are writing a new
 323 Maypole backend. It should return something that looks like an Apache
 324 or CGI request object, it defaults to blank.
 325
 326
 327 =head3 is_applicable
 328
 329 Returns a Maypole::Constant to indicate whether the request is valid.
 330
 331 The default implimentation checks that C<$r-E<gt>table> is publicly
 332 accessible
 333 and that the model class is configured to handle the C<$r-E<gt>action>
 334
 335 =head3 authenticate
 336
 337 Returns a Maypole::Constant to indicate whether the user is
 338 authenticated for
 339 the Maypole request.
 340
 341 The default implimentation returns C<OK>
 342
 343 =head3 model_class
 344
 345 Returns the perl package name that will serve as the model for the
 346 request. It corresponds to the request C<table> attribute.
 347
 348 =head3 additional_data
 349
 350 Called before the model processes the request, this method gives you a
 351 chance
 352 to do some processing for each request, for example, manipulating
 353 C<template_args>.
 354
 355 =head3 objects
 356
 357 Get/set a list of model objects. The objects will be accessible in the
 358 view
 359 templates.
 360
 361 If the first item in C<$r-E<gt>args> can be C<retrieve()>d by the model
 362 class,
 363 it will be removed from C<args> and the retrieved object will be added
 364 to the
 365 C<objects> list. See L<Maypole::Model> for more information.
 366
 367 =head3 template_args
 368
 369     $r->template_args->{foo} = 'bar';
 370
 371 Get/set a hash of template variables.
 372
 373 =head3 template
 374
 375 Get/set the template to be used by the view. By default, it returns
 376 C<$r-E<gt>action>
 377
 378 =head3 exception
 379
 380 This method is called if any exceptions are raised during the
 381 authentication
 382 or
 383 model/view processing. It should accept the exception as a parameter and
 384 return
 385 a Maypole::Constant to indicate whether the request should continue to
 386 be
 387 processed.
 388
 389 =head3 error
 390
 391 Get/set a request error
 392
 393 =head3 output
 394
 395 Get/set the response output. This is usually populated by the view
 396 class. You
 397 can skip view processing by setting the C<output>.
 398
 399 =head3 document_encoding
 400
 401 Get/set the output encoding. Default: utf-8.
 402
 403 =head3 content_type
 404
 405 Get/set the output content type. Default: text/html
 406
 407 =head3 send_output
 408
 409 Sends the output and additional headers to the user.
 410
 411 =head3 call_authenticate
 412
 413 This method first checks if the relevant model class
 414 can authenticate the user, or falls back to the default
 415 authenticate method of your Maypole application.
 416
 417
 418 =head3 call_exception
 419
 420 This model is called to catch exceptions, first after authenticate
 421 ,then after processing the model class, and finally to check for
 422 exceptions from the view class.
 423
 424 This method first checks if the relevant model class
 425 can handle exceptions the user, or falls back to the default
 426 exception method of your Maypole application.
 427
 428
 429 =head3 handler
 430
 431 This method sets up the class if it's not done yet, sets some
 432 defaults and leaves the dirty work to handler_guts.
 433
 434 =head3 handler_guts
 435
 436 This is the core of maypole. You don't want to know.
 437
 438 =head1 SEE ALSO
 439
 440 There's more documentation, examples, and a wiki at the Maypole web
 441 site:
 442
 443 http://maypole.perl.org/
 444
 445 L<Maypole::Application>,L<Apache::MVC>, L<CGI::Maypole>.
 446
 447 =head1 AUTHOR
 448
 449 Sebastian Riedel, c<sri@oook.de>
 450
 451 =head1 AUTHOR EMERITUS
 452
 453 Simon Cozens, C<simon@cpan.org>
 454
 455 =head1 THANKS TO
 456
 457 Danijel Milicevic, Dave Slack, Jesse Sheidlower, Jody Belka, Marcus Ramberg,
 458 Mickael Joanne, Randal Schwartz, Simon Flack, Steve Simms, Veljko Vidovic
 459 and all the others who've helped.
 460
 461 =head1 LICENSE
 462
 463 You may distribute this code under the same terms as Perl itself.
 464
 465 =cut
 466
 467 1;