changes to get/set default columns and column metadata

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

diff --git a/Changes b/Changes
index 940512dd96b39cefde76def8f15ea52b1d163391..c7efd8aa7755c3f14c7664710c639098b81aa070 100644 (file)
--- a/Changes
+++ b/Changes
@@ -12,6 +12,9 @@ Deprecated:
     Maypole no longer uses Class::DBI::AsForm, instead Maypole::Model::CDBI::AsForm
     has replaced it.
 
     Maypole no longer uses Class::DBI::AsForm, instead Maypole::Model::CDBI::AsForm
     has replaced it.
 

+    $config->{$table}{required_cols} is deprecated, please use $class->required_columns instead
+
+

 Incompatible API changes:
     Maypole
         - is_applicable() deprecated for is_model_applicable(). is_applicable is
 Incompatible API changes:
     Maypole
         - is_applicable() deprecated for is_model_applicable(). is_applicable is


@@ -62,6 +65,8 @@ API additions and enhancements:
        - Changed factory edit/view to use object instead of objects
      Maypole::Model::CDBI
        - improved error messages in do_edit action
        - Changed factory edit/view to use object instead of objects
      Maypole::Model::CDBI
        - improved error messages in do_edit action

+        - new required_columns mutator method
+        - new column_required accessor method

 
 Bug fixes:
     Fix to cgi_maypole.t (bug 11346)
 
 Bug fixes:
     Fix to cgi_maypole.t (bug 11346)

diff --git a/lib/Maypole.pm b/lib/Maypole.pm
index c3e3525d585c0c2422459d09c80d59bf634b0884..56c94e3748fb28fa9e92daac0f79c881662287ae 100644 (file)
--- a/lib/Maypole.pm
+++ b/lib/Maypole.pm
@@ -35,6 +35,9 @@ The canonical example used in the Maypole documentation is the beer database:
     
     # choose a frontend, initialise the config object, and load a plugin
     use Maypole::Application qw/Relationship/;
     
     # choose a frontend, initialise the config object, and load a plugin
     use Maypole::Application qw/Relationship/;

+
+    # set everything up
+    __PACKAGE__->setup("dbi:SQLite:t/beerdb.db");

     
     # get the empty config object created by Maypole::Application
     my $config = __PACKAGE__->config;
     
     # get the empty config object created by Maypole::Application
     my $config = __PACKAGE__->config;


@@ -62,8 +65,8 @@ The canonical example used in the Maypole documentation is the beer database:
         date => [ qw/date/],
     );
 
         date => [ qw/date/],
     );
 

-    # set everything up
-    __PACKAGE__->setup("dbi:SQLite:t/beerdb.db");
+    # note : set up model before calling this method
+    BeerDB::Beer->required_columns([qw/name/]); 

 
     1;    
 
 
     1;    
 

diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm
index bd9646f5ee99105dd5eb5c12aa7274baf4d34c61..5433beba42282488de1de6e584f1f9e36366f94c 100644 (file)
--- a/lib/Maypole/Model/CDBI.pm
+++ b/lib/Maypole/Model/CDBI.pm
@@ -80,7 +80,7 @@ sub do_edit : Exported {
     return;
   }
 
     return;
   }
 

-  my $required_cols = $config->{$table}{required_cols} || [];
+  my $required_cols = $config->{$table}{required_cols} || $self->required_columns;

   my $ignored_cols  = $config->{$table}{ignore_cols} || [];
 
   ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
   my $ignored_cols  = $config->{$table}{ignore_cols} || [];
 
   ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);


@@ -155,40 +155,6 @@ sub _do_update_or_create {
   return $obj, $fatal, $creating;
 }
 
   return $obj, $fatal, $creating;
 }
 

