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