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 = "1.0";
  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     $calling_class->config->{dsn} = $dsn;
  36     $calling_class->config->{loader} = Class::DBI::Loader->new(
  37         namespace => $calling_class,
  38         dsn => $dsn
  39     );
  40 }
  41
  42 sub init {
  43     my $class = shift;
  44     my $config = $class->config;
  45     $config->{model} ||= "Apache::MVC::Model::CDBI";
  46     $config->{view}  ||= "Apache::MVC::View::TT";
  47     $config->{model}->require;
  48     $config->{view}->require;
  49     $config->{classes} = [ $class->config->{loader}->classes ];
  50     $config->{display_tables} ||= [ $class->config->{loader}->tables ];
  51     for my $subclass (@{$config->{classes}}) {
  52         no strict 'refs';
  53         push @{$subclass."::ISA"}, $class->config->{model};
  54     }
  55     $class->view_object($class->config->{view}->new);
  56     $class->init_done(1);
  57
  58 }
  59
  60 sub class_of {
  61     my ($self, $table) = @_;
  62     return $self->config->{loader}->_table2class($table);
  63 }
  64
  65 sub handler {
  66     # See Apache::MVC::Workflow before trying to understand this.
  67     my $class = shift;
  68     $class->init unless $class->init_done;
  69     my $r = bless { config => $class->config }, $class;
  70     $r->get_request();
  71     $r->parse_location();
  72
  73     $r->model_class($r->class_of($r->{table}));
  74     my $status = $r->is_applicable;
  75     return $status unless $status == OK;
  76     $status = $r->call_authenticate;
  77     return $status unless $status == OK;
  78     $r->additional_data();
  79
  80     $r->model_class->process($r);
  81     $r->view_object->process($r);
  82     return $r; # For debugging.
  83 }
  84
  85 sub get_request {
  86     my $self = shift;
  87     require Apache; require Apache::Request;
  88     $self->{ar} = Apache::Request->new(Apache->request);
  89 }
  90
  91 sub parse_location {
  92     my $self = shift;
  93     my $uri = $self->{ar}->path_info();
  94     my @pi = split /\//, $uri;
  95     shift @pi while @pi and !$pi[0];
  96     $self->{table} = shift @pi;
  97     $self->{action} = shift @pi;
  98     $self->{args} = \@pi;
  99
 100     $self->{params} = $self->{ar}->content;
 101 }
 102
 103 sub is_applicable {
 104     my $self = shift;
 105     my $config = $self->config;
 106     my %ok = map {$_ => 1} @{$config->{display_tables}};
 107     return DECLINED() unless exists $ok{$self->{table}};
 108
 109     # Does the action method exist?
 110     my $cv = $self->model_class->can($self->{action});
 111     return DECLINED() unless $cv;
 112
 113     # Is it exported?
 114     $self->{method_attribs} = join " ", attributes::get($cv);
 115     return DECLINED()
 116      unless $self->{method_attribs} =~ /\bExported\b/i;
 117     return OK();
 118 }
 119
 120 sub call_authenticate {
 121     my $self = shift;
 122     return $self->model_class->authenticate($self) if
 123         $self->model_class->can("authenticate");
 124     return $self->authenticate();
 125 }
 126
 127 sub additional_data {}
 128
 129 sub authenticate { return OK }
 130
 131 1;