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