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     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     $r->model_class($r->class_of($r->{table}));
  77     my $status = $r->is_applicable;
  78     return $status unless $status == OK;
  79     $status = $r->call_authenticate;
  80     return $status unless $status == OK;
  81     $r->additional_data();
  82
  83     $r->model_class->process($r);
  84     $r->view_object->process($r);
  85     return $r; # For debugging.
  86 }
  87
  88 sub get_request {
  89     my $self = shift;
  90     require Apache; require Apache::Request;
  91     $self->{ar} = Apache::Request->new(Apache->request);
  92 }
  93
  94 sub parse_location {
  95     my $self = shift;
  96     my $uri = $self->{ar}->path_info();
  97     my @pi = split /\//, $uri;
  98     shift @pi while @pi and !$pi[0];
  99     $self->{table} = shift @pi;
 100     $self->{action} = shift @pi;
 101     $self->{args} = \@pi;
 102
 103     $self->{params} = { $self->{ar}->content };
 104 }
 105
 106 sub is_applicable {
 107     my $self = shift;
 108     my $config = $self->config;
 109     $config->{ok_tables} = {map {$_ => 1} @{$config->{display_tables}}};
 110     warn "We don't have that table ($self->{table})"
 111         unless $config->{ok_tables}{$self->{table}};
 112     return DECLINED() unless exists $config->{ok_tables}{$self->{table}};
 113
 114     # Does the action method exist?
 115     # XXX We should set the method class to the class for the table
 116     my $cv = $self->model_class->can($self->{action});
 117     warn "We don't have that action ($self->{action})" unless $cv;
 118     return DECLINED() unless $cv;
 119
 120     # Is it exported?
 121     $self->{method_attribs} = join " ", attributes::get($cv);
 122     do { warn "$self->{action} not exported";
 123     return DECLINED()
 124      } unless $self->{method_attribs} =~ /\bExported\b/i;
 125     return OK();
 126 }
 127
 128 sub call_authenticate {
 129     my $self = shift;
 130     return $self->model_class->authenticate($self) if
 131         $self->model_class->can("authenticate");
 132     return $self->authenticate();
 133 }
 134
 135 sub additional_data {}
 136
 137 sub authenticate { return OK }
 138
 139 1;