-
-# split out from do_edit to be reported by Mp::P::Trace
-#sub _do_update_or_create {
-#  my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
-#
-#  my $fatal;
-#  my $creating = 0;
-#
-#  my $h = $self->Untainter->new( %{$r->params} );
-#
-#  # update or create
-#  if ($obj) {
-#    # We have something to edit
-#    eval { $obj->update_from_cgi( $h => {
-#                                       required => $required_cols,
-#                                       ignore => $ignored_cols,
-#                                      } );
-#         $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
-#       };
-#    $fatal = $@;
-#  } else {
-#      eval {
-#              $obj = $self->create_from_cgi( $h => {
-#                                          required => $required_cols,
-#                                          ignore => $ignored_cols,
-#                                         } );
-#      };
-#      $fatal = $@;
-#      $creating++;
-#  }
-#
-#  return $obj, $fatal, $creating;
-#}
-

 =head2 delete
 
 Deprecated method that calls do_delete or a given classes delete method, please
 =head2 delete
 
 Deprecated method that calls do_delete or a given classes delete method, please


@@ -533,100 +499,107 @@ sub _isa_class {
 }
 
 
 }
 
 

-

 # Thanks to dave baird --  form builder for these private functions
 # Thanks to dave baird --  form builder for these private functions

+# sub _column_info {

 sub _column_info {
 sub _column_info {

-    my $self = shift;
-       my $dbh = $self->db_Main;
-       return $self->COLUMN_INFO if ref $self->COLUMN_INFO;
-
-       my $meta;  # The info we are after
-       my ($catalog, $schema) = (undef, undef); 
-       # Dave is suspicious this (above undefs) could 
-       # break things if driver useses this info
-
-       # '%' is a search pattern for columns - matches all columns
-    if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) )
-    {
-        $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
-        $self->COLUMN_INFO( $self->_hash_type_meta( $sth ) );    
-#      use Data::Dumper; warn "col info for typed is " . Dumper($self->COLUMN_INFO);
-    }
-    else
-    {
-        $self->COLUMN_INFO( $self->_hash_typeless_meta( ) );    
-#              use Data::Dumper; warn "col info TYPELESS is " . Dumper($self->COLUMN_INFO);
-    }
-       return $self->COLUMN_INFO;
+  my $self = shift;
+  warn "__column_info called by ", join (', ', caller), "\n";
+  my $dbh = $self->db_Main;
+
+  my $meta;                    # The info we are after
+  my ($catalog, $schema) = (undef, undef); 
+  # Dave is suspicious this (above undefs) could 
+  # break things if driver useses this info
+
+  my $original_metadata;
+  # '%' is a search pattern for columns - matches all columns
+  if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
+    $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
+    $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
+  } else {
+    $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
+  }
+
+  return $self->COLUMN_INFO;

 }
 
 }
 

