pjsz and AJT Maypole/Model updates and fixes

git-svn-id: http://svn.maypole.perl.org/Maypole/trunk@456 48953598-375a-da11-a14b-00016c27c3ee

diff --git a/lib/Maypole.pm b/lib/Maypole.pm
index fe2d29a0c5dad032b905a55aade0945b1faffd3d..5db199b484ae12a13c492aa3c16e64e419476e51 100644 (file)
--- a/lib/Maypole.pm
+++ b/lib/Maypole.pm
@@ -307,35 +307,32 @@ don't need to load them in the driver.
 
 =cut
 
-sub setup_model 
-{
-    my $class = shift;
-    
-    $class = ref $class if ref $class;
-    
-    my $config = $class->config;
-    
-    $config->model || $config->model('Maypole::Model::CDBI');
-    
-    $config->model->require or die sprintf 
-        "Couldn't load the model class %s: %s", $config->model, $@;
-    
-    # among other things, this populates $config->classes
-    $config->model->setup_database($config, $class, @_);
-    
-    foreach my $subclass ( @{ $config->classes } ) 
-    {
-      next if $subclass->isa("Maypole::Model::Base");
-      no strict 'refs';
-      unshift @{ $subclass . "::ISA" }, $config->model;
-      
-      # Load custom model code, if it exists - nb this must happen after the 
-      # unshift, to allow code attributes to work, but before adopt(),  
-      # in case adopt() calls overridden methods on $subclass
-      $class->load_model_subclass($subclass) unless ($class->model_classes_loaded());
-      
-      $config->model->adopt($subclass) if $config->model->can("adopt");
-    }
+sub setup_model {
+  my $class = shift;
+  $class = ref $class if ref $class;
+  my $config = $class->config;
+  $config->model || $config->model('Maypole::Model::CDBI');
+  $config->model->require or die sprintf
+    "Couldn't load the model class %s: %s", $config->model, $@;
+
+  # among other things, this populates $config->classes
+  $config->model->setup_database($config, $class, @_);
+ 
+  foreach my $subclass ( @{ $config->classes } ) {
+    next if $subclass->isa("Maypole::Model::Base");
+    no strict 'refs';
+    unshift @{ $subclass . "::ISA" }, $config->model; 
+
+  }
+
+  # Load custom model code, if it exists - nb this must happen after the
+  # unshift, to allow code attributes to work, but before adopt(),
+  # in case adopt() calls overridden methods on $subclass
+  foreach my $subclass ( @{ $config->classes } ) {
+    $class->load_model_subclass($subclass) unless ($class->model_classes_loaded());
+    $config->model->adopt($subclass) if $config->model->can("adopt");
+  }
+
 }
 
 =item load_model_subclass($subclass)
@@ -344,32 +341,32 @@ This method is called from C<setup_model()>. It attempts to load the
 C<$subclass> package, if one exists. So if you make a customized C<BeerDB::Beer>
 package, you don't need to explicitly load it. 
 
-If, perhaps during development, you don't want to load up custom classes, you 
+If automatic loading causes problems, Override load_model_subclass in your driver.
+
+sub load_model_subclass {};
+
+Or perhaps during development, if you don't want to load up custom classes, you 
 can override this method and load them manually. 
 
 =cut
 
-sub load_model_subclass
-{
-    my ($class, $subclass) = @_;
-    
-    my $config = $class->config;
-    
-    # Load any external files for the model base class or subclasses
-    # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from
-    # Maypole::Plugin::Loader and Class::DBI.
-    if ( $subclass->require ) 
-    {
-        warn "Loaded external module for '$subclass'\n" if $class->debug > 1;
-    } 
-    else 
-    {
-        (my $filename = $subclass) =~ s!::!/!g;
-        die "Loading '$subclass' failed: $@\n"
-               unless $@ =~ /Can\'t locate \Q$filename\E\.pm/;
-        warn "No external module for '$subclass'" 
-            if $class->debug > 1;
-   }
+sub load_model_subclass {
+  my ($class, $subclass) = @_;
+
+  my $config = $class->config;
+
+  # Load any external files for the model base class or subclasses
+  # (e.g. BeerDB/DBI.pm or BeerDB/Beer.pm) based on code borrowed from
+  # Maypole::Plugin::Loader and Class::DBI.
+  if ( $subclass->require ) {
+    warn "Loaded external module for '$subclass'\n" if $class->debug > 1;
+  } else {
+    (my $filename = $subclass) =~ s!::!/!g;
+    die "Loading '$subclass' failed: $@\n"
+      unless $@ =~ /Can\'t locate \Q$filename\E\.pm/;
+    warn "No external module for '$subclass'"
+      if $class->debug > 1;
+  }
 }
 
 =item init
@@ -526,7 +523,7 @@ sub handler_guts
     
     $self->__load_request_model;
 
-    my $applicable = $self->is_model_applicable;
+    my $applicable = $self->is_model_applicable == OK;
     
     $self->__setup_plain_template unless $applicable;
 
@@ -730,6 +727,10 @@ from a Maypole:Constant to a true/false value.
 
 Returns a Maypole::Constant to indicate whether the request is valid.
 
+=cut
+
+sub is_applicable { return shift->is_model_applicable(@_); }
+
 =item is_model_applicable
 
 Returns true or false to indicate whether the request is valid.
@@ -740,17 +741,8 @@ C<< $r->action >>.
 
 =cut
 
-sub is_model_applicable 
-{
+sub is_model_applicable {
     my ($self) = @_;
-    
-    # cater for applications that are using obsolete version
-    if ($self->can('is_applicable')) 
-    {
-        warn "DEPRECATION WARNING: rewrite is_applicable to the interface ".
-                "of Maypole::is_model_applicable\n";
-        return $self->is_applicable == OK;
-    }
 
     # Establish which tables should be processed by the model
     my $config = $self->config;
@@ -779,17 +771,17 @@ sub is_model_applicable
             . join( ",", keys %$ok_tables )
                 if $self->debug and not $ok_tables->{$table};
                 
-        return 0;
+        return DECLINED;
     }
     
     # Is the action public?
     my $action = $self->action;
-    return 1 if $self->model_class->is_public($action);
+    return OK if $self->model_class->is_public($action);
     
     warn "The action '$action' is not applicable to the table '$table'"
          if $self->debug;
     
-    return 0;
+    return DECLINED;
 }
 
 =item get_session

diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm
index 32f36b909ea174c37f4f6af9e1a61bbde0288450..2c79804642773411585ceca3e564bff1966c048d 100644 (file)
--- a/lib/Maypole/Model/CDBI.pm
+++ b/lib/Maypole/Model/CDBI.pm
@@ -572,6 +572,12 @@ sub setup_database {
       if $namespace->debug;
 }
 
+=head2 class_of
+
+  returns class for given table
+
+=cut
+
 sub class_of {
     my ( $self, $r, $table ) = @_;
     return $r->config->loader->_table2class($table); # why not find_class ?

diff --git a/lib/Maypole/Model/CDBI/Plain.pm b/lib/Maypole/Model/CDBI/Plain.pm
index 7a36f68034bbe3b6104489a0dc2f8c6db465b366..fd34a75c91d312bcb6437cca6c4dc6883d67e52d 100644 (file)
--- a/lib/Maypole/Model/CDBI/Plain.pm
+++ b/lib/Maypole/Model/CDBI/Plain.pm
@@ -36,15 +36,10 @@ tables and set up the inheritance relationships as normal.
 
   This method loads the model classes for the application
 
-=head1 SEE ALSO
-
-L<Maypole::Model::Base>
-
-L<Maypole::Model::CDBI>
-
 =cut
 
 
+
 sub setup_database {
     my ( $self, $config, $namespace, $classes ) = @_;
     $config->{classes}        = $classes;
@@ -54,11 +49,39 @@ sub setup_database {
     $config->{tables}         = [ keys %{ $config->{table_to_class} } ];
 }
 
+=head2 class_of
+
+  returns class for given table
+
+=cut
+
 sub class_of {
     my ( $self, $r, $table ) = @_;
     return $r->config->{table_to_class}->{$table};
 }
 
+=head2 adopt
+
+This class method is passed the name of a model class that represensts a table
+and allows the master model class to do any set-up required.
+
+=cut
+
+sub adopt {
+    my ( $self, $child ) = @_;
+    if ( my $col = $child->stringify_column ) {
+        $child->columns( Stringify => $col );
+    }
+}
+
+=head1 SEE ALSO
+
+L<Maypole::Model::Base>
+
+L<Maypole::Model::CDBI>
+
+=cut
+
 
 1;