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