lib/Maypole/Model/CDBI/Base.pm

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