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})"
 134       if $self->debug
 135       and not $config->ok_tables->{ $self->{table} };
 136     return DECLINED() unless exists $config->ok_tables->{ $self->{table} };
 137
 138     # Is it public?
 139     return DECLINED unless $r->model_class->is_public( $r->{action} );
 140     return OK();
 141 }
 142
 143 sub call_authenticate {
 144     my $self = shift;
 145
 146     # Check if we have a model class
 147     if ( $self->{model_class} ) {
 148         return $self->model_class->authenticate($self)
 149           if $self->model_class->can("authenticate");
 150     }
 151     return $self->authenticate($self);   # Interface consistency is a Good Thing
 152 }
 153
 154 sub call_exception {
 155     my $self = shift;
 156     my ($error) = @_;
 157
 158     # Check if we have a model class
 159     if (   $self->{model_class}
 160         && $self->model_class->can('exception') )
 161     {
 162         my $status = $self->model_class->exception( $self, $error );
 163         return $status if $status == OK;
 164     }
 165     return $self->exception($error);
 166 }
 167
 168 sub additional_data { }
 169
 170 sub authenticate { return OK }
 171
 172 sub exception { return ERROR }
 173
 174 sub parse_path {
 175     my $self = shift;
 176     $self->{path} ||= "frontpage";
 177     my @pi = split /\//, $self->{path};
 178     shift @pi while @pi and !$pi[0];
 179     $self->{table}  = shift @pi;
 180     $self->{action} = shift @pi;
 181     $self->{args}   = \@pi;
 182 }
 183
 184 sub get_template_root { "." }
 185 sub get_request       { }
 186
 187 sub parse_location {
 188     die "Do not use Maypole directly; use Apache::MVC or similar";
 189 }
 190
 191 sub send_output {
 192     die "Do not use Maypole directly; use Apache::MVC or similar";
 193 }
 194
 195 =head1 NAME
 196
 197 Maypole - MVC web application framework
 198
 199 =head1 SYNOPSIS
 200
 201 See L<Maypole::Application>.
 202
 203 =head1 DESCRIPTION
 204
 205 This documents the Maypole request object. For user documentation, see
 206 L<Maypole::Manual>.
 207
 208 =head2 CLASS METHODS
 209
 210 =head3 config
 211
 212 Returns the L<Maypole::Config> object
 213
 214 =head3 setup
 215
 216     My::App->setup($data_source, $user, $password, \%attr);
 217
 218 Initialise the maypole application and model classes. Your application should
 219 call this after setting configuration via L<"config">
 220
 221 =head3 init
 222
 223 You should not call this directly, but you may wish to override this to
 224 add
 225 application-specific initialisation.
 226
 227 =head3 view_object
 228
 229 Get/set the Maypole::View object
 230
 231 =head3 debug
 232
 233     sub My::App::debug {1}
 234
 235 Returns the debugging flag. Override this in your application class to
 236 enable/disable debugging.
 237
 238 =head2 INSTANCE METHODS
 239
 240 =head3 parse_location
 241
 242 Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a
 243 Maypole
 244 request. It does this by setting the C<path>, and invoking C<parse_path>
 245 and
 246 C<parse_args>.
 247
 248 You should only need to define this method if you are writing a new
 249 Maypole
 250 backend.
 251
 252 =head3 path
 253
 254 Returns the request path
 255
 256 =head3 parse_path
 257
 258 Parses the request path and sets the C<args>, C<action> and C<table>
 259 properties
 260
 261 =head3 table
 262
 263 The table part of the Maypole request path
 264
 265 =head3 action
 266
 267 The action part of the Maypole request path
 268
 269 =head3 args
 270
 271 A list of remaining parts of the request path after table and action
 272 have been
 273 removed
 274
 275 =head3 parse_args
 276
 277 Turns post data and query string paramaters into a hash of C<params>.
 278
 279 You should only need to define this method if you are writing a new
 280 Maypole
 281 backend.
 282
 283 =head3 params
 284
 285 Returns a hash of request parameters. The source of the parameters may
 286 vary
 287 depending on the Maypole backend, but they are usually populated from
 288 request
 289 query string and POST data.
 290
 291 B<Note:> Where muliple values of a parameter were supplied, the
 292 C<params>
 293 value
 294 will be an array reference.
 295
 296 =head3 get_template_root
 297
 298 Implimentation-specific path to template root.
 299
 300 You should only need to define this method if you are writing a new
 301 Maypole
 302 backend. Otherwise, see L<Maypole::Config/"template_root">
 303
 304 =head3 is_applicable
 305
 306 Returns a Maypole::Constant to indicate whether the request is valid.
 307
 308 The default implimentation checks that C<$r-E<gt>table> is publicly
 309 accessible
 310 and that the model class is configured to handle the C<$r-E<gt>action>
 311
 312 =head3 authenticate
 313
 314 Returns a Maypole::Constant to indicate whether the user is
 315 authenticated for
 316 the Maypole request.
 317
 318 The default implimentation returns C<OK>
 319
 320 =head3 model_class
 321
 322 Returns the perl package name that will serve as the model for the
 323 request. It corresponds to the request C<table> attribute.
 324
 325 =head3 additional_data
 326
 327 Called before the model processes the request, this method gives you a
 328 chance
 329 to do some processing for each request, for example, manipulating
 330 C<template_args>.
 331
 332 =head3 objects
 333
 334 Get/set a list of model objects. The objects will be accessible in the
 335 view
 336 templates.
 337
 338 If the first item in C<$r-E<gt>args> can be C<retrieve()>d by the model
 339 class,
 340 it will be removed from C<args> and the retrieved object will be added
 341 to the
 342 C<objects> list. See L<Maypole::Model> for more information.
 343
 344 =head3 template_args
 345
 346     $r->template_args->{foo} = 'bar';
 347
 348 Get/set a hash of template variables.
 349
 350 =head3 template
 351
 352 Get/set the template to be used by the view. By default, it returns
 353 C<$r-E<gt>action>
 354
 355 =head3 exception
 356
 357 This method is called if any exceptions are raised during the
 358 authentication
 359 or
 360 model/view processing. It should accept the exception as a parameter and
 361 return
 362 a Maypole::Constant to indicate whether the request should continue to
 363 be
 364 processed.
 365
 366 =head3 error
 367
 368 Get/set a request error
 369
 370 =head3 output
 371
 372 Get/set the response output. This is usually populated by the view
 373 class. You
 374 can skip view processing by setting the C<output>.
 375
 376 =head3 document_encoding
 377
 378 Get/set the output encoding. Default: utf-8.
 379
 380 =head3 content_type
 381
 382 Get/set the output content type. Default: text/html
 383
 384 =head3 send_output
 385
 386 Sends the output and additional headers to the user.
 387
 388 =head1 SEE ALSO
 389
 390 There's more documentation, examples, and a wiki at the Maypole web
 391 site:
 392
 393 http://maypole.perl.org/
 394
 395 L<Maypole::Application>,L<Apache::MVC>, L<CGI::Maypole>.
 396
 397 =head1 MAINTAINER
 398
 399 Sebastian Riedel, c<sri@oook.de>
 400
 401 =head1 AUTHOR
 402
 403 Simon Cozens, C<simon@cpan.org>
 404
 405 =head1 THANK YOU
 406
 407 Danijel Milicevic, Jesse Scheidlower, Jody Belka, Marcus Ramberg,
 408 Mickael Joanne, Simon Flack, Veljko Vidovic and all the others who've
 409 helped.
 410
 411 =head1 LICENSE
 412
 413 You may distribute this code under the same terms as Perl itself.
 414
 415 =cut
 416
 417 1;