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( $r => {
 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( $r => {
 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     $r->objects(
 235         [
 236             $self->search_where(
 237                 \%values, ( $order ? { order_by => $order } : () )
 238             )
 239         ]
 240     );
 241     $r->{template_args}{search} = 1;
 242 }
 243
 244 =head2 list
 245
 246 The C<list> method fills C<$r-E<gt>objects> with all of the
 247 objects in the class. The results are paged using a pager.
 248
 249 =cut
 250
 251 sub list : Exported {
 252     my ( $self, $r ) = @_;
 253     my $order = $self->order($r);
 254     $self = $self->do_pager($r);
 255     if ($order) {
 256         $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
 257     }
 258     else {
 259         $r->objects( [ $self->retrieve_all ] );
 260     }
 261 }
 262
 263 ###############################################################################
 264 # Helper methods
 265
 266 =head1 Helper Methods
 267
 268
 269 =head2 adopt
 270
 271 This class method is passed the name of a model class that represents a table
 272 and allows the master model class to do any set-up required.
 273
 274 =cut
 275
 276 sub adopt {
 277     my ( $self, $child ) = @_;
 278     $child->autoupdate(1);
 279     if ( my $col = $child->stringify_column ) {
 280         $child->columns( Stringify => $col );
 281     }
 282 }
 283
 284
 285 =head2 related
 286
 287 This method returns a list of has-many accessors. A brewery has many
 288 beers, so C<BeerDB::Brewery> needs to return C<beers>.
 289
 290 =cut
 291
 292 sub related {
 293     my ( $self, $r ) = @_;
 294     return keys %{ $self->meta_info('has_many') || {} };
 295 }
 296
 297
 298 =head2 related_class
 299
 300 Given an accessor name as a method, this function returns the class this accessor returns.
 301
 302 =cut
 303
 304 sub related_class {
 305      my ( $self, $r, $accessor ) = @_;
 306      my $meta = $self->meta_info;
 307      my @rels = keys %$meta;
 308      my $related;
 309      foreach (@rels) {
 310          $related = $meta->{$_}{$accessor};
 311          last if $related;
 312      }
 313      return unless $related;
 314
 315      my $mapping = $related->{args}->{mapping};
 316      if ( $mapping and @$mapping ) {
 317        return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
 318      }
 319      else {
 320          return $related->{foreign_class};
 321      }
 322  }
 323
 324 =head2 search_columns
 325
 326   $class->search_columns;
 327
 328 Returns a list of columns suitable for searching - used in factory templates, over-ridden in
 329 classes. Provides same list as display_columns unless over-ridden.
 330
 331 =cut
 332
 333 sub search_columns {
 334   my $class = shift;
 335   return $class->display_columns;
 336 }
 337
 338
 339 =head2 related_meta
 340
 341   $class->related_meta($col);
 342
 343 Returns the hash ref of relationship meta info for a given column.
 344
 345 =cut
 346
 347 sub related_meta {
 348     my ($self,$r, $accssr) = @_;
 349     $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
 350     my $class_meta = $self->meta_info;
 351     if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
 352         keys %$class_meta)
 353     { return  $class_meta->{$rel_type}->{$accssr} };
 354 }
 355
 356
 357
 358 =head2 stringify_column
 359
 360    Returns the name of the column to use when stringifying
 361    and object.
 362
 363 =cut
 364
 365 sub stringify_column {
 366     my $class = shift;
 367     return (
 368         $class->columns("Stringify"),
 369         ( grep { /^(name|title)$/i } $class->columns ),
 370         ( grep { /(name|title)/i } $class->columns ),
 371         ( grep { !/id$/i } $class->primary_columns ),
 372     )[0];
 373 }
 374
 375 =head2 do_pager
 376
 377    Sets the pager template argument ($r->{template_args}{pager})
 378    to a Class::DBI::Pager object based on the rows_per_page
 379    value set in the configuration of the application.
 380
 381    This pager is used via the pager macro in TT Templates, and
 382    is also accessible via Mason.
 383
 384 =cut
 385
 386 sub do_pager {
 387     my ( $self, $r ) = @_;
 388     if ( my $rows = $r->config->rows_per_page ) {
 389         return $r->{template_args}{pager} =
 390           $self->pager( $rows, $r->query->{page} );
 391     }
 392     else { return $self }
 393 }
 394
 395
 396 =head2 order
 397
 398     Returns the SQL order syntax based on the order parameter passed
 399     to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
 400
 401     $sql .= $self->order($r);
 402
 403     If the order column is not a column of this table,
 404     or an order argument is not passed, then the return value is undefined.
 405
 406     Note: the returned value does not start with a space.
 407
 408 =cut
 409
 410 sub order {
 411     my ( $self, $r ) = @_;
 412     my %ok_columns = map { $_ => 1 } $self->columns;
 413     my $q = $r->query;
 414     my $order = $q->{order};
 415     return unless $order and $ok_columns{$order};
 416     $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
 417     return $order;
 418 }
 419
 420
 421 =head2 fetch_objects
 422
 423 Returns 1 or more objects of the given class when provided with the request
 424
 425 =cut
 426
 427 sub fetch_objects {
 428     my ($class, $r)=@_;
 429     my @pcs = $class->primary_columns;
 430     if ( $#pcs ) {
 431     my %pks;
 432         @pks{@pcs}=(@{$r->{args}});
 433         return $class->retrieve( %pks );
 434     }
 435     return $class->retrieve( $r->{args}->[0] );
 436 }
 437
 438
 439 =head2 _isa_class
 440
 441 Private method to return the class a column
 442 belongs to that was inherited by an is_a relationship.
 443 This should probably be public but need to think of API
 444
 445 =cut
 446
 447 sub _isa_class {
 448     my ($class, $col) = @_;
 449     $class->_croak( "Need a column for _isa_class." ) unless $col;
 450     my $isaclass;
 451     my $isa = $class->meta_info("is_a") || {};
 452     foreach ( keys %$isa ) {
 453         $isaclass = $isa->{$_}->foreign_class;
 454         return $isaclass if ($isaclass->find_column($col));
 455     }
 456     return; # col not in a is_a class
 457 }
 458
 459
 460 # Thanks to dave baird --  form builder for these private functions
 461 # sub _column_info {
 462 sub _column_info {
 463   my $self = shift;
 464   my $dbh = $self->db_Main;
 465
 466   my $meta;                     # The info we are after
 467   my ($catalog, $schema) = (undef, undef);
 468   # Dave is suspicious this (above undefs) could
 469   # break things if driver useses this info
 470
 471   my $original_metadata;
 472   # '%' is a search pattern for columns - matches all columns
 473   if ( my $sth = $dbh->column_info( $catalog, $schema, $self->table, '%' ) ) {
 474     $dbh->errstr && die "Error getting column info sth: " . $dbh->errstr;
 475     $self->COLUMN_INFO ($self->_hash_type_meta( $sth ));
 476   } else {
 477     $self->COLUMN_INFO ($self->_hash_typeless_meta( ));
 478   }
 479
 480   return $self->COLUMN_INFO;
 481 }
 482
 483 sub _hash_type_meta {
 484   my ($self, $sth) = @_;
 485   my $meta;
 486   while ( my $row = $sth->fetchrow_hashref ) {
 487     my $colname = $row->{COLUMN_NAME} || $row->{column_name};
 488
 489     # required / nullable
 490     $meta->{$colname}{nullable} = $row->{NULLABLE};
 491     $meta->{$colname}{required} = ( $meta->{$colname}{nullable} == 0 ) ? 1 : 0;
 492
 493     # default
 494     if (defined $row->{COLUMN_DEF}) {
 495       my $default = $row->{COLUMN_DEF};
 496       $default =~ s/['"]?(.*?)['"]?::.*$/$1/;
 497       $meta->{$colname}{default} = $default;
 498     }else {
 499       $meta->{$colname}{default} = '';
 500     }
 501
 502     # type
 503     my $type = $row->{mysql_type_name} || $row->{type};
 504     unless ($type) {
 505       $type =  $row->{TYPE_NAME};
 506       if ($row->{COLUMN_SIZE}) {
 507         $type .= "($row->{COLUMN_SIZE})";
 508       }
 509     }
 510     $type =~ s/['"]?(.*)['"]?::.*$/$1/;
 511     # Bool if tinyint
 512     if ($type and $type =~ /^tinyint/i and $row->{COLUMN_SIZE} == 1) {
 513       $type = 'BOOL';
 514     }
 515     $meta->{$colname}{type} = $type;
 516
 517     # order
 518     $meta->{$colname}{position} = $row->{ORDINAL_POSITION}
 519   }
 520   return $meta;
 521 }
 522
 523 # typeless db e.g. sqlite
 524 sub _hash_typeless_meta {
 525   my ( $self ) = @_;
 526
 527   $self->set_sql( fb_meta_dummy => 'SELECT * FROM __TABLE__ WHERE 1=0' )
 528     unless $self->can( 'sql_fb_meta_dummy' );
 529
 530   my $sth = $self->sql_fb_meta_dummy;
 531
 532   $sth->execute or die "Error executing column info: "  . $sth->errstr;;
 533
 534   # see 'Statement Handle Attributes' in the DBI docs for a list of available attributes
 535   my $cols  = $sth->{NAME};
 536   my $types = $sth->{TYPE};
 537   # my $sizes = $sth->{PRECISION};    # empty
 538   # my $nulls = $sth->{NULLABLE};     # empty
 539
 540   # we haven't actually fetched anything from the sth, so need to tell DBI we're not going to
 541   $sth->finish;
 542
 543   my $order = 0;
 544   my $meta;
 545   foreach my $col ( @$cols ) {
 546     my $col_meta;
 547     $col_meta->{nullable}    = 1;
 548     $col_meta->{required}    = 0;
 549     $col_meta->{default}     = '';
 550     $col_meta->{position} = $order++;
 551     # type_name is taken literally from the schema, but is not actually used by sqlite,
 552     # so it can be anything, e.g. varchar or varchar(xxx) or VARCHAR etc.
 553     my $type = shift( @$types );
 554     $col_meta->{type} = ($type =~ /(\w+)\((\w+)\)/) ? $1 :$type ;
 555     $meta->{$col} = $col_meta;
 556   }
 557   return $meta;
 558 }
 559
 560 =head2 column_type
 561
 562     my $type = $class->column_type('column_name');
 563
 564 This returns the 'type' of this column (VARCHAR(20), BIGINT, etc.)
 565 For now, it returns "BOOL" for tinyints.
 566
 567 TODO :: TEST with enums
 568
 569 =cut
 570
 571 sub column_type {
 572   my $class = shift;
 573   my $colname = shift or die "Need a column for column_type";
 574   $class->_column_info() unless (ref $class->COLUMN_INFO);
 575
 576   if ($class->_isa_class($colname)) {
 577     return $class->_isa_class($colname)->column_type($colname);
 578   }
 579   unless ( $class->find_column($colname) ) {
 580     warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 581     return undef;
 582   }
 583   return $class->COLUMN_INFO->{$colname}{type};
 584 }
 585
 586 =head2 required_columns
 587
 588   Accessor to get/set required columns for forms, validation, etc.
 589
 590   Returns list of required columns. Accepts an array ref of column names.
 591
 592   $class->required_columns([qw/foo bar baz/]);
 593
 594   Allows you to specify the required columns for a class, over-riding any
 595   assumptions and guesses made by Maypole.
 596
 597   Any columns specified as required will no longer be 'nullable' or optional, and
 598   any columns not specified as 'required' will be 'nullable' or optional.
 599
 600   The default for a column is nullable, or whatever is discovered from database
 601   schema.
 602
 603   Use this instead of $config->{$table}{required_cols}
 604
 605   Note : you need to setup the model class before calling this method.
 606
 607 =cut
 608
 609 sub required_columns {
 610   my ($class, $columns) = @_;
 611   $class->_column_info() unless (ref $class->COLUMN_INFO);
 612   my $column_info = $class->COLUMN_INFO;
 613
 614   if ($columns) {
 615     # get the previously required columns
 616     my %previously_required = map { $_ => 1} grep($column_info->{$_}{required}, keys %$column_info);
 617
 618     # update each specified column as required
 619     foreach my $colname ( @$columns ) {
 620       # handle C::DBI::Rel::IsA
 621       if ($class->_isa_class($colname)) {
 622         $class->_isa_class($colname)->COLUMN_INFO->{$colname}{required} = 1
 623           unless ($class->_isa_class($colname)->column_required);
 624         next;
 625       }
 626       unless ( $class->find_column($colname) ) {
 627         warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 628         next;
 629       }
 630       $column_info->{$colname}{required} = 1;
 631       delete $previously_required{$colname};
 632     }
 633
 634     # no longer require any columns not specified
 635     foreach my $colname ( keys %previously_required ) {
 636       $column_info->{$colname}{required} = 0;
 637       $column_info->{$colname}{nullable} = 1;
 638     }
 639
 640     # update column metadata
 641     $class->COLUMN_INFO($column_info);
 642   }
 643
 644   return [ grep ($column_info->{$_}{required}, keys %$column_info) ] ;
 645 }
 646
 647 =head2 column_required
 648
 649   Returns true if a column is required
 650
 651   my $required = $class->column_required($column_name);
 652
 653   Columns can be required by the application but not the database, but not the other way around,
 654   hence there is also a column_nullable method which will tell you if the column is nullable
 655   within the database itself.
 656
 657 =cut
 658
 659 sub column_required {
 660   my ($class, $colname) = @_;
 661   $colname or $class->_croak( "Need a column for column_required" );
 662   $class->_column_info() unless ref $class->COLUMN_INFO;
 663   if ($class->_isa_class($colname)) {
 664     return $class->_isa_class($colname)->column_required($colname);
 665   }
 666   unless ( $class->find_column($colname) ) {
 667     # handle  non-existant columns
 668     warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 669     return undef;
 670   }
 671   return $class->COLUMN_INFO->{$colname}{required} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
 672   return  0;
 673 }
 674
 675 =head2 column_nullable
 676
 677   Returns true if a column can be NULL within the underlying database and false if not.
 678
 679   my $nullable = $class->column_nullable($column_name);
 680
 681   Any columns that are not nullable will automatically be specified as required, you can
 682   also specify nullable columns as required within your application.
 683
 684   It is recomended you use column_required rather than column_nullable within your
 685   application, this method is more useful if extending the model or handling your own
 686   validation.
 687
 688 =cut
 689
 690 sub column_nullable {
 691     my $class = shift;
 692     my $colname = shift or $class->_croak( "Need a column for column_nullable" );
 693
 694   $class->_column_info() unless ref $class->COLUMN_INFO;
 695   if ($class->_isa_class($colname)) {
 696     return $class->_isa_class($colname)->column_nullable($colname);
 697   }
 698   unless ( $class->find_column($colname) ) {
 699     # handle  non-existant columns
 700     warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 701     return undef;
 702   }
 703   return $class->COLUMN_INFO->{$colname}{nullable} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
 704   return  0;
 705 }
 706
 707 =head2 column_default
 708
 709 Returns default value for column or the empty string.
 710 Columns with NULL, CURRENT_TIMESTAMP, or Zeros( 0000-00...) for dates and times
 711 have '' returned.
 712
 713 =cut
 714
 715 sub column_default {
 716   my $class = shift;
 717   my $colname = shift or $class->_croak( "Need a column for column_default");
 718   $class->_column_info() unless (ref $class->COLUMN_INFO);
 719   if ($class->_isa_class($colname)) {
 720     return $class->_isa_class($colname)->column_default($colname);
 721   }
 722   unless ( $class->find_column($colname) ) {
 723     warn "$colname is not a recognised column in this class ", ref $class || $class, "\n";
 724     return undef;
 725   }
 726
 727   return $class->COLUMN_INFO->{$colname}{default} if ($class->COLUMN_INFO and $class->COLUMN_INFO->{$colname});
 728   return;
 729 }
 730
 731 =head2 get_classmetadata
 732
 733 Gets class meta data *excluding cgi input* for the passed in class or the
 734 calling class. *NOTE* excludes cgi inputs. This method is handy to call from
 735 templates when you need some metadata for a related class.
 736
 737 =cut
 738
 739 sub get_classmetadata {
 740     my ($self, $class) = @_; # class is class we want data for
 741     $class ||= $self;
 742     $class = ref $class || $class;
 743
 744     my %res;
 745     $res{name}          = $class;
 746     $res{colnames}      = {$class->column_names};
 747     $res{columns}       = [$class->display_columns];
 748     $res{list_columns}  = [$class->list_columns];
 749     $res{moniker}       = $class->moniker;
 750     $res{plural}        = $class->plural_moniker;
 751     $res{table}         = $class->table;
 752     $res{column_metadata} = (ref $class->COLUMN_INFO) ? $class->COLUMN_INFO : $class->_column_info() ;
 753     return \%res;
 754 }
 755
 756
 757 =head1 SEE ALSO
 758
 759 L<Maypole>, L<Maypole::Model::CDBI::Base>.
 760
 761 =head1 AUTHOR
 762
 763 Maypole is currently maintained by Aaron Trevena.
 764
 765 =head1 AUTHOR EMERITUS
 766
 767 Simon Cozens, C<simon#cpan.org>
 768
 769 Simon Flack maintained Maypole from 2.05 to 2.09
 770
 771 Sebastian Riedel, C<sri#oook.de> maintained Maypole from 1.99_01 to 2.04
 772
 773 =head1 LICENSE
 774
 775 You may distribute this code under the same terms as Perl itself.
 776
 777 =cut
 778
 779 1;