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 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 # 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     $self->{query}  = { $self->{ar}->args };
 113 }
 114
 115 sub is_applicable {
 116     my $self = shift;
 117     my $config = $self->config;
 118     $config->{ok_tables} = {map {$_ => 1} @{$config->{display_tables}}};
 119     warn "We don't have that table ($self->{table})"
 120         unless $config->{ok_tables}{$self->{table}};
 121     return DECLINED() unless exists $config->{ok_tables}{$self->{table}};
 122
 123     # Does the action method exist?
 124     my $cv = $self->model_class->can($self->{action});
 125     warn "We don't have that action ($self->{action})" unless $cv;
 126     return DECLINED() unless $cv;
 127
 128     # Is it exported?
 129     $self->{method_attribs} = join " ", attributes::get($cv);
 130     do { warn "$self->{action} not exported";
 131     return DECLINED()
 132      } unless $self->{method_attribs} =~ /\bExported\b/i;
 133     return OK();
 134 }
 135
 136 sub call_authenticate {
 137     my $self = shift;
 138     return $self->model_class->authenticate($self) if
 139         $self->model_class->can("authenticate");
 140     return $self->authenticate();
 141 }
 142
 143 sub additional_data {}
 144
 145 sub authenticate { return OK }
 146
 147 1;
 148
 149 =head1 NAME
 150
 151 Apache::MVC - Web front end to a data source
 152
 153 =head1 SYNOPSIS
 154
 155     package BeerDB;
 156     use base 'Apache::MVC';
 157     sub handler { Apache::MVC::handler("BeerDB", @_) }
 158     BeerDB->set_database("dbi:mysql:beerdb");
 159     BeerDB->config->{uri_base} = "http://your.site/";
 160     BeerDB->config->{display_tables} = [qw[beer brewery pub style]];
 161     # Now set up your database:
 162     # has-a relationships
 163     # untaint columns
 164
 165     1;
 166
 167 =head1 DESCRIPTION
 168
 169 A large number of web programming tasks follow the same sort of pattern:
 170 we have some data in a datasource, typically a relational database. We
 171 have a bunch of templates provided by web designers. We have a number of
 172 things we want to be able to do with the database - create, add, edit,
 173 delete records, view records, run searches, and so on. We have a web
 174 server which provides input from the user about what to do. Something in
 175 the middle takes the input, grabs the relevant rows from the database,
 176 performs the action, constructs a page, and spits it out.
 177
 178 This module aims to be the most generic and extensible "something in the
 179 middle".
 180
 181 An example would help explain this best. You need to add a product
 182 catalogue to a company's web site. Users need to list the products in
 183 various categories, view a page on each product with its photo and
 184 pricing information and so on, and there needs to be a back-end where
 185 sales staff can add new lines, change prices, and delete out of date
 186 records. So, you set up the database, provide some default templates
 187 for the designers to customize, and then write an Apache handler like
 188 this:
 189
 190     package ProductDatabase;
 191     use base 'Apache::MVC';
 192     __PACKAGE__->set_database("dbi:mysql:products");
 193     BeerDB->config->{uri_base} = "http://your.site/catalogue/";
 194     ProductDatabase::Product->has_a("category" => ProductDatabase::Category);
 195     # ...
 196
 197     sub authenticate {
 198         my ($self, $request) = @_;
 199         return OK if $request->{ar}->get_remote_host() eq "sales.yourcorp.com";
 200         return OK if $request->{action} =~ /^(view|list)$/;
 201         return DECLINED;
 202     }
 203     1;
 204
 205 You then put the following in your Apache config:
 206
 207     <Location /catalogue>
 208         SetHandler perl-script
 209         PerlHandler ProductDatabase
 210     </Location>
 211
 212 And copy the templates found in F<templates/factory> into the
 213 F<catalogue/factory> directory off the web root. When the designers get
 214 back to you with custom templates, they are to go in
 215 F<catalogue/custom>. If you need to do override templates on a
 216 database-table-by-table basis, put the new template in
 217 F<catalogue/I<table>>.
 218
 219 This will automatically give you C<add>, C<edit>, C<list>, C<view> and
 220 C<delete> commands; for instance, a product list, go to
 221
 222     http://your.site/catalogue/product/list
 223
 224 For a full example, see the included "beer database" application.
 225
 226 =head1 HOW IT WORKS
 227
 228 There's some documentation for the workflow in L<Apache::MVC::Workflow>,
 229 but the basic idea is that a URL part like C<product/list> gets
 230 translated into a call to C<ProductDatabase::Product-E<gt>list>. This
 231 propagates the request with a set of objects from the database, and then
 232 calls the C<list> template; first, a C<product/list> template if it
 233 exists, then the C<custom/list> and finally C<factory/list>.
 234
 235 If there's another action you want the system to do, you need to either
 236 subclass the model class, and configure your class slightly differently:
 237
 238     package ProductDatabase::Model;
 239     use base 'Apache::MVC::Model::CDBI';
 240
 241     sub supersearch :Exported {
 242         my ($self, $request) = @_;
 243         # Do stuff, get a bunch of objects back
 244         $r->objects(\@objects);
 245         $r->template("template_name");
 246     }
 247
 248     ProductDatabase->config->{model_class} = "ProductDatabase::Model";
 249
 250 (The C<:Exported> attribute means that the method can be called via the
 251 URL C</I<table>/supersearch/...>.)
 252
 253 Alternatively, you can put the method directly into the specific model
 254 class for the table:
 255
 256     sub ProductDatabase::Product::supersearch :Exported { ... }
 257
 258 By default, the view class uses Template Toolkit as the template
 259 processor, and the model class uses C<Class::DBI>; it may help you to be
 260 familiar with these modules before going much further with this,
 261 although I expect there to be other subclasses for other templating
 262 systems and database abstraction layers as time goes on. The article at
 263 C<http://www.perl.com/pub/a/2003/07/15/nocode.html> is a great
 264 introduction to the process we're trying to automate.
 265
 266 =head1 AUTHOR
 267
 268 Simon Cozens, C<simon@cpan.org>
 269
 270 =head1 LICENSE
 271
 272 You may distribute this code under the same terms as Perl itself.