-sub _hash_type_meta
-{
-    my ($self, $sth) = @_;
-       my $meta;
-    while ( my $row = $sth->fetchrow_hashref )
-       
-    {
-        my ($col_meta, $col_name);
-        
-        foreach my $key ( keys %$row)
-        {
-            my $value = $row->{$key} || $row->{ uc $key };
-            $col_meta->{$key} = $value;
-            $col_name = $row->{COLUMN_NAME} || $row->{column_name};
-        }
-        
-        $meta->{$col_name} =  $col_meta;    
+sub _hash_type_meta {
+  my ($self, $sth) = @_;
+  my $meta;
+  while ( my $row = $sth->fetchrow_hashref ) {
+    my $colname = $row->{COLUMN_NAME} || $row->{column_name};
+
+    # required / nullable
+    $meta->{$colname}{nullable} = $row->{NULLABLE};
+
+    $meta->{$colname}{required} = ($row->{NULLABLE} && $row->{NULLABLE} == 0) ? 1 : 0;
+
+    # default
+    if (defined $row->{COLUMN_DEF}) {
+      my $default = $row->{COLUMN_DEF};
+      $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
+      $meta->{$colname}{default} = $default;
+    }else {
+      $meta->{$colname}{default} = '';

     }
     }

-       return $meta;
-}

 
 

-# typeless db e.g. sqlite
-sub _hash_typeless_meta
-{
-    my ( $self ) = @_;
-
-    $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
-        unless $self->can( 'sql_fb_meta_dummy' );
-
-    my $sth = $self->sql_fb_meta_dummy;
-    
-    $sth->execute or die "Error executing column info: "  . $sth->errstr;;
-    
-    # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
-    my $cols  = $sth->{NAME};
-    my $types = $sth->{TYPE};
-    # my $sizes = $sth->{PRECISION};    # empty
-    # my $nulls = $sth->{NULLABLE};     # empty
-    
-    # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
-    $sth->finish;
-    
-    my $order = 0;
-    my $meta;
-    foreach my $col ( @$cols )
-    {
-        my $col_meta;
-        
-        $col_meta->{NULLABLE}    = 1;
-        
-        # in my limited testing, the columns are returned in the same order as they were defined in the schema
-        $col_meta->{ORDINAL_POSITION} = $order++;
-        
-        # type_name is taken literally from the schema, but is not actually used by sqlite, 
-        # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
-               my $type = shift( @$types );  
-               $type =~ /(\w+)\((\w+)\)/;
-        $col_meta->{type} = $type; 
-               $col_meta->{TYPE_NAME} = $1;
-               my $size = $2;
-               $col_meta->{COLUMN_SIZE} = $size if $type =~ /(CHAR|INT)/i; 
-               $meta->{$col} = $col_meta;
+    # type
+    my $type = $row->{mysql_type_name} || $row->{type};
+    unless ($type) {
+      $type =  $row->{TYPE_NAME};
+      if ($row->{COLUMN_SIZE}) {
+       $type .= "($row->{COLUMN_SIZE})";
+      }

     }
     }

-       return $meta;
-}
+    $type =~ s/['"]?(.*)['"]?::.*$/$1/;
+    # Bool if tinyint
+    if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) { 
+      $type = 'BOOL';
+    }
+    $meta->{$colname}{type} = $type;

 
 

+    # order
+    $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
+  }
+  return $meta;
+}

 
 

+# typeless db e.g. sqlite
+sub _hash_typeless_meta {
+  my ( $self ) = @_;
+
+  $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
+    unless $self->can( 'sql_fb_meta_dummy' );
+
+  my $sth = $self->sql_fb_meta_dummy;
+
+  $sth->execute or die "Error executing column info: "  . $sth->errstr;;
+
+  # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
+  my $cols  = $sth->{NAME};
+  my $types = $sth->{TYPE};
+  # my $sizes = $sth->{PRECISION};    # empty
+  # my $nulls = $sth->{NULLABLE};     # empty
+
+  # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
+  $sth->finish;
+
+  my $order = 0;
+  my $meta;
+  foreach my $col ( @$cols ) {
+    my $col_meta;
+    $col_meta->{nullable}    = 1;
+    $col_meta->{required}    = 0;
+    $col_meta->{default}     = '';
+    $col_meta->{position} = $order++;
+    # type_name is taken literally from the schema, but is not actually used by sqlite,
+    # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
+    my $type = shift( @$types );
+    $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
+    $meta->{$col} = $col_meta;
+  }
+  return $meta;
+}

 
 =head2 column_type
 
 
 =head2 column_type
 


@@ -635,68 +608,145 @@ sub _hash_typeless_meta
 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
 For now, it returns "BOOL" for tinyints. 
 
 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
 For now, it returns "BOOL" for tinyints. 
 

-TODO :: TEST with enums and postgres
+TODO :: TEST with enums

 
 =cut
 
 =cut

