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