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