lib/Maypole.pm

   1 package Maypole;
   2 use base qw(Class::Accessor::Fast Class::Data::Inheritable);
   3 use attributes ();
   4 use UNIVERSAL::require;
   5 use strict;
   6 use warnings;
   7 use Maypole::Config;
   8 use Maypole::Constants;
   9
  10 our $VERSION = '2.0';
  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 );
  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
  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 { 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     my $applicable = $r->is_applicable;
  77     unless ( $applicable == OK ) {
  78
  79         # It's just a plain template
  80         delete $r->{model_class};
  81         $r->{path} =~ s{/$}{};    # De-absolutify
  82         $r->template( $r->{path} );
  83     }
  84
  85     # We authenticate every request, needed for proper session management
  86     my $status;
  87     eval { $status = $r->call_authenticate };
  88     if ( my $error = $@ ) {
  89         $status = $r->call_exception($error);
  90         if ( $status != OK ) {
  91             warn "caught authenticate error: $error";
  92             return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
  93         }
  94     }
  95     if ( $r->debug and $status != OK and $status != DECLINED ) {
  96         $r->view_object->error( $r,
  97             "Got unexpected status $status from calling authentication" );
  98     }
  99     return $status unless $status == OK;
 100
 101     # We run additional_data for every request
 102     $r->additional_data;
 103     if ( $applicable == OK ) {
 104         eval { $r->model_class->process($r) };
 105         if ( my $error = $@ ) {
 106             $status = $r->call_exception($error);
 107             if ( $status != OK ) {
 108                 warn "caught model error: $error";
 109                 return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
 110             }
 111         }
 112     }
 113     if ( !$r->{output} ) {    # You might want to do it yourself
 114         eval { $status = $r->view_object->process($r) };
 115         if ( my $error = $@ ) {
 116             $status = $r->call_exception($error);
 117             if ( $status != OK ) {
 118                 warn "caught view error: $error" if $r->debug;
 119                 return $r->debug ? $r->view_object->error( $r, $error ) : ERROR;
 120             }
 121         }
 122         return $status;
 123     }
 124     else { return OK; }
 125 }
 126
 127 sub is_applicable {
 128     my $self   = shift;
 129     my $config = $self->config;
 130     $config->ok_tables || $config->ok_tables( $config->display_tables );
 131     $config->ok_tables( { map { $_ => 1 } @{ $config->ok_tables } } )
 132       if ref $config->ok_tables eq "ARRAY";
 133     warn "We don't have that table ($self->{table}).\n"
 134       . "Available tables are: "
 135       . join( ",", @{ $config->{display_tables} } )
 136       if $self->debug
 137       and not $config->ok_tables->{ $self->{table} };
 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 is_applicable
 307
 308 Returns a Maypole::Constant to indicate whether the request is valid.
 309
 310 The default implimentation checks that C<$r-E<gt>table> is publicly
 311 accessible
 312 and that the model class is configured to handle the C<$r-E<gt>action>
 313
 314 =head3 authenticate
 315
 316 Returns a Maypole::Constant to indicate whether the user is
 317 authenticated for
 318 the Maypole request.
 319
 320 The default implimentation returns C<OK>
 321
 322 =head3 model_class
 323
 324 Returns the perl package name that will serve as the model for the
 325 request. It corresponds to the request C<table> attribute.
 326
 327 =head3 additional_data
 328
 329 Called before the model processes the request, this method gives you a
 330 chance
 331 to do some processing for each request, for example, manipulating
 332 C<template_args>.
 333
 334 =head3 objects
 335
 336 Get/set a list of model objects. The objects will be accessible in the
 337 view
 338 templates.
 339
 340 If the first item in C<$r-E<gt>args> can be C<retrieve()>d by the model
 341 class,
 342 it will be removed from C<args> and the retrieved object will be added
 343 to the
 344 C<objects> list. See L<Maypole::Model> for more information.
 345
 346 =head3 template_args
 347
 348     $r->template_args->{foo} = 'bar';
 349
 350 Get/set a hash of template variables.
 351
 352 =head3 template
 353
 354 Get/set the template to be used by the view. By default, it returns
 355 C<$r-E<gt>action>
 356
 357 =head3 exception
 358
 359 This method is called if any exceptions are raised during the
 360 authentication
 361 or
 362 model/view processing. It should accept the exception as a parameter and
 363 return
 364 a Maypole::Constant to indicate whether the request should continue to
 365 be
 366 processed.
 367
 368 =head3 error
 369
 370 Get/set a request error
 371
 372 =head3 output
 373
 374 Get/set the response output. This is usually populated by the view
 375 class. You
 376 can skip view processing by setting the C<output>.
 377
 378 =head3 document_encoding
 379
 380 Get/set the output encoding. Default: utf-8.
 381
 382 =head3 content_type
 383
 384 Get/set the output content type. Default: text/html
 385
 386 =head3 send_output
 387
 388 Sends the output and additional headers to the user.
 389
 390 =head1 SEE ALSO
 391
 392 There's more documentation, examples, and a wiki at the Maypole web
 393 site:
 394
 395 http://maypole.perl.org/
 396
 397 L<Maypole::Application>,L<Apache::MVC>, L<CGI::Maypole>.
 398
 399 =head1 MAINTAINER
 400
 401 Sebastian Riedel, c<sri@oook.de>
 402
 403 =head1 AUTHOR
 404
 405 Simon Cozens, C<simon@cpan.org>
 406
 407 =head1 THANK YOU
 408
 409 Danijel Milicevic, Jesse Sheidlower, Jody Belka, Marcus Ramberg,
 410 Mickael Joanne, Simon Flack, Veljko Vidovic and all the others who've
 411 helped.
 412
 413 =head1 LICENSE
 414
 415 You may distribute this code under the same terms as Perl itself.
 416
 417 =cut
 418
 419 1;