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     warn "Parsed location\n";
  77     $r->model_class($r->class_of($r->{table}));
  78     my $status = $r->is_applicable;
  79     if ($status == OK) {
  80         $status = $r->call_authenticate;
  81         return $status unless $status == OK;
  82         $r->additional_data();
  83
  84         $r->model_class->process($r);
  85     } else {
  86         warn "Plain template $r->{path}";
  87         # Otherwise, it's just a plain template.
  88         delete $r->{model_class};
  89         $r->{path} =~ s{/}{}; # De-absolutify
  90         $r->template($r->{path});
  91         warn $r->template;
  92     }
  93     return $r->view_object->process($r);
  94 }
  95
  96 sub get_request {
  97     my $self = shift;
  98     require Apache; require Apache::Request;
  99     $self->{ar} = Apache::Request->new(Apache->request);
 100 }
 101
 102 sub parse_location {
 103     my $self = shift;
 104     $self->{path} = $self->{ar}->uri;
 105     my $loc = $self->{ar}->location;
 106     $self->{path} =~ s/^$loc//; # I shouldn't need to do this?
 107     warn "Path is $self->{path}";
 108     my @pi = split /\//, $self->{path};
 109     shift @pi while @pi and !$pi[0];
 110     $self->{table} = shift @pi;
 111     $self->{action} = shift @pi;
 112     $self->{args} = \@pi;
 113
 114     $self->{params} = { $self->{ar}->content };
 115 }
 116
 117 sub is_applicable {
 118     my $self = shift;
 119     my $config = $self->config;
 120     $config->{ok_tables} = {map {$_ => 1} @{$config->{display_tables}}};
 121     warn "We don't have that table ($self->{table})"
 122         unless $config->{ok_tables}{$self->{table}};
 123     return DECLINED() unless exists $config->{ok_tables}{$self->{table}};
 124
 125     # Does the action method exist?
 126     my $cv = $self->model_class->can($self->{action});
 127     warn "We don't have that action ($self->{action})" unless $cv;
 128     return DECLINED() unless $cv;
 129
 130     # Is it exported?
 131     $self->{method_attribs} = join " ", attributes::get($cv);
 132     do { warn "$self->{action} not exported";
 133     return DECLINED()
 134      } unless $self->{method_attribs} =~ /\bExported\b/i;
 135     return OK();
 136 }
 137
 138 sub call_authenticate {
 139     my $self = shift;
 140     return $self->model_class->authenticate($self) if
 141         $self->model_class->can("authenticate");
 142     return $self->authenticate();
 143 }
 144
 145 sub additional_data {}
 146
 147 sub authenticate { return OK }
 148
 149 1;
 150
 151 =head1 NAME
 152
 153 Apache::MVC - Web front end to a data source
 154
 155 =head1 SYNOPSIS
 156
 157     package BeerDB;
 158     use base 'Apache::MVC';
 159     sub handler { Apache::MVC::handler("BeerDB", @_) }
 160     BeerDB->set_database("dbi:mysql:beerdb");
 161     BeerDB->config->{uri_base} = "http://your.site/";
 162     BeerDB->config->{display_tables} = [qw[beer brewery pub style]];
 163     # Now set up your database:
 164     # has-a relationships
 165     # untaint columns
 166
 167     1;
 168
 169 =haed1 DESCRIPTION
 170
 171 A large number of web programming tasks follow the same sort of pattern:
 172 we have some data in a datasource, typically a relational database. We
 173 have a bunch of templates provided by web designers. We have a number of
 174 things we want to be able to do with the database - create, add, edit,
 175 delete records, view records, run searches, and so on. We have a web
 176 server which provides input from the user about what to do. Something in
 177 the middle takes the input, grabs the relevant rows from the database,
 178 performs the action, constructs a page, and spits it out.
 179
 180 This module aims to be the most generic and extensible "something in the
 181 middle".
 182
 183 An example would help explain this best. You need to add a product
 184 catalogue to a company's web site. Users need to list the products in
 185 various categories, view a page on each product with its photo and
 186 pricing information and so on, and there needs to be a back-end where
 187 sales staff can add new lines, change prices, and delete out of date
 188 records. So, you set up the database, provide some default templates
 189 for the designers to customize, and then write an Apache handler like
 190 this:
 191
 192     package MyCorp::ProductDatabase;
 193     use base 'Apache::MVC';
 194     __PACKAGE__->set_database("dbi:mysql:products");
 195