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         unshift @{$subclass."::ISA"}, $class->config->{model};
  54         $config->{model}->adopt($subclass)
  55            if $config->{model}->can("adopt");
  56     }
  57     $class->view_object($class->config->{view}->new);
  58     $class->init_done(1);
  59
  60 }
  61
  62 sub class_of {
  63     my ($self, $table) = @_;
  64     return $self->config->{loader}->_table2class($table);
  65 }
  66
  67 sub handler {
  68     # See Apache::MVC::Workflow before trying to understand this.
  69     my $class = shift;
  70     $class->init unless $class->init_done;
  71     my $r = bless { config => $class->config }, $class;
  72     $r->get_request();
  73     $r->parse_location();
  74
  75     $r->model_class($r->class_of($r->{table}));
  76     my $status = $r->is_applicable;
  77     return $status unless $status == OK;
  78     $status = $r->call_authenticate;
  79     return $status unless $status == OK;
  80     $r->additional_data();
  81
  82     $r->model_class->process($r);
  83     $r->view_object->process($r);
  84     return $r; # For debugging.
  85 }
  86
  87 sub get_request {
  88     my $self = shift;
  89     require Apache; require Apache::Request;
  90     $self->{ar} = Apache::Request->new(Apache->request);
  91 }
  92
  93 sub parse_location {
  94     my $self = shift;
  95     my $uri = $self->{ar}->path_info();
  96     my @pi = split /\//, $uri;
  97     shift @pi while @pi and !$pi[0];
  98     $self->{table} = shift @pi;
  99     $self->{action} = shift @pi;
 100     $self->{args} = \@pi;
 101
 102     $self->{params} = { $self->{ar}->content };
 103 }
 104
 105 sub is_applicable {
 106     my $self = shift;
 107     my $config = $self->config;
 108     my %ok = map {$_ => 1} @{$config->{display_tables}};
 109     warn "We don't have that table ($self->{table})"
 110         unless $ok{$self->{table}};
 111     return DECLINED() unless exists $ok{$self->{table}};
 112
 113     # Does the action method exist?
 114     # XXX We should set the method class to the class for the table
 115     my $cv = $self->model_class->can($self->{action});
 116     warn "We don't have that action ($self->{action})" unless $cv;
 117     return DECLINED() unless $cv;
 118
 119     # Is it exported?
 120     $self->{method_attribs} = join " ", attributes::get($cv);
 121     do { warn "$self->{action} not exported";
 122     return DECLINED()
 123      } unless $self->{method_attribs} =~ /\bExported\b/i;
 124     return OK();
 125 }
 126
 127 sub call_authenticate {
 128     my $self = shift;
 129     return $self->model_class->authenticate($self) if
 130         $self->model_class->can("authenticate");
 131     return $self->authenticate();
 132 }
 133
 134 sub additional_data {}
 135
 136 sub authenticate { return OK }
 137
 138 1;