1package Maypole; 2use base qw(Class::Accessor::Fast Class::Data::Inheritable); 3use UNIVERSAL::require; 4use strict; 5use warnings; 6use Data::Dumper; 7use Maypole::Config; 8use Maypole::Constants; 9use Maypole::Headers; 10use URI(); 11use URI::QueryParam; 12use NEXT; 13use File::MMagic::XS qw(:compat); 14 15our $VERSION = '2.13'; 16our $mmagic = File::MMagic::XS->new(); 17 18# proposed privacy conventions: 19# - no leading underscore - public to custom application code and plugins 20# - single leading underscore - private to the main Maypole stack - *not* 21# including plugins 22# - double leading underscore - private to the current package 23 24=head1 NAME 25 26Maypole - MVC web application framework 27 28=head1 SYNOPSIS 29 30The canonical example used in the Maypole documentation is the beer database: 31 32 package BeerDB; 33 use strict; 34 use warnings; 35 36 # choose a frontend, initialise the config object, and load a plugin 37 use Maypole::Application qw/Relationship/; 38 39 # set everything up 40 __PACKAGE__->setup("dbi:SQLite:t/beerdb.db"); 41 42 # get the empty config object created by Maypole::Application 43 my $config = __PACKAGE__->config; 44 45 # basic settings 46 $config->uri_base("http://localhost/beerdb"); 47 $config->template_root("/path/to/templates"); 48 $config->rows_per_page(10); 49 $config->display_tables([qw/beer brewery pub style/]); 50 51 # table relationships 52 $config->relationships([ 53 "a brewery produces beers", 54 "a style defines beers", 55 "a pub has beers on handpumps", 56 ]); 57 58 # validation 59 BeerDB::Brewery->untaint_columns( printable => [qw/name notes url/] ); 60 BeerDB::Pub->untaint_columns( printable => [qw/name notes url/] ); 61 BeerDB::Style->untaint_columns( printable => [qw/name notes/] ); 62 BeerDB::Beer->untaint_columns( 63 printable => [qw/abv name price notes/], 64 integer => [qw/style brewery score/], 65 date => [ qw/date/], 66 ); 67 68 # note : set up model before calling this method 69 BeerDB::Beer->required_columns([qw/name/]); 70 71 1; 72 73=head1 DESCRIPTION 74 75This documents the Maypole request object. See the L<Maypole::Manual>, for a 76detailed guide to using Maypole. 77 78Maypole is a Perl web application framework similar to Java's struts. It is 79essentially completely abstracted, and so doesn't know anything about 80how to talk to the outside world. 81 82To use it, you need to create a driver package which represents your entire 83application. This is the C<BeerDB> package used as an example in the manual. 84 85This needs to first use L<Maypole::Application> which will make your package 86inherit from the appropriate platform driver such as C<Apache::MVC> or 87C<CGI::Maypole>. Then, the driver calls C<setup>. This sets up the model classes 88and configures your application. The default model class for Maypole uses 89L<Class::DBI> to map a database to classes, but this can be changed by altering 90configuration (B<before> calling setup.) 91 92 93=head1 DOCUMENTATION AND SUPPORT 94 95Note that some details in some of these resources may be out of date. 96 97=over 4 98 99=item The Maypole Manual 100 101The primary documentation is the Maypole manual. This lives in the 102C<Maypole::Manual> pod documents included with the distribution. 103 104=item Embedded POD 105 106Individual packages within the distribution contain (more or less) detailed 107reference documentation for their API. 108 109=item Mailing lists 110 111There are two mailing lists - maypole-devel and maypole-users - see 112http://maypole.perl.org/?MailingList 113 114=item The Maypole Wiki 115 116The Maypole wiki provides a useful store of extra documentation - 117http://maypole.perl.org 118 119In particular, there's a FAQ (http://maypole.perl.org/?FAQ) and a cookbook 120(http://maypole.perl.org/?Cookbook). Again, certain information on these pages 121may be out of date. 122 123=item Web applications with Maypole 124 125A tutorial written by Simon Cozens for YAPC::EU 2005 - 126http://www.aarontrevena.co.uk/opensource/maypole/maypole-tutorial.pdf [228KB]. 127 128=item A Database-Driven Web Application in 18 Lines of Code 129 130By Paul Barry, published in Linux Journal, March 2005. 131 132http://www.linuxjournal.com/article/7937 133 134"From zero to Web-based database application in eight easy steps". 135 136Maypole won a 2005 Linux Journal Editor's Choice Award 137(http://www.linuxjournal.com/article/8293) after featuring in this article. 138 139=item Build Web apps with Maypole 140 141By Simon Cozens, on IBM's DeveloperWorks website, May 2004. 142 143http://www-128.ibm.com/developerworks/linux/library/l-maypole/ 144 145=item Rapid Web Application Deployment with Maypole 146 147By Simon Cozens, on O'Reilly's Perl website, April 2004. 148 149http://www.perl.com/pub/a/2004/04/15/maypole.html 150 151=item Authentication 152 153Some notes written by Simon Cozens. A little bit out of date, but still 154very useful: http://www.aarontrevena.co.uk/opensource/maypole/authentication.html 155 156=item CheatSheet 157 158There's a refcard for the Maypole (and Class::DBI) APIs on the wiki - 159http://maypole.perl.org/?CheatSheet. Probably a little out of date now - it's a 160wiki, so feel free to fix any errors! 161 162=item Plugins and add-ons 163 164There are a large and growing number of plugins and other add-on modules 165available on CPAN - http://search.cpan.org/search?query=maypole&mode=module 166 167=item del.icio.us 168 169You can find a range of useful Maypole links, particularly to several thoughtful 170blog entries, starting here: http://del.icio.us/search/?all=maypole 171 172=item CPAN ratings 173 174There are a couple of short reviews here: 175http://cpanratings.perl.org/dist/Maypole 176 177=back 178 179=cut 180 181__PACKAGE__->mk_classdata($_) for qw( config init_done view_object model_classes_loaded); 182 183__PACKAGE__->mk_accessors( 184 qw( params query objects model_class template_args output path 185 args action template error document_encoding content_type table 186 headers_in headers_out stash status parent build_form_elements 187 user session) 188); 189 190__PACKAGE__->config( Maypole::Config->new({additional => { }, request_options => { }, view_options => { },}) ); 191 192__PACKAGE__->init_done(0); 193 194__PACKAGE__->model_classes_loaded(0); 195 196=head1 HOOKABLE METHODS 197 198As a framework, Maypole provides a number of B<hooks> - methods that are 199intended to be overridden. Some of these methods come with useful default 200behaviour, others do nothing by default. Hooks include: 201 202 Class methods 203 ------------- 204 debug 205 setup 206 setup_model 207 load_model_subclass 208 init 209 210 Instance methods 211 ---------------- 212 start_request_hook 213 is_model_applicable 214 get_session 215 authenticate 216 exception 217 additional_data 218 preprocess_path 219 220=head1 CLASS METHODS 221 222=over 4 223 224=item debug 225 226 sub My::App::debug {1} 227 228Returns the debugging flag. Override this in your application class to 229enable/disable debugging. 230 231You can also set the C<debug> flag via L<Maypole::Application>. 232 233Some packages respond to higher debug levels, try increasing it to 2 or 3. 234 235 236=cut 237 238sub debug { 0 } 239 240=item config 241 242Returns the L<Maypole::Config> object 243 244=item setup 245 246 My::App->setup($data_source, $user, $password, \%attr); 247 248Initialise the Maypole application and plugins and model classes. 249Your application should call this B<after> setting up configuration data via 250L<"config">. 251 252It calls the hook C<setup_model> to setup the model. The %attr hash contains 253options and arguments used to set up the model. See the particular model's 254documentation. However here is the most usage of setup where 255Maypole::Model::CDBI is the base class. 256 257 My::App->setup($data_source, $user, $password, 258 { options => { # These are DB connection options 259 AutoCommit => 0, 260 RaiseError => 1, 261 ... 262 }, 263 # These are Class::DBI::Loader arguments. 264 relationships => 1, 265 ... 266 } 267 ); 268 269Also, see L<Maypole::Manual::Plugins>. 270 271=cut 272 273 274sub setup 275{ 276 my $class = shift; 277 278 $class->setup_model(@_); 279} 280 281=item setup_model 282 283Called by C<setup>. This method builds the Maypole model hierarchy. 284 285A likely target for over-riding, if you need to build a customised model. 286 287This method also ensures any code in custom model classes is loaded, so you 288don't need to load them in the driver. 289 290=cut 291 292sub setup_model { 293 my $class = shift; 294 $class = ref $class if ref $class; 295 my $config = $class->config; 296 $config->model || $config->model('Maypole::Model::CDBI'); 297 $config->model->require or die sprintf 298 "Couldn't load the model class %s: %s", $config->model, $@; 299 300 # among other things, this populates $config->classes 301 $config->model->setup_database($config, $class, @_); 302 303 $config->model->add_model_superclass($config); 304 305 # Load custom model code, if it exists - nb this must happen after the 306 # adding the model superclass, to allow code attributes to work, but before adopt(), 307 # in case adopt() calls overridden methods on $subclass 308 foreach my $subclass ( @{ $config->classes } ) { 309 $class->load_model_subclass($subclass) unless ($class->model_classes_loaded()); 310 $config->model->adopt($subclass) if $config->model->can("adopt"); 311 } 312 313} 314 315=item load_model_subclass($subclass) 316 317This method is called from C<setup_model()>. It attempts to load the 318C<$subclass> package, if one exists. So if you make a customized C<BeerDB::Beer> 319package, you don't need to explicitly load it. 320 321If automatic loading causes problems, Override load_model_subclass in your driver. 322 323sub load_model_subclass {}; 324 325Or perhaps during development, if you don't want to load up custom classes, you 326can override this method and load them manually. 327 328=cut 329 330sub load_model_subclass { 331 my ($class, $subclass) = @_; 332 333 my $config = $class->config; 334 335 # Load any external files for the model base class or subclasses 336 # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from 337 # Maypole::Plugin::Loader and Class::DBI. 338 if ( $subclass->require ) { 339 warn "Loaded external module for '$subclass'\n" if $class->debug > 1; 340 } else { 341 (my $filename = $subclass) =~ s!::!/!g; 342 die "Loading '$subclass' failed: $@\n" 343 unless $@ =~ /Can\'t locate \Q$filename\E\.pm/; 344 warn "No external module for '$subclass'" 345 if $class->debug > 1; 346 } 347} 348 349=item init 350 351Loads the view class and instantiates the view object. 352 353You should not call this directly, but you may wish to override this to add 354application-specific initialisation - see L<Maypole::Manual::Plugins>. 355 356=cut 357 358sub init 359{ 360 my $class = shift; 361 my $config = $class->config; 362 $config->view || $config->view("Maypole::View::TT"); 363 $config->view->require; 364 die "Couldn't load the view class " . $config->view . ": $@" if $@; 365 $config->display_tables 366 || $config->display_tables( $class->config->tables ); 367 $class->view_object( $class->config->view->new ); 368 $class->init_done(1); 369} 370 371=item new 372 373Constructs a very minimal new Maypole request object. 374 375=cut 376 377sub new 378{ 379 my ($class) = @_; 380 my $self = bless { 381 config => $class->config, 382 }, $class; 383 384 $self->stash({}); 385 $self->params({}); 386 $self->query({}); 387 $self->template_args({}); 388 $self->args([]); 389 $self->objects([]); 390 return $self; 391} 392 393=item view_object 394 395Get/set the Maypole::View object 396 397=back 398 399=head1 INSTANCE METHODS 400 401=head2 Workflow 402 403=over 4 404 405=item handler 406 407This method sets up the class if it's not done yet, sets some defaults and 408leaves the dirty work to C<handler_guts>. 409 410=cut 411 412# handler() has a method attribute so that mod_perl will invoke 413# BeerDB->handler() as a method rather than a plain function 414# BeerDB::handler() and so this inherited implementation will be 415# found. See e.g. "Practical mod_perl" by Bekman & Cholet for 416# more information <http://modperlbook.org/html/ch25_01.html> 417sub handler : method { 418 # See Maypole::Workflow before trying to understand this. 419 my ($class, $req) = @_; 420 421 $class->init unless $class->init_done; 422 423 my $self = $class->new; 424 425 # initialise the request 426 $self->headers_out(Maypole::Headers->new); 427 $self->get_request($req); 428 429 $self->parse_location; 430 431 # hook useful for declining static requests e.g. images, or perhaps for 432 # sanitizing request parameters 433 $self->status(Maypole::Constants::OK()); # set the default 434 $self->__call_hook('start_request_hook'); 435 return $self->status unless $self->status == Maypole::Constants::OK(); 436 die "status undefined after start_request_hook()" unless defined 437 $self->status; 438 439 my $session = $self->get_session; 440 $self->session($self->{session} || $session); 441 my $user = $self->get_user; 442 $self->user($self->{user} || $user); 443 444 my $status = $self->handler_guts; 445 return $status unless $status == OK; 446 # TODO: require send_output to return a status code 447 $self->send_output; 448 return $status; 449} 450 451=item component 452 453 Run Maypole sub-requests as a component of the request 454 455 [% request.component("/beer/view_as_component/20") %] 456 457 Allows you to integrate the results of a Maypole request into an existing 458request. You'll need to set up actions and templates 459which return fragments of HTML rather than entire pages, but once you've 460done that, you can use the C<component> method of the Maypole request object 461to call those actions. You may pass a query string in the usual URL style. 462 463You should not fully qualify the Maypole URLs. 464 465Note: any HTTP POST or URL parameters passed to the parent are not passed to the 466component sub-request, only what is included in the url passed as an argument 467to the method 468 469=cut 470 471sub component { 472 my ( $r, $path ) = @_; 473 my $self = bless { parent => $r, config => $r->{config}, } , ref $r; 474 $self->stash({}); 475 $self->params({}); 476 $self->query({}); 477 $self->template_args({}); 478 $self->args([]); 479 $self->objects([]); 480 481 $self->session($self->get_session); 482 $self->user($self->get_user); 483 484 my $url = URI->new($path); 485 $self->{path} = $url->path; 486 $self->parse_path; 487 $self->params( $url->query_form_hash ); 488 $self->handler_guts; 489 return $self->output; 490} 491 492sub get_template_root { 493 my $self = shift; 494 my $r = shift; 495 return $r->parent->get_template_root if $r->{parent}; 496 return $self->NEXT::DISTINCT::get_template_root( $r, @_ ); 497} 498 499sub view_object { 500 my $self = shift; 501 my $r = shift; 502 return $r->parent->view_object if $r->{parent}; 503 return $self->NEXT::DISTINCT::view_object( $r, @_ ); 504} 505 506# Instead of making plugin authors use the NEXT::DISTINCT hoopla to ensure other 507# plugins also get to call the hook, we can cycle through the application's 508# @ISA and call them all here. Doesn't work for setup() though, because it's 509# too ingrained in the stack. We could add a run_setup() method, but we'd break 510# lots of existing code. 511sub __call_hook 512{ 513 my ($self, $hook) = @_; 514 515 my @plugins; 516 { 517 my $class = ref($self); 518 no strict 'refs'; 519 @plugins = @{"$class\::ISA"}; 520 } 521 522 # this is either a custom method in the driver, or the method in the 1st 523 # plugin, or the 'null' method in the frontend (i.e. inherited from 524 # Maypole.pm) - we need to be careful to only call it once 525 my $first_hook = $self->can($hook); 526 $self->$first_hook; 527 528 my %seen = ( $first_hook => 1 ); 529 530 # @plugins includes the frontend 531 foreach my $plugin (@plugins) 532 { 533 next unless my $plugin_hook = $plugin->can($hook); 534 next if $seen{$plugin_hook}++; 535 $self->$plugin_hook; 536 } 537} 538 539=item handler_guts 540 541This is the main request handling method and calls various methods to handle the 542request/response and defines the workflow within Maypole. 543 544=cut 545 546# The root of all evil 547sub handler_guts { 548 my ($self) = @_; 549 $self->build_form_elements(1) unless (defined ($self->config->build_form_elements) && $self->config->build_form_elements == 0); 550 $self->__load_request_model; 551 552 my $applicable = $self->is_model_applicable == OK; 553 554 my $status; 555 556 # handle authentication 557 eval { $status = $self->call_authenticate }; 558 if ( my $error = $@ ) { 559 $status = $self->call_exception($error, "authentication"); 560 if ( $status != OK ) { 561 $self->warn("caught authenticate error: $error"); 562 return $self->debug ? 563 $self->view_object->error($self, $error) : ERROR; 564 } 565 } 566 if ( $self->debug and $status != OK and $status != DECLINED ) { 567 $self->view_object->error( $self, 568 "Got unexpected status $status from calling authentication" ); 569 } 570 571 return $status unless $status == OK; 572 573 # We run additional_data for every request 574 $self->additional_data; 575 576 # process request with model if applicable and template not set. 577 if ($applicable) { 578 unless ($self->{template}) { 579 eval { $self->model_class->process($self) }; 580 if ( my $error = $@ ) { 581 $status = $self->call_exception($error, "model"); 582 if ( $status != OK ) { 583 $self->warn("caught model error: $error"); 584 return $self->debug ? 585 $self->view_object->error($self, $error) : ERROR; 586 } 587 } 588 } 589 } else { 590 $self->__setup_plain_template; 591 } 592 593 # less frequent path - perhaps output has been set to an error message 594 if ($self->output) { 595 $self->{content_type} ||= $self->__get_mime_type(); 596 $self->{document_encoding} ||= "utf-8"; 597 return OK; 598 } 599 600 # normal path - no output has been generated yet 601 my $processed_view_ok = $self->__call_process_view; 602 603 $self->{content_type} ||= $self->__get_mime_type(); 604 $self->{document_encoding} ||= "utf-8"; 605 606 return $processed_view_ok; 607} 608 609my %filetypes = ( 610 'js' => 'text/javascript', 611 'css' => 'text/css', 612 'htm' => 'text/html', 613 'html' => 'text/html', 614 ); 615 616sub __get_mime_type { 617 my $self = shift; 618 my $type = 'text/html'; 619 if ($self->path =~ m/.*\.(\w{2,4})$/) { 620 $type = $filetypes{$1}; 621 } else { 622 my $output = $self->output; 623 if (defined $output) { 624 $type = $mmagic->checktype_contents($output); 625 } 626 } 627 return $type; 628} 629 630sub __load_request_model 631{ 632 my ($self) = @_; 633 # We may get a made up class from class_of 634 my $mclass = $self->config->model->class_of($self, $self->table); 635 if ( eval {$mclass->isa('Maypole::Model::Base')} ) { 636 $self->model_class( $mclass ); 637 } 638 elsif ($self->debug > 1) { 639 $self->warn("***Warning: No $mclass class appropriate for model. @_"); 640 } 641} 642 643 644# is_applicable() returned false, so set up a plain template. Model processing 645# will be skipped, but need to remove the model anyway so the template can't 646# access it. 647sub __setup_plain_template 648{ 649 my ($self) = @_; 650 651 # It's just a plain template 652 $self->build_form_elements(0); 653 $self->model_class(undef); 654 655 unless ($self->template) { 656 # FIXME: this is likely to be redundant and is definately causing problems. 657 my $path = $self->path; 658 $path =~ s{/$}{}; # De-absolutify 659 $self->path($path); 660 $self->template($self->path); 661 } 662} 663 664# The model has been processed or skipped (if is_applicable returned false), 665# any exceptions have been handled, and there's no content in $self->output 666sub __call_process_view { 667 my ($self) = @_; 668 669 my $status = eval { $self->view_object->process($self) }; 670 671 my $error = $@ || $self->{error}; 672 673 if ( $error ) { 674 $status = $self->call_exception($error, "view"); 675 676 if ( $status != OK ) { 677 warn "caught view error: $error" if $self->debug; 678 return $self->debug ? 679 $self->view_object->error($self, $error) : ERROR; 680 } 681 } 682 683 return $status; 684} 685 686=item warn 687 688$r->warn('its all gone pete tong'); 689 690Warn must be implemented by the backend, i.e. Apache::MVC 691and warn to stderr or appropriate logfile. 692 693You can also over-ride this in your Maypole driver, should you 694want to use something like Log::Log4perl instead. 695 696=cut 697 698sub warn { } 699 700=item build_form_elements 701 702$r->build_form_elements(0); 703 704Specify (in an action) whether to build HTML form elements and populate 705the cgi element of classmetadata in the view. 706 707You can set this globally using the accessor of the same name in Maypole::Config, 708this method allows you to over-ride that setting per action. 709 710=cut 711 712=item get_request 713 714You should only need to define this method if you are writing a new 715Maypole backend. It should return something that looks like an Apache 716or CGI request object, it defaults to blank. 717 718=cut 719 720sub get_request { } 721 722=item parse_location 723 724Turns the backend request (e.g. Apache::MVC, Maypole, CGI) into a Maypole 725request. It does this by setting the C<path>, and invoking C<parse_path> and 726C<parse_args>. 727 728You should only need to define this method if you are writing a new Maypole 729backend. 730 731=cut 732 733sub parse_location 734{ 735 die "parse_location is a virtual method. Do not use Maypole directly; " . 736 "use Apache::MVC or similar"; 737} 738 739=item start_request_hook 740 741This is called immediately after setting up the basic request. The default 742method does nothing. 743 744The value of C<< $r->status >> is set to C<OK> before this hook is run. Your 745implementation can change the status code, or leave it alone. 746 747After this hook has run, Maypole will check the value of C<status>. For any 748value other than C<OK>, Maypole returns the C<status> immediately. 749 750This is useful for filtering out requests for static files, e.g. images, which 751should not be processed by Maypole or by the templating engine: 752 753 sub start_request_hook 754 { 755 my ($r) = @_; 756 757 $r->status(DECLINED) if $r->path =~ /\.jpg$/; 758 } 759 760Multiple plugins, and the driver, can define this hook - Maypole will call all 761of them. You should check for and probably not change any non-OK C<status> 762value: 763 764 package Maypole::Plugin::MyApp::SkipFavicon; 765 766 sub start_request_hook 767 { 768 my ($r) = @_; 769 770 # check if a previous plugin has already DECLINED this request 771 # - probably unnecessary in this example, but you get the idea 772 return unless $r->status == OK; 773 774 # then do our stuff 775 $r->status(DECLINED) if $r->path =~ /favicon\.ico/; 776 } 777 778=cut 779 780sub start_request_hook { } 781 782=item is_applicable 783 784B<This method is deprecated> as of version 2.11. If you have overridden it, 785please override C<is_model_applicable> instead, and change the return type 786from a Maypole:Constant to a true/false value. 787 788Returns a Maypole::Constant to indicate whether the request is valid. 789 790=cut 791 792sub is_applicable { return shift->is_model_applicable(@_); } 793 794=item is_model_applicable 795 796Returns true or false to indicate whether the request is valid. 797 798The default implementation checks that C<< $r->table >> is publicly 799accessible and that the model class is configured to handle the 800C<< $r->action >>. 801 802=cut 803 804sub is_model_applicable { 805 my ($self) = @_; 806 807 # Establish which tables should be processed by the model 808 my $config = $self->config; 809 810 $config->ok_tables || $config->ok_tables( $config->display_tables ); 811 812 $config->ok_tables( { map { $_ => 1 } @{ $config->ok_tables } } ) 813 if ref $config->ok_tables eq "ARRAY"; 814 815 my $ok_tables = $config->ok_tables; 816 817 # Does this request concern a table to be processed by the model? 818 my $table = $self->table; 819 820 my $ok = 0; 821 822 if (exists $ok_tables->{$table}) 823 { 824 $ok = 1; 825 } 826 827 if (not $ok) 828 { 829 $self->warn ("We don't have that table ($table).\n" 830 . "Available tables are: " 831 . join( ",", keys %$ok_tables )) 832 if $self->debug and not $ok_tables->{$table}; 833 834 return DECLINED; 835 } 836 837 # Is the action public? 838 my $action = $self->action; 839 return OK if $self->model_class->is_public($action); 840 841 $self->warn("The action '$action' is not applicable to the table '$table'") 842 if $self->debug; 843 844 return DECLINED; 845} 846 847=item get_session 848 849Called immediately after C<start_request_hook()>. 850 851This method should return a session, which will be stored in the request's 852C<session> attribute. 853 854The default method is empty. 855 856=cut 857 858sub get_session { } 859 860=item get_user 861 862Called immediately after C<get_session>. 863 864This method should return a user, which will be stored in the request's C<user> 865attribute. 866 867The default method is empty. 868 869=cut 870 871sub get_user {} 872 873=item call_authenticate 874 875This method first checks if the relevant model class 876can authenticate the user, or falls back to the default 877authenticate method of your Maypole application. 878 879=cut 880 881sub call_authenticate 882{ 883 my ($self) = @_; 884 885 # Check if we have a model class with an authenticate() to delegate to 886 return $self->model_class->authenticate($self) 887 if $self->model_class and $self->model_class->can('authenticate'); 888 889 # Interface consistency is a Good Thing - 890 # the invocant and the argument may one day be different things 891 # (i.e. controller and request), like they are when authenticate() 892 # is called on a model class (i.e. model and request) 893 return $self->authenticate($self); 894} 895 896=item authenticate 897 898Returns a Maypole::Constant to indicate whether the user is authenticated for 899the Maypole request. 900 901The default implementation returns C<OK> 902 903=cut 904 905sub authenticate { return OK } 906 907 908=item call_exception 909 910This model is called to catch exceptions, first after authenticate, then after 911processing the model class, and finally to check for exceptions from the view 912class. 913 914This method first checks if the relevant model class 915can handle exceptions the user, or falls back to the default 916exception method of your Maypole application. 917 918=cut 919 920sub call_exception 921{ 922 my ($self, $error, $when) = @_; 923 924 # Check if we have a model class with an exception() to delegate to 925 if ( $self->model_class && $self->model_class->can('exception') ) 926 { 927 my $status = $self->model_class->exception( $self, $error, $when ); 928 return $status if $status == OK; 929 } 930 931 return $self->exception($error, $when); 932} 933 934 935=item exception 936 937This method is called if any exceptions are raised during the authentication or 938model/view processing. It should accept the exception as a parameter and return 939a Maypole::Constant to indicate whether the request should continue to be 940processed. 941 942=cut 943 944sub exception { 945 my ($self, $error, $when) = @_; 946 if (ref $self->view_object && $self->view_object->can("report_error") and $self->debug) { 947 $self->view_object->report_error($self, $error, $when); 948 return OK; 949 } 950 return ERROR; 951} 952 953=item additional_data 954 955Called before the model processes the request, this method gives you a chance to 956do some processing for each request, for example, manipulating C<template_args>. 957 958=cut 959 960sub additional_data { } 961 962=item send_output 963 964Sends the output and additional headers to the user. 965 966=cut 967 968sub send_output { 969 die "send_output is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; 970} 971 972 973=back 974 975=head2 Path processing and manipulation 976 977=over 4 978 979=item path 980 981Returns the request path 982 983=item parse_path 984 985Parses the request path and sets the C<args>, C<action> and C<table> 986properties. Calls C<preprocess_path> before parsing path and setting properties. 987 988=cut 989 990sub parse_path { 991 my ($self) = @_; 992 993 # Previous versions unconditionally set table, action and args to whatever 994 # was in @pi (or else to defaults, if @pi is empty). 995 # Adding preprocess_path(), and then setting table, action and args 996 # conditionally, broke lots of tests, hence this: 997 $self->$_(undef) for qw/action table args/; 998 $self->preprocess_path; 999 1000 # use frontpage template for frontpage 1001 unless ($self->path && $self->path ne '/') { 1002 $self->path('frontpage'); 1003 } 1004 1005 my @pi = grep {length} split '/', $self->path; 1006 1007 $self->table || $self->table(shift @pi); 1008 $self->action || $self->action( shift @pi or 'index' ); 1009 $self->args || $self->args(\@pi); 1010} 1011 1012=item preprocess_path 1013 1014Sometimes when you don't want to rewrite or over-ride parse_path but 1015want to rewrite urls or extract data from them before it is parsed, 1016the preprocess_path/location methods allow you to munge paths and urls 1017before maypole maps them to actions, classes, etc. 1018 1019This method is called after parse_location has populated the request 1020information and before parse_path has populated the model and action 1021information, and is passed the request object. 1022 1023You can set action, args or table in this method and parse_path will 1024then leave those values in place or populate them based on the current 1025value of the path attribute if they are not present. 1026 1027=cut 1028 1029sub preprocess_path { }; 1030 1031=item preprocess_location 1032 1033This method is called at the start of parse_location, after the headers in, and allows you 1034to rewrite the url used by maypole, or dynamically set configuration 1035like the base_uri based on the hostname or path. 1036 1037=cut 1038 1039sub preprocess_location { }; 1040 1041=item make_path( %args or \%args or @args ) 1042 1043This is the counterpart to C<parse_path>. It generates a path to use 1044in links, form actions etc. To implement your own path scheme, just override 1045this method and C<parse_path>. 1046 1047 %args = ( table => $table, 1048 action => $action, 1049 additional => $additional, # optional - generally an object ID 1050 ); 1051 1052 \%args = as above, but a ref 1053 1054 @args = ( $table, $action, $additional ); # $additional is optional 1055 1056C<id> can be used as an alternative key to C<additional>. 1057 1058C<$additional> can be a string, an arrayref, or a hashref. An arrayref is 1059expanded into extra path elements, whereas a hashref is translated into a query 1060string. 1061 1062=cut 1063 1064 1065sub make_path 1066{ 1067 my $r = shift; 1068 1069 my %args; 1070 1071 if (@_ == 1 and ref $_[0] and ref $_[0] eq 'HASH') 1072 { 1073 %args = %{$_[0]}; 1074 } 1075 elsif ( @_ > 1 and @_ < 4 ) 1076 { 1077 $args{table} = shift; 1078 $args{action} = shift; 1079 $args{additional} = shift; 1080 } 1081 else 1082 { 1083 %args = @_; 1084 } 1085 1086 do { die "no $_" unless $args{$_} } for qw( table action ); 1087 1088 my $additional = $args{additional} || $args{id}; 1089 1090 my @add = (); 1091 1092 if ($additional) 1093 { 1094 # if $additional is a href, make_uri() will transform it into a query 1095 @add = (ref $additional eq 'ARRAY') ? @$additional : ($additional); 1096 } 1097 1098 my $uri = $r->make_uri($args{table}, $args{action}, @add); 1099 1100 return $uri->as_string; 1101} 1102 1103 1104 1105=item make_uri( @segments ) 1106 1107Make a L<URI> object given table, action etc. Automatically adds 1108the C<uri_base>. 1109 1110If the final element in C<@segments> is a hash ref, C<make_uri> will render it 1111as a query string. 1112 1113=cut 1114 1115sub make_uri 1116{ 1117 my ($r, @segments) = @_; 1118 1119 my $query = (ref $segments[-1] eq 'HASH') ? pop(@segments) : undef; 1120 1121 my $base = $r->config->uri_base; 1122 $base =~ s|/$||; 1123 1124 my $uri = URI->new($base); 1125 $uri->path_segments($uri->path_segments, grep {length} @segments); 1126 1127 my $abs_uri = $uri->abs('/'); 1128 $abs_uri->query_form($query) if $query; 1129 return $abs_uri; 1130} 1131 1132=item parse_args 1133 1134Turns post data and query string paramaters into a hash of C<params>. 1135 1136You should only need to define this method if you are writing a new Maypole 1137backend. 1138 1139=cut 1140 1141sub parse_args 1142{ 1143 die "parse_args() is a virtual method. Do not use Maypole directly; ". 1144 "use Apache::MVC or similar"; 1145} 1146 1147=item get_template_root 1148 1149Implementation-specific path to template root. 1150 1151You should only need to define this method if you are writing a new Maypole 1152backend. Otherwise, see L<Maypole::Config/"template_root"> 1153 1154=cut 1155 1156=back 1157 1158=head2 Request properties 1159 1160=over 4 1161 1162=item model_class 1163 1164Returns the perl package name that will serve as the model for the 1165request. It corresponds to the request C<table> attribute. 1166 1167 1168=item objects 1169 1170Get/set a list of model objects. The objects will be accessible in the view 1171templates. 1172 1173If the first item in C<$self-E<gt>args> can be C<retrieve()>d by the model 1174class, it will be removed from C<args> and the retrieved object will be added to 1175the C<objects> list. See L<Maypole::Model> for more information. 1176 1177 1178=item object 1179 1180Alias to get/set the first/only model object. The object will be accessible 1181in the view templates. 1182 1183When used to set the object, will overwrite the request objects 1184with a single object. 1185 1186=cut 1187 1188sub object { 1189 my ($r,$object) = @_; 1190 $r->objects([$object]) if ($object); 1191 return undef unless $r->objects(); 1192 return $r->objects->[0]; 1193} 1194 1195=item template_args 1196 1197 $self->template_args->{foo} = 'bar'; 1198 1199Get/set a hash of template variables. 1200 1201Maypole reserved words for template variables will over-ride values in template_variables. 1202 1203Reserved words are : r, request, object, objects, base, config and errors, as well as the 1204current class or object name. 1205 1206=item stash 1207 1208A place to put custom application data. Not used by Maypole itself. 1209 1210=item template 1211 1212Get/set the template to be used by the view. By default, it returns 1213C<$self-E<gt>action> 1214 1215 1216=item error 1217 1218Get/set a request error 1219 1220=item output 1221 1222Get/set the response output. This is usually populated by the view class. You 1223can skip view processing by setting the C<output>. 1224 1225=item table 1226 1227The table part of the Maypole request path 1228 1229=item action 1230 1231The action part of the Maypole request path 1232 1233=item args 1234 1235A list of remaining parts of the request path after table and action 1236have been 1237removed 1238 1239=item headers_in 1240 1241A L<Maypole::Headers> object containing HTTP headers for the request 1242 1243=item headers_out 1244 1245A L<HTTP::Headers> object that contains HTTP headers for the output 1246 1247=item document_encoding 1248 1249Get/set the output encoding. Default: utf-8. 1250 1251=item content_type 1252 1253Get/set the output content type. Default: text/html 1254 1255=item get_protocol 1256 1257Returns the protocol the request was made with, i.e. https 1258 1259=cut 1260 1261sub get_protocol { 1262 die "get_protocol is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; 1263} 1264 1265=back 1266 1267=head2 Request parameters 1268 1269The source of the parameters may vary depending on the Maypole backend, but they 1270are usually populated from request query string and POST data. 1271 1272Maypole supplies several approaches for accessing the request parameters. Note 1273that the current implementation (via a hashref) of C<query> and C<params> is 1274likely to change in a future version of Maypole. So avoid direct access to these 1275hashrefs: 1276 1277 $r->{params}->{foo} # bad 1278 $r->params->{foo} # better 1279 1280 $r->{query}->{foo} # bad 1281 $r->query->{foo} # better 1282 1283 $r->param('foo') # best 1284 1285=over 4 1286 1287=item param 1288 1289An accessor (get or set) for request parameters. It behaves similarly to 1290CGI::param() for accessing CGI parameters, i.e. 1291 1292 $r->param # returns list of keys 1293 $r->param($key) # returns value for $key 1294 $r->param($key => $value) # returns old value, sets to new value 1295 1296=cut 1297 1298sub param 1299{ 1300 my ($self, $key) = (shift, shift); 1301 1302 return keys %{$self->params} unless defined $key; 1303 1304 return unless exists $self->params->{$key}; 1305 1306 my $val = $self->params->{$key}; 1307 1308 if (@_) 1309 { 1310 my $new_val = shift; 1311 $self->params->{$key} = $new_val; 1312 } 1313 1314 return (ref $val eq 'ARRAY') ? @$val : ($val) if wantarray; 1315 1316 return (ref $val eq 'ARRAY') ? $val->[0] : $val; 1317} 1318 1319 1320=item params 1321 1322Returns a hashref of request parameters. 1323 1324B<Note:> Where muliple values of a parameter were supplied, the C<params> value 1325will be an array reference. 1326 1327=item query 1328 1329Alias for C<params>. 1330 1331=back 1332 1333=head3 Utility methods 1334 1335=over 4 1336 1337=item redirect_request 1338 1339Sets output headers to redirect based on the arguments provided 1340 1341Accepts either a single argument of the full url to redirect to, or a hash of 1342named parameters : 1343 1344$r->redirect_request('http://www.example.com/path'); 1345 1346or 1347 1348$r->redirect_request(protocol=>'https', domain=>'www.example.com', path=>'/path/file?arguments', status=>'302', url=>'..'); 1349 1350The named parameters are protocol, domain, path, status and url 1351 1352Only 1 named parameter is required but other than url, they can be combined as 1353required and current values (from the request) will be used in place of any 1354missing arguments. The url argument must be a full url including protocol and 1355can only be combined with status. 1356 1357=cut 1358 1359sub redirect_request { 1360 die "redirect_request is a virtual method. Do not use Maypole directly; use Apache::MVC or similar"; 1361} 1362 1363# =item redirect_internal_request 1364# 1365# =cut 1366# 1367# sub redirect_internal_request { 1368# 1369# } 1370 1371 1372=item make_random_id 1373 1374returns a unique id for this request can be used to prevent or detect repeat 1375submissions. 1376 1377=cut 1378 1379# Session and Repeat Submission Handling 1380sub make_random_id { 1381 use Maypole::Session; 1382 return Maypole::Session::generate_unique_id(); 1383} 1384 1385=back 1386 1387=head1 SEQUENCE DIAGRAMS 1388 1389See L<Maypole::Manual::Workflow> for a detailed discussion of the sequence of 1390calls during processing of a request. This is a brief summary: 1391 1392 INITIALIZATION 1393 Model e.g. 1394 BeerDB Maypole::Model::CDBI 1395 | | 1396 setup | | 1397 o-------->|| | 1398 || setup_model | setup_database() creates 1399 ||------+ | a subclass of the Model 1400 |||<----+ | for each table 1401 ||| | | 1402 ||| setup_database | | 1403 |||--------------------->|| 'create' * 1404 ||| ||----------> $subclass 1405 ||| | | 1406 ||| load_model_subclass | | 1407 foreach |||------+ ($subclass) | | 1408 $subclass ||||<----+ | require | 1409 ||||--------------------------------------->| 1410 ||| | | 1411 ||| adopt($subclass) | | 1412 |||--------------------->|| | 1413 | | | 1414 | | | 1415 |-----+ init | | 1416 ||<---+ | | 1417 || | new | view_object: e.g. 1418 ||---------------------------------------------> Maypole::View::TT 1419 | | | | 1420 | | | | 1421 | | | | 1422 | | | | 1423 | | | | 1424 1425 1426 1427 HANDLING A REQUEST 1428 1429 1430 BeerDB Model $subclass view_object 1431 | | | | 1432 handler | | | | 1433 o-------->| new | | | 1434 |-----> r:BeerDB | | | 1435 | | | | | 1436 | | | | | 1437 | || | | | 1438 | ||-----+ parse_location | | | 1439 | |||<---+ | | | 1440 | || | | | 1441 | ||-----+ start_request_hook | | | 1442 | |||<---+ | | | 1443 | || | | | 1444 | ||-----+ get_session | | | 1445 | |||<---+ | | | 1446 | || | | | 1447 | ||-----+ get_user | | | 1448 | |||<---+ | | | 1449 | || | | | 1450 | ||-----+ handler_guts | | | 1451 | |||<---+ | | | 1452 | ||| class_of($table) | | | 1453 | |||------------------------->|| | | 1454 | ||| $subclass || | | 1455 | |||<-------------------------|| | | 1456 | ||| | | | 1457 | |||-----+ is_model_applicable| | | 1458 | ||||<---+ | | | 1459 | ||| | | | 1460 | |||-----+ call_authenticate | | | 1461 | ||||<---+ | | | 1462 | ||| | | | 1463 | |||-----+ additional_data | | | 1464 | ||||<---+ | | | 1465 | ||| process | | | 1466 | |||--------------------------------->|| fetch_objects 1467 | ||| | ||-----+ | 1468 | ||| | |||<---+ | 1469 | ||| | || | 1470 | ||| | || $action 1471 | ||| | ||-----+ | 1472 | ||| | |||<---+ | 1473 | ||| process | | | 1474 | |||------------------------------------------->|| template 1475 | ||| | | ||-----+ 1476 | ||| | | |||<---+ 1477 | ||| | | | 1478 | || send_output | | | 1479 | ||-----+ | | | 1480 | |||<---+ | | | 1481 $status | || | | | 1482 <------------------|| | | | 1483 | | | | | 1484 | X | | | 1485 | | | | 1486 | | | | 1487 | | | | 1488 1489 1490 1491=head1 SEE ALSO 1492 1493There's more documentation, examples, and information on our mailing lists 1494at the Maypole web site: 1495 1496L<http://maypole.perl.org/> 1497 1498L<Maypole::Application>, L<Apache::MVC>, L<CGI::Maypole>. 1499 1500=head1 AUTHOR 1501 1502Maypole is currently maintained by Aaron Trevena. 1503 1504=head1 AUTHOR EMERITUS 1505 1506Simon Cozens, C<simon#cpan.org> 1507 1508Simon Flack maintained Maypole from 2.05 to 2.09 1509 1510Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04 1511 1512=head1 THANKS TO 1513 1514Sebastian Riedel, Danijel Milicevic, Dave Slack, Jesse Sheidlower, Jody Belka, 1515Marcus Ramberg, Mickael Joanne, Randal Schwartz, Simon Flack, Steve Simms, 1516Veljko Vidovic and all the others who've helped. 1517 1518=head1 LICENSE 1519 1520You may distribute this code under the same terms as Perl itself. 1521 1522=cut 1523 15241; 1525 1526__END__ 1527 1528 =item register_cleanup($coderef) 1529 1530Analogous to L<Apache>'s C<register_cleanup>. If an Apache request object is 1531available, this call simply redispatches there. If not, the cleanup is 1532registered in the Maypole request, and executed when the request is 1533C<DESTROY>ed. 1534 1535This method is only useful in persistent environments, where you need to ensure 1536that some code runs when the request finishes, no matter how it finishes (e.g. 1537after an unexpected error). 1538 1539 =cut 1540 1541{ 1542 my @_cleanups; 1543 1544 sub register_cleanup 1545 { 1546 my ($self, $cleanup) = @_; 1547 1548 die "register_cleanup() is an instance method, not a class method" 1549 unless ref $self; 1550 die "Cleanup must be a coderef" unless ref($cleanup) eq 'CODE'; 1551 1552 if ($self->can('ar') && $self->ar) 1553 { 1554 $self->ar->register_cleanup($cleanup); 1555 } 1556 else 1557 { 1558 push @_cleanups, $cleanup; 1559 } 1560 } 1561 1562 sub DESTROY 1563 { 1564 my ($self) = @_; 1565 1566 while (my $cleanup = shift @_cleanups) 1567 { 1568 eval { $cleanup->() }; 1569 if ($@) 1570 { 1571 warn "Error during request cleanup: $@"; 1572 } 1573 } 1574 } 1575} 1576 1577