+

 sub column_type {
 sub column_type {

-    my $class = shift;
-    my $col = shift or die "Need a column for column_type";
-       my $info = $class->_column_info->{$col} || 
-                          eval { $class->_isa_class($col)->_column_info($col) } ||
-                          return '';
-                          
-    my $type = $info->{mysql_type_name} || $info->{type};
-       unless ($type) {
-               $type =  $info->{TYPE_NAME};
-               if ($info->{COLUMN_SIZE}) { $type .= "($info->{COLUMN_SIZE})"; }
+  my $class = shift;
+  my $colname = shift or die "Need a column for column_type";
+  $class->_column_info() unless (ref $class->COLUMN_INFO);
+
+  if ($class->_isa_class($colname)) {
+    return $class->_isa_class($colname)->column_type($colname);
+  }
+  unless ( $class->find_column($colname) ) {
+    warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
+    return undef;
+  }
+  return $class->COLUMN_INFO->{$colname}{type};
+}
+
+=head2 required_columns
+
+  Accessor to get/set required columns for forms, validation, etc.
+
+  Returns list of required columns. Accepts an array ref of column names.
+
+  $class->required_columns([qw/foo bar baz/]);
+
+  Allows you to specify the required columns for a class, over-riding any
+  assumptions and guesses made by Maypole.
+
+  Use this instead of $config->{$table}{required_cols}
+
+  Note : you need to setup the model class before calling this method.
+
+=cut
+
+sub required_columns {
+  my ($class, $columns) = @_;
+  $class->_column_info() unless ref $class->COLUMN_INFO;
+  my $column_info = $class->COLUMN_INFO;
+  if ($columns) {
+    foreach my $colname ( @$columns ) {
+      if ($class->_isa_class($colname)) {
+       $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
+         unless ($class->_isa_class($colname)->column_required);
+       next;
+      }
+      unless ( $class->find_column($colname) ) {
+       warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
+       next;
+      }
+      $column_info->{required} = 1;

     }
     }

-       # Bool if tinyint
-       if ($type and $type =~ /^tinyint/i and $info->{COLUMN_SIZE} == 1) { 
-                       $type = 'BOOL'; 
-       }
-       return $type;
+    $class->COLUMN_INFO($column_info);
+  }
+
+  return [ grep ($column_info->{$_}{required}, keys %{$column_info}) ] ;
+}
+
+=head2 column_required
+
+  Returns true if a column is required
+
+  my $required = $class->column_required($column_name);
+
+  Columns can be required by the application but not the database, but not the other way around,
+  hence there is also a column_nullable method which will tell you if the column is nullable
+  within the database itself.
+
+=cut
+
+sub column_required {
+  my ($class, $colname) = @_;
+  $colname or $class->_croak( "Need a column for column_nullable" );
+  $class->_column_info() unless ref $class->COLUMN_INFO;
+  if ($class->_isa_class($colname)) {
+    return $class->_isa_class($colname)->column_required($colname);
+  }
+  unless ( $class->find_column($colname) ) {
+    # handle  non-existant columns
+    warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
+    return undef;
+  }
+  return $class->COLUMN_INFO->{$colname}{required} || 0;

 }
 
 =head2 column_nullable
 
 }
 
 =head2 column_nullable
 

-Returns true if a column can be NULL and false if not.
+  Returns true if a column can be NULL within the underlying database and false if not.
+
+  my $nullable = $class->column_nullable($column_name);
+
+  Any columns that are not nullable will automatically be specified as required, you can
+  also specify nullable columns as required within your application.
+
+  It is recomended you use column_required rather than column_nullable within your
+  application, this method is more useful if extending the model or handling your own
+  validation.

 
 =cut
 
 sub column_nullable {
     my $class = shift;
 
 =cut
 
 sub column_nullable {
     my $class = shift;

-    my $col = shift or $class->_croak( "Need a column for column_nullable" );
-       my $info = $class->_column_info->{$col} || 
-                          eval { $class->_isa_class($col)->_column_info($col) } ||
-                          return 1;
-    return $info->{NULLABLE};
+    my $colname = shift or $class->_croak( "Need a column for column_nullable" );
+
+  $class->_column_info() unless ref $class->COLUMN_INFO;
+  if ($class->_isa_class($colname)) {
+    return $class->_isa_class($colname)->column_nullable($colname);
+  }
+  unless ( $class->find_column($colname) ) {
+    # handle  non-existant columns
+    warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
+    return undef;
+  }
+  return $class->COLUMN_INFO->{$colname}{nullable} || 0;

 }
 
 =head2 column_default
 
 }
 
 =head2 column_default
 

