lib/Maypole/Model/CDBI.pm

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