lib/Maypole/Model/CDBI.pm

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