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
  11 __PACKAGE__->mk_classdata($_) for qw( _config init_done view_object );
  12 __PACKAGE__->mk_accessors ( qw( config ar params objects model_class
  13 args action template ));
  14 __PACKAGE__->config({});
  15 __PACKAGE__->init_done(0);
  16
  17 # This is really dirty.
  18 sub config {
  19     my $self = shift;
  20     if (ref $self) { return $self->_config_accessor(@_) }
  21     return $self->_config(@_);
  22 }
  23
  24 sub set_database {
  25     my ($calling_class, $dsn) = @_;
  26     $calling_class = ref $calling_class if ref $calling_class;
  27     $calling_class->config->{dsn} = $dsn;
  28     $calling_class->config->{loader} = Class::DBI::Loader->new(
  29         namespace => $calling_class,
  30         dsn => $dsn
  31     );
  32 }
  33
  34 sub init {
  35     my $class = shift;
  36     my $config = $class->config;
  37     $config->{model} ||= "Apache::MVC::Model::CDBI";
  38     $config->{view}  ||= "Apache::MVC::View::TT";
  39     $config->{model}->require;
  40     $config->{view}->require;
  41     $config->{classes} = [ $class->config->{loader}->classes ];
  42     $config->{display_tables} ||= [ $class->config->{loader}->tables ];
  43     for my $subclass (@{$config->{classes}}) {
  44         no strict 'refs';
  45         push @{$subclass."::ISA"}, $class->config->{model};
  46     }
  47     $class->view_object($class->config->{view}->new);
  48     $class->init_done(1);
  49
  50 }
  51
  52 sub class_of {
  53     my ($self, $table) = @_;
  54     return $self->config->{loader}->_table2class($table);
  55 }
  56
  57 sub handler {
  58     # See Apache::MVC::Workflow before trying to understand this.
  59     # XXX This needs to work with Apache without method handlers
  60     my $class = shift;
  61     $class->init unless $class->init_done;
  62     my $r = bless { config => $class->config }, $class;
  63     $r->get_request();
  64     $r->parse_location();
  65     $r->model_class($r->class_of($r->{table}));
  66     my $status = $r->is_applicable;
  67     return $status unless $status == OK;
  68     $status = $r->call_authenticate;
  69     return $status unless $status == OK;
  70     $r->additional_data();
  71     $r->model_class->process($r);
  72     $r->view_object->process($r);
  73     return $r; # For debugging.
  74 }
  75
  76 sub get_request {
  77     my $self = shift;
  78     require Apache; require Apache::Request;
  79     $self->{ar} = Apache::Request->new(Apache->request);
  80 }
  81
  82 sub parse_location {
  83     my $self = shift;
  84     my @pi = split /\//, $self->{ar}->uri();
  85     shift @pi while @pi and !$pi[0];
  86     $self->{table} = shift @pi;
  87     $self->{action} = shift @pi;
  88     $self->{args} = \@pi;
  89
  90     $self->{params} = $self->{ar}->content;
  91 }
  92
  93 sub is_applicable {
  94     my $self = shift;
  95     my $config = $self->config;
  96     my %ok = map {$_ => 1} @{$config->{display_tables}};
  97     return DECLINED() unless exists $ok{$self->{table}};
  98
  99     # Does the action method exist?
 100     my $cv = $self->model_class->can($self->{action});
 101     return DECLINED() unless $cv;
 102
 103     # Is it exported?
 104     $self->{method_attribs} = join " ", attributes::get($cv);
 105     return DECLINED()
 106      unless $self->{method_attribs} =~ /\bExported\b/i;
 107     return OK();
 108 }
 109
 110 sub call_authenticate {
 111     my $self = shift;
 112     return $self->model_class->authenticate($self) if
 113         $self->model_class->can("authenticate");
 114     return $self->authenticate();
 115 }
 116
 117 sub additional_data {}
 118
 119 sub authenticate { return OK }
 120
 121 1;