lib/Maypole/Model/CDBI.pm

   1 package Maypole::Model::CDBI;
   2 use strict;
   3 use Class::C3;
   4
   5 use Data::Dumper;
   6
   7 =head1 NAME
   8
   9 Maypole::Model::CDBI - Model class based on Class::DBI
  10
  11 =head1 DESCRIPTION
  12
  13 This is a master model class which uses L<Class::DBI> to do all the hard
  14 work of fetching rows and representing them as objects. It is a good
  15 model to copy if you're replacing it with other database abstraction
  16 modules.
  17
  18 It implements a base set of methods required for a Maypole Data Model.
  19
  20 It inherits accessor and helper methods from L<Maypole::Model::Base>.
  21
  22 When specified as the application model, it will use Class::DBI::Loader
  23 to generate the model classes from the provided database. If you do not
  24 wish to use this functionality, use L<Maypole::Model::CDBI::Plain> which
  25 will instead use Class::DBI classes provided.
  26
  27 =cut
  28
  29 use base qw(Maypole::Model::Base Class::DBI);
  30 use Class::DBI::Loader;
  31 use Class::DBI::AbstractSearch;
  32 use Class::DBI::Plugin::RetrieveAll;
  33 use Class::DBI::Pager;
  34 use Lingua::EN::Inflect::Number qw(to_PL);
  35 use attributes ();
  36
  37 use Maypole::Model::CDBI::AsForm;
  38 use Maypole::Model::CDBI::FromCGI;
  39 use CGI::Untaint::Maypole;
  40
  41 =head2 Untainter
  42
  43 Set the class you use to untaint and validate form data
  44 Note it must be of type CGI::Untaint::Maypole (takes $r arg) or CGI::Untaint
  45
  46 =cut
  47
  48 sub Untainter { 'CGI::Untaint::Maypole' };
  49
  50 =head2 add_model_superclass
  51
  52 Adds model as superclass to model classes (if necessary)
  53
  54 =cut
  55
  56 sub add_model_superclass {
  57   my ($class,$config) = @_;
  58   foreach my $subclass ( @{ $config->classes } ) {
  59     next if $subclass->isa("Maypole::Model::Base");
  60     no strict 'refs';
  61     push @{ $subclass . "::ISA" }, $config->model;
  62   }
  63   return;
  64 }
  65
  66
  67 __PACKAGE__->mk_classdata($_) for (qw/COLUMN_INFO/);
  68
  69 =head1 Action Methods
  70
  71 Action methods are methods that are accessed through web (or other public) interface.
  72
  73 =head2 do_edit
  74
  75 If there is an object in C<$r-E<gt>objects>, then it should be edited
  76 with the parameters in C<$r-E<gt>params>; otherwise, a new object should
  77 be created with those parameters, and put back into C<$r-E<gt>objects>.
  78 The template should be changed to C<view>, or C<edit> if there were any
  79 errors. A hash of errors will be passed to the template.
  80
  81 =cut
  82
  83 sub do_edit : Exported {
  84   my ($self, $r, $obj) = @_;
  85
  86   my $config   = $r->config;
  87   my $table    = $r->table;
  88
  89   # handle cancel button hit
  90   if ( $r->{params}->{cancel} ) {
  91     $r->template("list");
  92     $r->objects( [$self->retrieve_all] );
  93     return;
  94   }
  95
  96   my $required_cols = $config->{$table}{required_cols} || $self->required_columns;
  97   my $ignored_cols  = $config->{$table}{ignore_cols} || [];
  98
  99   ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
 100
 101   # handle errors, if none, proceed to view the newly created/updated object
 102   my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
 103
 104   if (%errors) {
 105     # Set it up as it was:
 106     $r->template_args->{cgi_params} = $r->params;
 107
 108     # replace user unfriendly error messages with something nicer
 109
 110     foreach (@{$config->{$table}->{required_cols}}) {
 111       next unless ($errors{$_});
 112       my $key = $_;
 113       s/_/ /g;
 114       $r->template_args->{errors}{ucfirst($_)} = 'This field is required, please provide a valid value';
 115       $r->template_args->{errors}{$key} = 'This field is required, please provide a valid value';
 116       delete $errors{$key};
 117     }
 118
 119     foreach (keys %errors) {
 120       my $key = $_;
 121       s/_/ /g;
 122       $r->template_args->{errors}{ucfirst($_)} = 'Please provide a valid value for this field';
 123       $r->template_args->{errors}{$key} = 'Please provide a valid value for this field';
 124     }
 125
 126     undef $obj if $creating;
 127
 128     die "do_update failed with error : $fatal" if ($fatal);
 129     $r->template("edit");
 130   } else {
 131     $r->template("view");
 132   }
 133
 134
 135
 136   $r->objects( $obj ? [$obj] : []);
 137 }
 138
 139 # split out from do_edit to be reported by Mp::P::Trace
 140 sub _do_update_or_create {
 141   my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
 142
 143   my $fatal;
 144   my $creating = 0;
 145
 146   my $h = $self->Untainter->new( %{$r->params} );
 147
 148   # update or create
 149   if ($obj) {
 150     # We have something to edit
 151     eval { $obj->update_from_cgi( $r => {
 152                                          required => $required_cols,
 153                                          ignore => $ignored_cols,
 154                                         });
 155            $obj->update(); # pos fix for bug 17132 'autoupdate required by do_edit'
 156          };
 157     $fatal = $@;
 158   } else {
 159         eval {
 160         $obj = $self->create_from_cgi( $r => {
 161                                             required => $required_cols,
 162                                             ignore => $ignored_cols,
 163                                            } );
 164         };
 165         $fatal = $@;
 166         $creating++;
 167   }
 168   return $obj, $fatal, $creating;
 169 }
 170
 171 =head2 delete
 172
 173 Deprecated method that calls do_delete or a given classes delete method, please
 174 use do_delete instead
 175
 176 =head2 do_delete
 177
 178 Unsuprisingly, this command causes a database record to be forever lost.
 179
 180 This method replaces the, now deprecated, delete method provided in prior versions
 181
 182 =cut
 183
 184 sub delete : Exported {
 185   my $self = shift;
 186   my ($sub) = (caller(1))[3];
 187   # So subclasses can still send delete down ...
 188   $sub =~ /^(.+)::([^:]+)$/;
 189   if ($1 ne "Maypole::Model::Base" && $2 ne "delete") {
 190     $self->SUPER::delete(@_);
 191   } else {
 192     warn "Maypole::Model::CDBI delete method is deprecated\n";
 193     $self->do_delete(@_);
 194   }
 195 }
 196
 197 sub do_delete {
 198   my ( $self, $r ) = @_;
 199   # FIXME: handle fatal error with exception
 200   $_->SUPER::delete for @{ $r->objects || [] };
 201 #  $self->dbi_commit;
 202   $r->objects( [ $self->retrieve_all ] );
 203   $r->{template} = "list";
 204   $self->list($r);
 205 }
 206
 207 =head2 search
 208
 209 Deprecated searching method - use do_search instead.
 210
 211 =head2 do_search
 212
 213 This action method searches for database records, it replaces
 214 the, now deprecated, search method previously provided.
 215
 216 =cut
 217
 218 sub search : Exported {
 219   my $self = shift;
 220   my ($sub) = (caller(1))[3];
 221   # So subclasses can still send search down ...
 222   if ($sub =~ /^(.+)::([^:]+)$/) {
 223     return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
 224       $self->SUPER::search(@_) : $self->do_search(@_);
 225   } else {
 226     $self->SUPER::search(@_);
 227   }
 228 }
 229
 230 sub do_search : Exported {
 231     my ( $self, $r ) = @_;
 232     my %fields = map { $_ => 1 } $self->columns;
 233     my $oper   = "like";                                # For now
 234     my %params = %{ $r->{params} };
 235     my %values = map { $_ => { $oper, $params{$_} } }
 236       grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
 237       keys %params;
 238
 239     $r->template("list");
 240     if ( !%values ) { return $self->list($r) }
 241     my $order = $self->order($r);
 242     $self = $self->do_pager($r);
 243     $r->objects(
 244         [
 245             $self->search_where(
 246                 \%values, ( $order ? { order_by => $order } : () )
 247             )
 248         ]
 249     );
 250     $r->{template_args}{search} = 1;
 251 }
 252
 253 =head2 list
 254
 255 The C<list> method fills C<$r-E<gt>objects> with all of the
 256 objects in the class. The results are paged using a pager.
 257
 258 =cut
 259
 260 sub list : Exported {
 261     my ( $self, $r ) = @_;
 262     my $order = $self->order($r);
 263     $self = $self->do_pager($r);
 264     if ($order) {
 265         $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
 266     }
 267     else {
 268         $r->objects( [ $self->retrieve_all ] );
 269     }
 270 }
 271
 272 ###############################################################################
 273 # Helper methods
 274
 275 =head1 Helper Methods
 276
 277
 278 =head2 adopt
 279
 280 This class method is passed the name of a model class that represensts a table
 281 and allows the master model class to do any set-up required.
 282
 283 =cut
 284
 285 sub adopt {
 286     my ( $self, $child ) = @_;
 287     $child->autoupdate(1);
 288     if ( my $col = $child->stringify_column ) {
 289         $child->columns( Stringify => $col );
 290     }
 291 }
 292
 293
 294 =head2 related
 295
 296 This method returns a list of has-many accessors. A brewery has many
 297 beers, so C<BeerDB::Brewery> needs to return C<beers>.
 298
 299 =cut
 300
 301 sub related {
 302     my ( $self, $r ) = @_;
 303     return keys %{ $self->meta_info('has_many') || {} };
 304 }
 305
 306
 307 =head2 related_class
 308
 309 Given an accessor name as a method, this function returns the class this accessor returns.
 310
 311 =cut
 312
 313 sub related_class {
 314      my ( $self, $r, $accessor ) = @_;
 315      my $meta = $self->meta_info;
 316      my @rels = keys %$meta;
 317      my $related;
 318      foreach (@rels) {
 319          $related = $meta->{$_}{$accessor};
 320          last if $related;
 321      }
 322      return unless $related;
 323
 324      my $mapping = $related->{args}->{mapping};
 325      if ( $mapping and @$mapping ) {
 326        return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
 327      }
 328      else {
 329          return $related->{foreign_class};
 330      }
 331  }
 332
 333 =head2 related_meta
 334
 335   $class->related_meta($col);
 336
 337 Returns the hash ref of relationship meta info for a given column.
 338
 339 =cut
 340
 341 sub related_meta {
 342     my ($self,$r, $accssr) = @_;
 343     $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
 344     my $class_meta = $self->meta_info;
 345     if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
 346         keys %$class_meta)
 347     { return  $class_meta->{$rel_type}->{$accssr} };
 348 }
 349
 350
 351
 352 =head2 stringify_column
 353
 354    Returns the name of the column to use when stringifying
 355    and object.
 356
 357 =cut
 358
 359 sub stringify_column {
 360     my $class = shift;
 361     return (
 362         $class->columns("Stringify"),
 363         ( grep { /^(name|title)$/i } $class->columns ),
 364         ( grep { /(name|title)/i } $class->columns ),
 365         ( grep { !/id$/i } $class->primary_columns ),
 366     )[0];
 367 }
 368
 369 =head2 do_pager
 370
 371    Sets the pager template argument ($r->{template_args}{pager})
 372    to a Class::DBI::Pager object based on the rows_per_page
 373    value set in the configuration of the application.
 374
 375    This pager is used via the pager macro in TT Templates, and
 376    is also accessible via Mason.
 377
 378 =cut
 379
 380 sub do_pager {
 381     my ( $self, $r ) = @_;
 382     if ( my $rows = $r->config->rows_per_page ) {
 383         return $r->{template_args}{pager} =
 384           $self->pager( $rows, $r->query->{page} );
 385     }
 386     else { return $self }
 387 }
 388
 389
 390 =head2 order
 391
 392     Returns the SQL order syntax based on the order parameter passed
 393     to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
 394
 395     $sql .= $self->order($r);
 396
 397     If the order column is not a column of this table,
 398     or an order argument is not passed, then the return value is undefined.
 399
 400     Note: the returned value does not start with a space.
 401
 402 =cut
 403
 404 sub order {
 405     my ( $self, $r ) = @_;
 406     my %ok_columns = map { $_ => 1 } $self->columns;
 407     my $q = $r->query;
 408     my $order = $q->{order};
 409     return unless $order and $ok_columns{$order};
 410     $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
 411     return $order;
 412 }
 413
 414 =head2 setup
 415
 416   This method is inherited from Maypole::Model::Base and calls setup_database,
 417   which uses Class::DBI::Loader to create and load Class::DBI classes from
 418   the given database schema.
 419
 420 =cut
 421
 422 =head2 setup_database
 423
 424 The $opts argument is a hashref of options.  The "options" key is a hashref of
 425 Database connection options . Other keys may be various Loader arguments or
 426 flags.  It has this form:
 427  {
 428    # DB connection options
 429    options { AutoCommit => 1 , ... },
 430    # Loader args
 431    relationships => 1,
 432    ...
 433  }
 434
 435 =cut
 436
 437 sub setup_database {
 438     my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
 439     $dsn  ||= $config->dsn;
 440     $u    ||= $config->user;
 441     $p    ||= $config->pass;
 442     $opts ||= $config->opts;
 443     $config->dsn($dsn);
 444     warn "No DSN set in config" unless $dsn;
 445     $config->loader || $config->loader(
 446         Class::DBI::Loader->new(
 447             namespace => $namespace,
 448             dsn       => $dsn,
 449             user      => $u,
 450             password  => $p,
 451             %$opts,
 452         )
 453     );
 454     $config->{classes} = [ $config->{loader}->classes ];
 455     $config->{tables}  = [ $config->{loader}->tables ];
 456
 457     my @table_class = map { $_ . " => " . $config->{loader}->_table2class($_) } @{ $config->{tables} };
 458     warn( 'Loaded tables to classes: ' . join ', ', @table_class )
 459       if $namespace->debug;
 460 }
 461
 462 =head2 class_of
 463
 464   returns class for given table
 465
 466 =cut
 467
 468 sub class_of {
 469     my ( $self, $r, $table ) = @_;
 470     return $r->config->loader->_table2class($table); # why not find_class ?
 471 }
 472
 473 =head2 fetch_objects
 474
 475 Returns 1 or more objects of the given class when provided with the request
 476
 477 =cut
 478
 479 sub fetch_objects {
 480     my ($class, $r)=@_;
 481     my @pcs = $class->primary_columns;
 482     if ( $#pcs ) {
 483     my %pks;
 484         @pks{@pcs}=(@{$r->{args}});
 485         return $class->retrieve( %pks );
 486     }
 487     return $class->retrieve( $r->{args}->[0] );
 488 }
 489
 490
 491
 492
 493
 494 =head2 _isa_class
 495
 496 Private method to return the class a column
 497 belongs to that was inherited by an is_a relationship.
 498 This should probably be public but need to think of API
 499
 500 =cut
 501
 502 sub _isa_class {
 503     my ($class, $col) = @_;
 504     $class->_croak( "Need a column for _isa_class." ) unless $col;
 505     my $isaclass;
 506     my $isa = $class->meta_info("is_a") || {};
 507     foreach ( keys %$isa ) {
 508         $isaclass = $isa->{$_}->foreign_class;
 509         return $isaclass if ($isaclass->find_column($col));
 510     }
 511     return; # col not in a is_a class
 512 }
 513
 514
 515 # Thanks to dave baird --  form builder for these private functions
 516 # sub _column_info {
 517 sub _column_info {
 518   my $self = shift;
 519   my $dbh = $self->db_Main;
 520
 521   my $meta;                     # The info we are after
 522   my ($catalog, $schema) = (undef, undef);
 523   # Dave is suspicious this (above undefs) could
 524   # break things if driver useses this info
 525
 526   my $original_metadata;
 527   # '%' is a search pattern for columns - matches all columns
 528   if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
 529     $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
 530     $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
 531   } else {
 532     $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
 533   }
 534
 535   return $self->COLUMN_INFO;
 536 }
 537
 538 sub _hash_type_meta {
 539   my ($self, $sth) = @_;
 540   my $meta;
 541   while ( my $row = $sth->fetchrow_hashref ) {
 542     my $colname = $row->{COLUMN_NAME} || $row->{column_name};
 543
 544     # required / nullable
 545     $meta->{$colname}{nullable} = $row->{NULLABLE};
 546     $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
 547
 548     # default
 549     if (defined $row->{COLUMN_DEF}) {
 550       my $default = $row->{COLUMN_DEF};
 551       $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
 552       $meta->{$colname}{default} = $default;
 553     }else {
 554       $meta->{$colname}{default} = '';
 555     }
 556
 557     # type
 558     my $type = $row->{mysql_type_name} || $row->{type};
 559     unless ($type) {
 560       $type =  $row->{TYPE_NAME};
 561       if ($row->{COLUMN_SIZE}) {
 562         $type .= "($row->{COLUMN_SIZE})";
 563       }
 564     }
 565     $type =~ s/['"]?(.*)['"]?::.*$/$1/;
 566     # Bool if tinyint
 567     if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
 568       $type = 'BOOL';
 569     }
 570     $meta->{$colname}{type} = $type;
 571
 572     # order
 573     $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
 574   }
 575   return $meta;
 576 }
 577
 578 # typeless db e.g. sqlite
 579 sub _hash_typeless_meta {
 580   my ( $self ) = @_;
 581
 582   $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
 583     unless $self->can( 'sql_fb_meta_dummy' );
 584
 585   my $sth = $self->sql_fb_meta_dummy;
 586
 587   $sth->execute or die "Error executing column info: "  . $sth->errstr;;
 588
 589   # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
 590   my $cols  = $sth->{NAME};
 591   my $types = $sth->{TYPE};
 592   # my $sizes = $sth->{PRECISION};    # empty
 593   # my $nulls = $sth->{NULLABLE};     # empty
 594
 595   # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
 596   $sth->finish;
 597
 598   my $order = 0;
 599   my $meta;
 600   foreach my $col ( @$cols ) {
 601     my $col_meta;
 602     $col_meta->{nullable}    = 1;
 603     $col_meta->{required}    = 0;
 604     $col_meta->{default}     = '';
 605     $col_meta->{position} = $order++;
 606     # type_name is taken literally from the schema, but is not actually used by sqlite,
 607     # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
 608     my $type = shift( @$types );
 609     $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
 610     $meta->{$col} = $col_meta;
 611   }
 612   return $meta;
 613 }
 614
 615 =head2 column_type
 616
 617     my $type = $class->column_type('column_name');
 618
 619 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
 620 For now, it returns "BOOL" for tinyints.
 621
 622 TODO :: TEST with enums
 623
 624 =cut
 625
 626 sub column_type {
 627   my $class = shift;
 628   my $colname = shift or die "Need a column for column_type";
 629   $class->_column_info() unless (ref $class->COLUMN_INFO);
 630
 631   if ($class->_isa_class($colname)) {
 632     return $class->_isa_class($colname)->column_type($colname);
 633   }
 634   unless ( $class->find_column($colname) ) {
 635     warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 636     return undef;
 637   }
 638   return $class->COLUMN_INFO->{$colname}{type};
 639 }
 640
 641 =head2 required_columns
 642
 643   Accessor to get/set required columns for forms, validation, etc.
 644
 645   Returns list of required columns. Accepts an array ref of column names.
 646
 647   $class->required_columns([qw/foo bar baz/]);
 648
 649   Allows you to specify the required columns for a class, over-riding any
 650   assumptions and guesses made by Maypole.
 651
 652   Use this instead of $config->{$table}{required_cols}
 653
 654   Note : you need to setup the model class before calling this method.
 655
 656 =cut
 657
 658 sub required_columns {
 659   my ($class, $columns) = @_;
 660   $class->_column_info() unless ref $class->COLUMN_INFO;
 661   my $column_info = $class->COLUMN_INFO;
 662
 663   if ($columns) {
 664     foreach my $colname ( @$columns ) {
 665       if ($class->_isa_class($colname)) {
 666         $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
 667           unless ($class->_isa_class($colname)->column_required);
 668         next;
 669       }
 670       unless ( $class->find_column($colname) ) {
 671         warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 672         next;
 673       }
 674       $column_info->{$colname}{required} = 1;
 675     }
 676     $class->COLUMN_INFO($column_info);
 677   }
 678
 679   return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
 680 }
 681
 682 =head2 column_required
 683
 684   Returns true if a column is required
 685
 686   my $required = $class->column_required($column_name);
 687
 688   Columns can be required by the application but not the database, but not the other way around,
 689   hence there is also a column_nullable method which will tell you if the column is nullable
 690   within the database itself.
 691
 692 =cut
 693
 694 sub column_required {
 695   my ($class, $colname) = @_;
 696   $colname or $class->_croak( "Need a column for column_required" );
 697   $class->_column_info() unless ref $class->COLUMN_INFO;
 698   if ($class->_isa_class($colname)) {
 699     return $class->_isa_class($colname)->column_required($colname);
 700   }
 701   unless ( $class->find_column($colname) ) {
 702     # handle  non-existant columns
 703     warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 704     return undef;
 705   }
 706   return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
 707   return  0;
 708 }
 709
 710 =head2 column_nullable
 711
 712   Returns true if a column can be NULL within the underlying database and false if not.
 713
 714   my $nullable = $class->column_nullable($column_name);
 715
 716   Any columns that are not nullable will automatically be specified as required, you can
 717   also specify nullable columns as required within your application.
 718
 719   It is recomended you use column_required rather than column_nullable within your
 720   application, this method is more useful if extending the model or handling your own
 721   validation.
 722
 723 =cut
 724
 725 sub column_nullable {
 726     my $class = shift;
 727     my $colname = shift or $class->_croak( "Need a column for column_nullable" );
 728
 729   $class->_column_info() unless ref $class->COLUMN_INFO;
 730   if ($class->_isa_class($colname)) {
 731     return $class->_isa_class($colname)->column_nullable($colname);
 732   }
 733   unless ( $class->find_column($colname) ) {
 734     # handle  non-existant columns
 735     warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 736     return undef;
 737   }
 738   return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
 739   return  0;
 740 }
 741
 742 =head2 column_default
 743
 744 Returns default value for column or the empty string.
 745 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
 746 have '' returned.
 747
 748 =cut
 749
 750 sub column_default {
 751   my $class = shift;
 752   my $colname = shift or $class->_croak( "Need a column for column_default");
 753   $class->_column_info() unless (ref $class->COLUMN_INFO);
 754   if ($class->_isa_class($colname)) {
 755     return $class->_isa_class($colname)->column_default($colname);
 756   }
 757   unless ( $class->find_column($colname) ) {
 758     warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 759     return undef;
 760   }
 761
 762   return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
 763   return;
 764 }
 765
 766 =head2 get_classmetadata
 767
 768 Gets class meta data *excluding cgi input* for the passed in class or the
 769 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
 770 templates when you need some metadata for a related class.
 771
 772 =cut
 773
 774 sub get_classmetadata {
 775     my ($self, $class) = @_; # class is class we want data for
 776     $class ||= $self;
 777     $class = ref $class || $class;
 778
 779     my %res;
 780     $res{name}          = $class;
 781     $res{colnames}      = {$class->column_names};
 782     $res{columns}       = [$class->display_columns];
 783     $res{list_columns}  = [$class->list_columns];
 784     $res{moniker}       = $class->moniker;
 785     $res{plural}        = $class->plural_moniker;
 786     $res{table}         = $class->table;
 787     $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
 788     return \%res;
 789 }
 790
 791
 792 1;