-Returns default value for column or the empyty string. 
+Returns default value for column or the empty string. 

 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
 have '' returned.
 
 =cut
 
 sub column_default {
 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
 have '' returned.
 
 =cut
 
 sub column_default {

-    my $class = shift;
-    my $col = shift or $class->_croak( "Need a column for column_default");
-       #return unless $class->find_column($col); # not a real column
-
-       my $info = $class->_column_info->{$col} || 
-                          eval { $class->_isa_class($col)->_column_info($col) } ||
-                          return '';
-       
-    my $def = $info->{COLUMN_DEF};
-    $def = '' unless defined $def; # is this good?
-       return $def;
-}
-
-
-
+  my $class = shift;
+  my $colname = shift or $class->_croak( "Need a column for column_default");
+  $class->_column_info() unless (ref $class->COLUMN_INFO);
+  if ($class->_isa_class($colname)) {
+    return $class->_isa_class($colname)->column_default($colname);
+  }
+  unless ( $class->find_column($colname) ) {
+    warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
+    return undef;
+  }

 
 

+  return $class->COLUMN_INFO->{$colname}{default};
+}

 
 =head2 get_classmetadata
 
 
 =head2 get_classmetadata
 


@@ -719,7 +769,8 @@ sub get_classmetadata {
     $res{moniker}       = $class->moniker;
     $res{plural}        = $class->plural_moniker;
     $res{table}         = $class->table;
     $res{moniker}       = $class->moniker;
     $res{plural}        = $class->plural_moniker;
     $res{table}         = $class->table;

-    \%res;
+    $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
+    return \%res;

 }
 
 
 }
 
 

diff --git a/lib/Maypole/Model/CDBI/AsForm.pm b/lib/Maypole/Model/CDBI/AsForm.pm
index cd295f3e06335e502cbd720839ee3625f688608c..1765482469927742eb67baca014c82eea5ec4114 100644 (file)
--- a/lib/Maypole/Model/CDBI/AsForm.pm
+++ b/lib/Maypole/Model/CDBI/AsForm.pm
@@ -326,26 +326,24 @@ See C<HOW Methods>. You can also pass this argument in $args->{how}.
 =cut
 
 sub to_field {
 =cut
 
 sub to_field {

-               my ($self, $field, $how, $args) = @_;
-               if (ref $how)   { $args = $how; $how = ''; }
-               unless ($how)   { $how = $args->{how} || ''; }
-#warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
-               # Set sensible default value
-               if  ($field and not defined $args->{default}) { 
-                               my $def = $self->column_default($field) ;
-                               # exclude defaults we don't want actually put as value for input
-                               if (defined $def) {
-                                               $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ;
-                                               $args->{default} = $def;
-                               }
-               }
-
-
+  my ($self, $field, $how, $args) = @_;
+  if (ref $how)   { $args = $how; $how = ''; }
+  unless ($how)   { $how = $args->{how} || ''; }
+  #warn "In to_field field is $field how is $how. args ar e" . Dumper($args) . " \n";
+  # Set sensible default value
+  if  ($field and not defined $args->{default}) { 
+    my $def = $self->column_default($field) ;
+    # exclude defaults we don't want actually put as value for input
+    if (defined $def) {
+      $def = $def =~ /(^0000-00-00.*$|^0[0]*$|^0\.00$|CURRENT_TIMESTAMP|NULL)/i ? '' : $def ;
+      $args->{default} = $def;
+    }
+  }

 
 

-               return  $self->_field_from_how($field, $how, $args)   || 
-               $self->_field_from_relationship($field, $args) ||
-               $self->_field_from_column($field, $args)  ||
-               $self->_to_textfield($field, $args);
+  return       $self->_field_from_how($field, $how, $args)   ||
+    $self->_field_from_relationship($field, $args) ||
+      $self->_field_from_column($field, $args)  ||
+       $self->_to_textfield($field, $args);

 }
 
 
 }
 
 


