lib/Apache/MVC.pm

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