-
-=head2 adopt
-
-This class method is passed the name of a model class that represensts a table
-and allows the master model class to do any set-up required.
-
-=cut
-
-sub adopt {
- my ( $self, $child ) = @_;
- $child->autoupdate(1);
- if ( my $col = $child->stringify_column ) {
- $child->columns( Stringify => $col );
- }
-}
-
-=head2 is_class
-
-Tell if action is a class method (See Maypole::Plugin::Menu)
-
-=cut
-
-sub is_class {
- my ( $self, $method, $attrs ) = @_;
- die "Usage: method must be passed as first arg" unless $method;
- $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
- return 1 if $attrs =~ /\bClass\b/i;
- return 1 if $method =~ /^list$/; # default class actions
- return 0;
-}
-
-=head2 is_object
-
-Tell if action is a object method (See Maypole::Plugin::Menu)
-
-=cut
-
-sub is_object {
- my ( $self, $method, $attrs ) = @_;
- die "Usage: method must be passed as first arg" unless $method;
- $attrs = join(' ',$self->method_attrs($method)) unless ($attrs);
- return 1 if $attrs =~ /\bObject\b/i;
- return 1 if $method =~ /(^view$|^edit$|^delete$)/; # default object actions
- return 0;
-}
-
-
-=head2 related
-
-This method returns a list of has-many accessors. A brewery has many
-beers, so C<BeerDB::Brewery> needs to return C<beers>.
-
-=cut
-
-sub related {
- my ( $self, $r ) = @_;
- return keys %{ $self->meta_info('has_many') || {} };
-}
-
-
-=head2 related_class
-
-Given an accessor name as a method, this function returns the class this accessor returns.
-
-=cut
-
-sub related_class {
- my ( $self, $r, $accessor ) = @_;
- my $meta = $self->meta_info;
- my @rels = keys %$meta;
- my $related;
- foreach (@rels) {
- $related = $meta->{$_}{$accessor};
- last if $related;
- }
- return unless $related;
-
- my $mapping = $related->{args}->{mapping};
- if ( $mapping and @$mapping ) {
- return $related->{foreign_class}->meta_info('has_a')->{$$mapping[0]}->{foreign_class};
- }
- else {
- return $related->{foreign_class};
- }
- }
-
-=head2 related_meta
-
- $class->related_meta($col);
-
-Given a column associated with a relationship it will return the relatation
-ship type and the meta info for the relationship on the column.
-
-=cut
-
-sub related_meta {
- my ($self,$r, $accssr) = @_;
- $self->_croak("You forgot to put the place holder for 'r' or forgot the accssr parameter") unless $accssr;
- my $class_meta = $self->meta_info;
- if (my ($rel_type) = grep { defined $class_meta->{$_}->{$accssr} }
- keys %$class_meta)
- { return $rel_type, $class_meta->{$rel_type}->{$accssr} };
-}
-
-
-=head2 isa_class
-
-Returns class of a column inherited by is_a.
-
-=cut
-
-# Maybe put this in IsA?
-sub isa_class {
- my ($class, $col) = @_;
- $class->_croak( "Need a column for isa_class." ) unless $col;
- my $isaclass;
- my $isa = $class->meta_info("is_a") || {};
- foreach ( keys %$isa ) {
- $isaclass = $isa->{$_}->foreign_class;
- return $isaclass if ($isaclass->find_column($col));
- }
- return 0; # col not in a is_a class
-}
-
-=head2 accessor_classes
-
-Returns hash ref of classes for accessors.
-
-This is an attempt at a more efficient method than calling "related_class()"
-a bunch of times when you need it for many relations.
-It may be good to call at startup and store in a global config.
-
-=cut
-
-sub accessor_classes {
- my ($self, $class) = @_; # can pass a class arg to get accssor classes for
- $class ||= $self;
- my $meta = $class->meta_info;
- my %res;
- foreach my $rel (keys %$meta) {
- my $rel_meta = $meta->{$rel};
- %res = ( %res, map { $_ => $rel_meta->{$_}->{foreign_class} }
- keys %$rel_meta );
- }
- return \%res;
-
- # 2 liner to get class of accessor for $name
- #my $meta = $class->meta_info;
- #my ($isa) = map $_->foreign_class, grep defined,
- # map $meta->{$_}->{$name}, keys %$meta;
-
-}
-
-
-=head2 stringify_column
-
- Returns the name of the column to use when stringifying
- and object.
-
-=cut
-
-sub stringify_column {
- my $class = shift;
- return (
- $class->columns("Stringify"),
- ( grep { /^(name|title)$/i } $class->columns ),
- ( grep { /(name|title)/i } $class->columns ),
- ( grep { !/id$/i } $class->primary_columns ),
- )[0];
-}
-
-=head2 do_pager
-
- Sets the pager template argument ($r->{template_args}{pager})
- to a Class::DBI::Pager object based on the rows_per_page
- value set in the configuration of the application.
-
- This pager is used via the pager macro in TT Templates, and
- is also accessible via Mason.
-
-=cut
-
-sub do_pager {
- my ( $self, $r ) = @_;
- if ( my $rows = $r->config->rows_per_page ) {
- return $r->{template_args}{pager} =
- $self->pager( $rows, $r->query->{page} );
- }
- else { return $self }
-}
-
-
-=head2 order
-
- Returns the SQL order syntax based on the order parameter passed
- to the request, and the valid columns.. i.e. 'title ASC' or 'date_created DESC'.
-
- $sql .= $self->order($r);
-
- If the order column is not a column of this table,
- or an order argument is not passed, then the return value is undefined.
-
- Note: the returned value does not start with a space.
-
-=cut
-
-sub order {
- my ( $self, $r ) = @_;
- my %ok_columns = map { $_ => 1 } $self->columns;
- my $q = $r->query;
- my $order = $q->{order};
- return unless $order and $ok_columns{$order};
- $order .= ' DESC' if $q->{o2} and $q->{o2} eq 'desc';
- return $order;
-}
-