@@ -375,65 +373,64 @@ Example:
 
 
 sub search_inputs {
 
 
 sub search_inputs {

-               my ($class, $args) = @_;
-               $class = ref $class || $class;
-               #my $accssr_class = { $class->accessor_classes };
-               my %cgi;
-
-               $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
-
-               foreach my $field ( @{ $args->{columns} } ) {
-                               my $base_args = {
-                                               no_hidden_constraints => 1,
-                                               column_nullable => 1, # empty option on select boxes
-                                               value  => '',
-                               };
-                               if ( ref $field eq "HASH" ) { # foreign search fields
-                                               my ($accssr, $cols)  = each %$field;
-                                               $base_args->{columns} = $cols;
-                                               unless (  @$cols ) {
-                                                               # default to search fields for related
-                                                               #$cols =  $accssr_class->{$accssr}->search_columns;
-                                                               die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
-                                               }
-                                               my $fcgi  = $class->to_field($accssr, 'foreign_inputs', $base_args);
-
-                                               # unset the default values for a select box
-                                               foreach (keys %$fcgi) {
-                                                               my $el = $fcgi->{$_};
-                                                               if ($el->tag eq 'select') {
-
-                                                                               $class->unselect_element($el);
-                                                                               my ($first, @content) = $el->content_list;
-                                                                               my @fc = $first->content_list;
-                                                                               my $val = $first ? $first->attr('value') : undef;  
-                                                                               if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or 
-
-                                                                                               #(defined $first->attr('value') or $first->attr('value') ne ''))  
-                                                                                               # push an empty option on stactk
-                                                                                               $el->unshift_content(HTML::Element->new('option'));
-                                                                               }
-                                                               }
+  my ($class, $args) = @_;
+  $class = ref $class || $class;
+  #my $accssr_class = { $class->accessor_classes };
+  my %cgi;
+  
+  $args->{columns} ||= $class->can('search_columns') ?[$class->search_columns] : [$class->display_columns];
+  
+  foreach my $field ( @{ $args->{columns} } ) {
+    my $base_args = {
+                    no_hidden_constraints => 1,
+                    column_nullable => 1, # empty option on select boxes
+                    value  => '',
+                   };
+    if ( ref $field eq "HASH" ) { # foreign search fields
+      my ($accssr, $cols)  = each %$field;
+      $base_args->{columns} = $cols;
+      unless (  @$cols ) {
+       # default to search fields for related
+       #$cols =  $accssr_class->{$accssr}->search_columns;
+       die ("$class search_fields error: Must specify at least one column to search in the foreign object named '$accssr'");
+      }
+      my $fcgi  = $class->to_field($accssr, 'foreign_inputs', $base_args);
+
+      # unset the default values for a select box
+      foreach (keys %$fcgi) {
+       my $el = $fcgi->{$_};
+       if ($el->tag eq 'select') {
+
+         $class->unselect_element($el);
+         my ($first, @content) = $el->content_list;
+         my @fc = $first->content_list;
+         my $val = $first ? $first->attr('value') : undef;  
+         if ($first and (@fc > 0 or (defined $val and $val ne '')) ) { # something ( $first->attr('value') ne '' or 
+
+           #(defined $first->attr('value') or $first->attr('value') ne ''))  
+           # push an empty option on stactk
+           $el->unshift_content(HTML::Element->new('option'));
+         }
+       }

 
 

-                                               }
-                                               $cgi{$accssr} = $fcgi;
-                                               delete $base_args->{columns};
-                               }
-                               else {
-                                               $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
-                                               my $el = $cgi{$field};
-                                               if ($el->tag eq 'select') {
-                                                               $class->unselect_element($el);
-                                                               my ($first, @content) = $el->content_list;
-                                                               if ($first and $first->content_list) { # something 
-                                                                               #(defined $first->attr('value') or $first->attr('value') ne ''))  
-                                                                               # push an empty option on stactk
-                                                                               $el->unshift_content(HTML::Element->new('option'));
-                                                               }
-                                               }
-                               }
-               }
-               return \%cgi;
+      }
+      $cgi{$accssr} = $fcgi;
+      delete $base_args->{columns};
+    } else {
+      $cgi{$field} = $class->to_field($field, $base_args); #{no_select => $args->{no_select}{$field} });
+      my $el = $cgi{$field};
+      if ($el->tag eq 'select') {
+       $class->unselect_element($el);
+       my ($first, @content) = $el->content_list;
+       if ($first and $first->content_list) { # something 
+         #(defined $first->attr('value') or $first->attr('value') ne ''))  
+         # push an empty option on stactk
+         $el->unshift_content(HTML::Element->new('option'));
+       }
+      }
+    }
+  }
+  return \%cgi;

 }
 
 
 }
 
 


