lib/Maypole/Model/CDBI/Base.pm

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