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