@@ -536,36 +533,35 @@ Override at will.
 =cut
 
 sub _field_from_column {
 =cut
 
 sub _field_from_column {

-               my ($self, $field, $args) = @_;
-               # this class and pk are default class and field at this point
-               my $class = $args->{class} || $self;
-               $class = ref $class || $class;
-               $field  ||= ($class->primary_columns)[0]; # TODO
-
-               # Get column type       
-               unless ($args->{column_type}) { 
-                               if ($class->can('column_type')) {
-                                               $args->{column_type} = $class->column_type($field);
-                               }       
-                               else {
-                                               # Right, have some of this
-                                               eval "package $class; Class::DBI::Plugin::Type->import()";
-                                               $args->{column_type} = $class->column_type($field);
-                               }
-               }
-               my $type = $args->{column_type};
-
-               return $self->_to_textfield($field, $args)
-               if $type  and $type =~ /^(VAR)?CHAR/i;  #common type
-               return $self->_to_textarea($field, $args)
-               if $type and $type =~ /^(TEXT|BLOB)$/i;
-               return $self->_to_enum_select($field, $args)  
-               if $type and  $type =~ /^ENUM\((.*?)\)$/i; 
-               return $self->_to_bool_select($field, $args)
-               if $type and  $type =~ /^BOOL/i; 
-               return $self->_to_readonly($field, $args)
-               if $type and $type =~ /^readonly$/i;
-               return;
+  my ($self, $field, $args) = @_;
+  # this class and pk are default class and field at this point
+  my $class = $args->{class} || $self;
+  $class = ref $class || $class;
+  $field  ||= ($class->primary_columns)[0]; # TODO
+
+  # Get column type
+  unless ($args->{column_type}) { 
+    if ($class->can('column_type')) {
+      $args->{column_type} = $class->column_type($field);
+    } else {
+      # Right, have some of this
+      eval "package $class; Class::DBI::Plugin::Type->import()";
+      $args->{column_type} = $class->column_type($field);
+    }
+  }
+  my $type = $args->{column_type};
+
+  return $self->_to_textfield($field, $args)
+    if $type  and $type =~ /^(VAR)?CHAR/i; #common type
+  return $self->_to_textarea($field, $args)
+    if $type and $type =~ /^(TEXT|BLOB)$/i;
+  return $self->_to_enum_select($field, $args)  
+    if $type and  $type =~ /^ENUM\((.*?)\)$/i; 
+  return $self->_to_bool_select($field, $args)
+    if $type and  $type =~ /^BOOL/i; 
+  return $self->_to_readonly($field, $args)
+    if $type and $type =~ /^readonly$/i;
+  return;

 }
 
 
 }
 
 

