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