lib/Maypole.pm

   1 package Maypole;
   2 use base qw(Class::Accessor Class::Data::Inheritable);
   3 use attributes ();
   4 use Class::DBI::Loader;
   5 use UNIVERSAL::require;
   6 use Apache::Constants ":common";
   7 use strict;
   8 use warnings;
   9 our $VERSION = "0.2";
  10 __PACKAGE__->mk_classdata($_) for qw( config init_done view_object );
  11 __PACKAGE__->mk_accessors ( qw( ar params query objects model_class
  12 args action template ));
  13 __PACKAGE__->config({});
  14 __PACKAGE__->init_done(0);
  15
  16
  17 sub import {
  18     my $real = shift;
  19     if ($real ne "Apache::MVC") {
  20         no strict 'refs';
  21         *{$real."::handler"} = sub { Apache::MVC::handler($real, @_) };
  22     }
  23 }
  24
  25 sub set_database {
  26     my ($calling_class, $dsn) = @_;
  27     $calling_class = ref $calling_class if ref $calling_class;
  28     my $config = $calling_class->config;
  29     $config->{model} ||= "Apache::MVC::Model::CDBI";
  30     $config->{model}->require;
  31     $config->{dsn} = $dsn;
  32     $config->{loader} = Class::DBI::Loader->new(
  33         namespace => $calling_class,
  34         dsn => $dsn
  35     );
  36     $config->{classes} = [ $config->{loader}->classes ];
  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}  ||= "Apache::MVC::View::TT";
  49     $config->{view}->require;
  50     $config->{display_tables} ||= [ $class->config->{loader}->tables ];
  51     $class->view_object($class->config->{view}->new);
  52     $class->init_done(1);
  53
  54 }
  55
  56 sub class_of {
  57     my ($self, $table) = @_;
  58     return $self->config->{loader}->_table2class($table);
  59 }
  60
  61 sub handler {
  62     # See Apache::MVC::Workflow before trying to understand this.
  63     my $class = shift;
  64     $class->init unless $class->init_done;
  65     my $r = bless { config => $class->config }, $class;
  66     $r->get_request();
  67     $r->parse_location();
  68
  69     $r->model_class($r->class_of($r->{table}));
  70     my $status = $r->is_applicable;
  71     if ($status == OK) {
  72         $status = $r->call_authenticate;
  73         return $status unless $status == OK;
  74         $r->additional_data();
  75
  76         $r->model_class->process($r);
  77     } else {
  78         # Otherwise, it's just a plain template.
  79         delete $r->{model_class};
  80         $r->{path} =~ s{/}{}; # De-absolutify
  81         $r->template($r->{path});
  82     }
  83     return $r->view_object->process($r);
  84 }
  85
  86 sub get_request {
  87     my $self = shift;
  88     require Apache; require Apache::Request;
  89     $self->{ar} = Apache::Request->new(Apache->request);
  90 }
  91
  92 sub parse_location {
  93     my $self = shift;
  94     $self->{path} = $self->{ar}->uri;
  95     my $loc = $self->{ar}->location;
  96     $self->{path} =~ s/^$loc//; # I shouldn't need to do this?
  97     $self->{path} ||= "frontpage";
  98     my @pi = split /\//, $self->{path};
  99     shift @pi while @pi and !$pi[0];
 100     $self->{table} = shift @pi;
 101     $self->{action} = shift @pi;
 102     $self->{args} = \@pi;
 103
 104     $self->{params} = { $self->{ar}->content };
 105     $self->{query}  = { $self->{ar}->args };
 106 }
 107
 108 sub is_applicable {
 109     my $self = shift;
 110     my $config = $self->config;
 111     $config->{ok_tables} = {map {$_ => 1} @{$config->{display_tables}}};
 112     warn "We don't have that table ($self->{table})"
 113         unless $config->{ok_tables}{$self->{table}};
 114     return DECLINED() unless exists $config->{ok_tables}{$self->{table}};
 115
 116     # Does the action method exist?
 117     my $cv = $self->model_class->can($self->{action});
 118     warn "We don't have that action ($self->{action})" unless $cv;
 119     return DECLINED() unless $cv;
 120
 121     # Is it exported?
 122     $self->{method_attribs} = join " ", attributes::get($cv);
 123     do { warn "$self->{action} not exported";
 124     return DECLINED()
 125      } unless $self->{method_attribs} =~ /\bExported\b/i;
 126     return OK();
 127 }
 128
 129 sub call_authenticate {
 130     my $self = shift;
 131     return $self->model_class->authenticate($self) if
 132         $self->model_class->can("authenticate");
 133     return $self->authenticate();
 134 }
 135
 136 sub additional_data {}
 137
 138 sub authenticate { return OK }
 139
 140 1;
 141
 142 =head1 NAME
 143
 144 Maypole - MVC web application framework
 145
 146 =head1 SYNOPSIS
 147
 148 See L<Apache::MVC>.
 149
 150 =head1 DESCRIPTION
 151
 152 A large number of web programming tasks follow the same sort of pattern:
 153 we have some data in a datasource, typically a relational database. We
 154 have a bunch of templates provided by web designers. We have a number of
 155 things we want to be able to do with the database - create, add, edit,
 156 delete records, view records, run searches, and so on. We have a web
 157 server which provides input from the user about what to do. Something in
 158 the middle takes the input, grabs the relevant rows from the database,
 159 performs the action, constructs a page, and spits it out.
 160
 161 Maypole aims to be the most generic and extensible "something in the
 162 middle" - an MVC-based web application framework.
 163
 164 An example would help explain this best. You need to add a product
 165 catalogue to a company's web site. Users need to list the products in
 166 various categories, view a page on each product with its photo and
 167 pricing information and so on, and there needs to be a back-end where
 168 sales staff can add new lines, change prices, and delete out of date
 169 records. So, you set up the database, provide some default templates
 170 for the designers to customize, and then write an Apache handler like
 171 this:
 172
 173     package ProductDatabase;
 174     use base 'Apache::MVC';
 175     __PACKAGE__->set_database("dbi:mysql:products");
 176     BeerDB->config->{uri_base} = "http://your.site/catalogue/";
 177     ProductDatabase::Product->has_a("category" => ProductDatabase::Category);
 178     # ...
 179
 180     sub authenticate {
 181         my ($self, $request) = @_;
 182         return OK if $request->{ar}->get_remote_host() eq "sales.yourcorp.com";
 183         return OK if $request->{action} =~ /^(view|list)$/;
 184         return DECLINED;
 185     }
 186     1;
 187
 188 You then put the following in your Apache config:
 189
 190     <Location /catalogue>
 191         SetHandler perl-script
 192         PerlHandler ProductDatabase
 193     </Location>
 194
 195 And copy the templates found in F<templates/factory> into the
 196 F<catalogue/factory> directory off the web root. When the designers get
 197 back to you with custom templates, they are to go in
 198 F<catalogue/custom>. If you need to do override templates on a
 199 database-table-by-table basis, put the new template in
 200 F<catalogue/I<table>>.
 201
 202 This will automatically give you C<add>, C<edit>, C<list>, C<view> and
 203 C<delete> commands; for instance, a product list, go to
 204
 205     http://your.site/catalogue/product/list
 206
 207 For a full example, see the included "beer database" application.
 208
 209 =head1 HOW IT WORKS
 210
 211 There's some documentation for the workflow in L<Apache::MVC::Workflow>,
 212 but the basic idea is that a URL part like C<product/list> gets
 213 translated into a call to C<ProductDatabase::Product-E<gt>list>. This
 214 propagates the request with a set of objects from the database, and then
 215 calls the C<list> template; first, a C<product/list> template if it
 216 exists, then the C<custom/list> and finally C<factory/list>.
 217
 218 If there's another action you want the system to do, you need to either
 219 subclass the model class, and configure your class slightly differently:
 220
 221     package ProductDatabase::Model;
 222     use base 'Apache::MVC::Model::CDBI';
 223
 224     sub supersearch :Exported {
 225         my ($self, $request) = @_;
 226         # Do stuff, get a bunch of objects back
 227         $r->objects(\@objects);
 228         $r->template("template_name");
 229     }
 230
 231     ProductDatabase->config->{model_class} = "ProductDatabase::Model";
 232
 233 (The C<:Exported> attribute means that the method can be called via the
 234 URL C</I<table>/supersearch/...>.)
 235
 236 Alternatively, you can put the method directly into the specific model
 237 class for the table:
 238
 239     sub ProductDatabase::Product::supersearch :Exported { ... }
 240
 241 By default, the view class uses Template Toolkit as the template
 242 processor, and the model class uses C<Class::DBI>; it may help you to be
 243 familiar with these modules before going much further with this,
 244 although I expect there to be other subclasses for other templating
 245 systems and database abstraction layers as time goes on. The article at
 246 C<http://www.perl.com/pub/a/2003/07/15/nocode.html> is a great
 247 introduction to the process we're trying to automate.
 248
 249 =head1 AUTHOR
 250
 251 Simon Cozens, C<simon@cpan.org>
 252
 253 =head1 LICENSE
 254
 255 You may distribute this code under the same terms as Perl itself.