diff --git a/lib/Maypole/Model/CDBI/FromCGI.pm b/lib/Maypole/Model/CDBI/FromCGI.pm
index cc27533fdbe1e8e08b4a48d6ea73b0ba16079bd1..6cb95a0bce3babb9ef71dcf334c7565d87b29395 100644 (file)
--- a/lib/Maypole/Model/CDBI/FromCGI.pm
+++ b/lib/Maypole/Model/CDBI/FromCGI.pm
@@ -279,12 +279,9 @@ sub validate_all {
   my $updating   = $opts->{updating};
 
   # Base case - validate this classes data
   my $updating   = $opts->{updating};
 
   # Base case - validate this classes data

-  $opts->{all}   ||= eval{ $r->config->{$self->table}{all_cols} }              ||
-    [$self->columns('All')];
-  $opts->{required} ||= eval{ $r->config->{$self->table}{required_cols} } ||   
-       [];
-  my $ignore = $opts->{ignore} || eval{ $r->config->{$self->table}{ignore_cols} }      
-    || [];
+  $opts->{all}   ||= eval{ $r->config->{$self->table}{all_cols} } || [$self->columns('All')];
+  $opts->{required} ||= eval { $r->config->{$self->table}{required_cols} || $self->required_columns } || [];
+  my $ignore = $opts->{ignore} || eval{ $r->config->{$self->table}{ignore_cols} } || [];

   push @$ignore, $self->primary_column->name if $updating;
   
   # Ignore hashes of foreign inputs. This takes care of required has_a's 
   push @$ignore, $self->primary_column->name if $updating;
   
   # Ignore hashes of foreign inputs. This takes care of required has_a's 

diff --git a/t/db_colinfo.t b/t/db_colinfo.t
index c56fbf28497b2b954345059a1d6816474574885d..b387769c9e8e9e8edf54f896211dea92c013c7f4 100755 (executable)
--- a/t/db_colinfo.t
+++ b/t/db_colinfo.t
@@ -1,5 +1,6 @@
 #!/usr/bin/perl -w
 use Test::More;
 #!/usr/bin/perl -w
 use Test::More;

+use Data::Dumper;

 use lib 'ex'; # Where BeerDB should live
 BEGIN {
    plan tests => 35;
 use lib 'ex'; # Where BeerDB should live
 BEGIN {
    plan tests => 35;


@@ -56,7 +57,7 @@ create table $table (
                  brewery   => 1, 
                  modified      => 1,
                  style         => 0,   
                  brewery   => 1, 
                  modified      => 1,
                  style         => 0,   

-                     name      => 0, 
+                 name      => 0, 

                  tasted    => 0,
 );
 
                  tasted    => 0,
 );
 


@@ -76,6 +77,7 @@ sub run_method_tests {
     my $correct = $correct{$col};
     like($val, qr/$correct/,"$method $col is $val");
   }
     my $correct = $correct{$col};
     like($val, qr/$correct/,"$method $col is $val");
   }

+

 }
 
 
 }
 
 


@@ -83,7 +85,7 @@ sub run_method_tests {
 
 # Make test class 
 package BeerDB::BeerTestmysql;
 
 # Make test class 
 package BeerDB::BeerTestmysql;

-use base Maypole::Model::CDBI;
+use base qw(Maypole::Model::CDBI Class::DBI);

 package main;
 
 $DB_Class = 'BeerDB::BeerTestmysql';
 package main;
 
 $DB_Class = 'BeerDB::BeerTestmysql';


@@ -117,6 +119,8 @@ SKIP: {
        $DB_Class->db_Main->do("drop table if exists $table;");
        $DB_Class->db_Main->do($sql);
        $DB_Class->table($table);
        $DB_Class->db_Main->do("drop table if exists $table;");
        $DB_Class->db_Main->do($sql);
        $DB_Class->table($table);

+       $DB_Class->columns(All => keys %correct_types);
+       $DB_Class->columns(Primary => 'id');

        run_method_tests($DB_Class,'column_type', %correct_types);
        run_method_tests($DB_Class,'column_default', %correct_defaults);
        run_method_tests($DB_Class,'column_nullable', %correct_nullables);
        run_method_tests($DB_Class,'column_type', %correct_types);
        run_method_tests($DB_Class,'column_default', %correct_defaults);
        run_method_tests($DB_Class,'column_nullable', %correct_nullables);


@@ -125,7 +129,7 @@ SKIP: {
 # SQLite  test
 
 package BeerDB::BeerTestsqlite;
 # SQLite  test
 
 package BeerDB::BeerTestsqlite;

-use base Maypole::Model::CDBI;
+use base qw(Maypole::Model::CDBI Class::DBI);

 package main;
 use Cwd;
 
 package main;
 use Cwd;
 


@@ -152,6 +156,8 @@ $skip_howmany = 13;
 SKIP: {
        skip $skip_msg, $skip_howmany  if $err; 
        $DB_Class->table($table); 
 SKIP: {
        skip $skip_msg, $skip_howmany  if $err; 
        $DB_Class->table($table); 

+       $DB_Class->columns(All => keys %correct_types);
+       $DB_Class->columns(Primary => 'id');

 #use Data::Dumper; 
        run_method_tests($DB_Class,'column_type', %correct_types);
        # No support default
 #use Data::Dumper; 
        run_method_tests($DB_Class,'column_type', %correct_types);
        # No support default