package Maypole::Model::CDBI;
-use base qw(Maypole::Model::Base Class::DBI);
-use Class::DBI::AsForm;
-use Class::DBI::FromCGI;
-use Class::DBI::Loader;
-use Class::DBI::AbstractSearch;
-use Class::DBI::Plugin::RetrieveAll;
-use Class::DBI::Pager;
-
-use Lingua::EN::Inflect::Number qw(to_PL);
-use CGI::Untaint;
use strict;
=head1 NAME
=head1 DESCRIPTION
-This is a master model class which uses C<Class::DBI> to do all the hard
+This is a master model class which uses L<Class::DBI> to do all the hard
work of fetching rows and representing them as objects. It is a good
model to copy if you're replacing it with other database abstraction
modules.
It implements a base set of methods required for a Maypole Data Model.
-See L<Maypole::Model::Base> for these:
-=over 4
+It inherits accessor and helper methods from L<Maypole::Model::Base>.
-=item adopt
+=cut
-=item class_of
+use base qw(Maypole::Model::Base Class::DBI);
+use Maypole::Model::CDBI::AsForm;
+use CGI::Untaint::Maypole;
-=item do_edit
+use Class::DBI::FromCGI;
+use Class::DBI::Loader;
+use Class::DBI::AbstractSearch;
+use Class::DBI::Plugin::RetrieveAll;
+use Class::DBI::Pager;
-=item list
+use Lingua::EN::Inflect::Number qw(to_PL);
-=item related
-=item setup_database
+###############################################################################
+# Helper methods
-=back
+=head1 Action Methods
-=head1 Additional Commands
+Action methods are methods that are accessed through web (or other public) interface.
-=over
+=item do_edit
-=item delete
+If there is an object in C<$r-E<gt>objects>, then it should be edited
+with the parameters in C<$r-E<gt>params>; otherwise, a new object should
+be created with those parameters, and put back into C<$r-E<gt>objects>.
+The template should be changed to C<view>, or C<edit> if there were any
+errors. A hash of errors will be passed to the template.
-Surprisingly, this command causes a database record to be forever lost.
+=cut
-=item search
+sub do_edit : Exported {
+ my ($self, $r, $obj) = @_;
-The search action
+ my $config = $r->config;
+ my $table = $r->table;
-=back
+ # handle cancel button hits
+ if ( $r->{params}->{cancel} ) {
+ $r->template("list");
+ $r->objects( [$self->retrieve_all] );
+ return;
+ }
-=head1 Helper Methods
+ my $required_cols = $config->{$table}->{required_cols} || [];
+ my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
-=over
+ ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
-=item order
+ # handle errors, if none, proceed to view the newly created/updated object
+ my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
-=item stringify_column
+ if (%errors) {
+ # Set it up as it was:
+ $r->template_args->{cgi_params} = $r->params;
+ $r->template_args->{errors} = \%errors;
-=item do_pager
+ undef $obj if $creating;
+ $r->template("edit");
+ } else {
+ $r->template("view");
+ }
-=item related_class
+ $r->objects( $obj ? [$obj] : []);
+}
-Given an accessor name as a method, this function returns the class this accessor returns.
+# split out from do_edit to be reported by Mp::P::Trace
+sub _do_update_or_create {
+ my ($self, $r, $obj, $required_cols, $ignored_cols) = @_;
+
+ my $fatal;
+ my $creating = 0;
+ my $h = CGI::Untaint::Maypole->new( %{$r->params} );
+
+ # update or create
+ if ($obj) {
+ # We have something to edit
+ eval { $obj->update_from_cgi( $h => {
+ required => $required_cols,
+ ignore => $ignored_cols,
+ } ) };
+ $fatal = $@;
+ } else {
+ eval {
+ $obj = $self->create_from_cgi( $h => {
+ required => $required_cols,
+ ignore => $ignored_cols,
+ } )
+ };
+
+ if ($fatal = $@) {
+ warn "$fatal" if $r->debug;
+ }
+ $creating++;
+ }
-=back
+ return $obj, $fatal, $creating;
+}
-=cut
-sub related {
- my ( $self, $r ) = @_;
- return keys %{ $self->meta_info('has_many') || {} };
-}
+=head2 do_delete
-sub related_class {
- my ( $self, $r, $accessor ) = @_;
- my $related = $self->related->{$accessor};
- if ( my $mapping = $related->{args}->{mapping} ) {
- return $related->{foreign_class}->meta_info('has_a')->{ $$mapping[0] }
- ->{foreign_class};
- }
- else {
- return $related->{foreign_class};
- }
-}
+Unsuprisingly, this command causes a database record to be forever lost.
-sub do_edit : Exported {
- my ( $self, $r ) = @_;
- my $h = CGI::Untaint->new( %{ $r->{params} } );
- my $creating = 0;
- my ($obj) = @{ $r->objects || [] };
- if ($obj) {
-
- # We have something to edit
- $obj->update_from_cgi( $h =>
- { required => $r->{config}{ $r->{table} }{required_cols} || [], }
- );
- }
- else {
- $obj =
- $self->create_from_cgi( $h =>
- { required => $r->{config}{ $r->{table} }{required_cols} || [], }
- );
- $creating++;
- }
- if ( my %errors = $obj->cgi_update_errors ) {
+This method replaces the, now deprecated, delete method provided in prior versions
- # Set it up as it was:
- $r->{template_args}{cgi_params} = $r->{params};
- $r->{template_args}{errors} = \%errors;
- $r->{template} = "edit";
- undef $obj if $creating; # Couldn't create
- }
- else {
- $r->{template} = "view";
- }
- $r->objects( [$obj] );
-}
+=cut
sub delete : Exported {
- return shift->SUPER::delete(@_) if caller ne "Maypole::Model::Base";
- my ( $self, $r ) = @_;
- $_->SUPER::delete for @{ $r->objects || [] };
- $r->objects( [ $self->retrieve_all ] );
- $r->{template} = "list";
- $self->list($r);
+ my $self = shift;
+ my ($sub) = (caller(1))[3];
+ $sub =~ /^(.+)::([^:]+)$/;
+ # So subclasses can still send search down ...
+ return ($1 ne "Maypole::Model::Base" && $2 ne "delete") ?
+ $self->SUPER::search(@_) : $self->do_delete(@_);
}
-sub stringify_column {
- my $class = shift;
- return (
- $class->columns("Stringify"),
- ( grep { /(name|title)/i } $class->columns ),
- ( grep { !/id$/i } $class->primary_columns ),
- )[0];
+sub do_delete {
+ my ( $self, $r ) = @_;
+ $_->SUPER::delete for @{ $r->objects || [] };
+ $r->objects( [ $self->retrieve_all ] );
+ $r->{template} = "list";
+ $self->list($r);
}
-sub adopt {
- my ( $self, $child ) = @_;
- $child->autoupdate(1);
- if ( my $col = $child->stringify_column ) {
- $child->columns( Stringify => $col );
- }
-}
+
+=head2 do_search
+
+This action method searches for database records, it replaces
+the, now deprecated, search method previously provided.
+
+=cut
sub search : Exported {
- return shift->SUPER::search(@_) if caller ne "Maypole::Model::Base";
+ my $self = shift;
+ my ($sub) = (caller(1))[3];
+ $sub =~ /^(.+)::([^:]+)$/;
+ # So subclasses can still send search down ...
+ return ($1 ne "Maypole::Model::Base" && $2 ne "search") ?
+ $self->SUPER::search(@_) : $self->do_search(@_);
+}
- # A real CDBI search.
+sub do_search : Exported {
my ( $self, $r ) = @_;
my %fields = map { $_ => 1 } $self->columns;
my $oper = "like"; # For now
my %params = %{ $r->{params} };
my %values = map { $_ => { $oper, $params{$_} } }
- grep { defined $params{$_} and $fields{$_} } keys %params;
+ grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
+ keys %params;
$r->template("list");
if ( !%values ) { return $self->list($r) }
$r->objects(
[
$self->search_where(
- \%values, ( $order ? { order => $order } : () )
+ \%values, ( $order ? { order_by => $order } : () )
)
]
);
$r->{template_args}{search} = 1;
}
+=head2 list
+
+The C<list> method fills C<$r-E<gt>objects> with all of the
+objects in the class. The results are paged using a pager.
+
+=cut
+
+sub list : Exported {
+ my ( $self, $r ) = @_;
+ my $order = $self->order($r);
+ $self = $self->do_pager($r);
+ if ($order) {
+ $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
+ }
+ else {
+ $r->objects( [ $self->retrieve_all ] );
+ }
+}
+
+#######################
+# _process_local_srch #
+#######################
+
+# Makes the local part of the db search query
+# Puts search prams local to this table in where array.
+# Returns a where array ref and search criteria string.
+# This is factored out of do_search so sub classes can override this part
+sub _process_local_srch {
+ my ($self, $hashed) = @_;
+ my %fields = map { $_ => 1 } $self->columns;
+ my $moniker = $self->moniker;
+ my %colnames = $self->column_names;
+ my $srch_crit = '';
+ my ($oper, $wc);
+ my @where = map {
+ # prelim
+ $srch_crit .= ' '.$colnames{$_}." = '".$hashed->{$_}."'";
+ $oper = $self->sql_search_oper($_);
+ $wc = $oper =~ /LIKE/i ? '%':''; # match any substr
+ "$moniker.$_ $oper '$wc" . $hashed->{$_} . "$wc'"; #the where clause
+ }
+ grep { defined $hashed->{$_} && length ($hashed->{$_}) && $fields{$_} }
+ keys %$hashed;
+
+ return (\@where, $srch_crit);
+}
+
+#########################
+# _process_foreign_srch #
+#########################
+
+# puts foreign search fields into select statement
+# changes @where by ref and return sel and srch_criteria string
+sub _process_foreign_srch {
+ my ($self, $hashed, $sel, $where, $srch_crit) = @_;
+ my %colnames = $self->column_names;
+ my $moniker = $self->moniker;
+ my %foreign;
+ foreach (keys %$hashed) {
+ $foreign{$_} = delete $hashed->{$_} if ref $hashed->{$_};
+ }
+ my %accssr_class = %{$self->accessor_classes};
+ while (my ( $accssr, $prms) = each %foreign ) {
+ my $fclass = $accssr_class{$accssr};
+ my %fields = map { $_ => 1 } $fclass->columns;
+ my %colnames = $fclass->column_names;
+ my ($oper, $wc);
+ my @this_where =
+ # TODO make field name match in all cases in srch crit
+ map {
+ # prelim
+ $srch_crit.= ' '.$colnames{$_}." = '".$prms->{$_}."'";
+ $oper = $fclass->sql_search_oper($_);
+ $wc = $oper =~ /LIKE/i ? '%':'';
+ "$accssr.$_ $oper '$wc".$prms->{$_}."$wc'"; # the where
+ }
+ grep { defined $prms->{$_} && length ($prms->{$_}) && $fields{$_} }
+ keys %$prms;
+
+ next unless @this_where;
+ $sel .= ", " . $fclass->table . " $accssr"; # add foreign tables to from
+
+ # map relationships -- TODO use constraints in has_many and mhaves
+ # and make general
+ my $pk = $self->primary_column;
+ if ($fclass->find_column('owner_id') && $fclass->find_column('owner_table') ) {
+ unshift @this_where, ("$accssr.owner_id = $moniker.$pk",
+ "$accssr.owner_table = '" . $self->table ."'");
+ }
+ # for has_own, has_a where foreign id is in self's table
+ elsif ( my $fk = $self->find_column($fclass->primary_column) ) {
+ unshift @this_where, "$accssr." . $fk->name . " = $moniker." . $fk->name;
+ }
+ push @$where, @this_where;
+ }
+ return ($sel, $srch_crit);
+}
+
+###############################################################################
+# Helper methods
+
+=head1 Helper Methods
+
+
+=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_public
+
+Should return true if a certain action is supported, or false otherwise.
+Defaults to checking if the sub has the C<:Exported> attribute.
+
+=cut
+
+sub is_public {
+ my ( $self, $action, $attrs ) = @_;
+ my $cv = $self->can($action);
+ warn "is_public failed . action is $action. self is $self" and return 0 unless $cv;
+ unless ($attrs) {
+ my @attrs = attributes::get($cv) || ();
+ $attrs = join " ", @attrs;
+ }
+ do {
+ warn "is_public failed .$action not exported" if Maypole->debug;
+ return 0;
+ } unless $attrs =~ /\bExported\b/i;
+ return 1;
+}
+
+
+=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 = $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 = $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;
+}
+
+# Get string of joined attributes for matching
+sub method_attrs {
+ my ($class, $method) = @_;
+ my $cv = $class->can($method);
+ return 0 unless $cv;
+ my @attrs = attributes::get($cv) || ();
+ return join " ", @attrs;
+}
+
+=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 isa_class
+
+Returns class of a column inherited by is_a, assumes something can be more than one thing (have * is_a rels)
+
+=cut
+
+sub isa_class {
+ my ($class, $col) = @_;
+ $class->_croak( "Need a column for isa_class." ) unless $col;
+ my $isaclass;
+ # class col is first found in is returned
+ 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.
+
+=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
+
+=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
+
+=cut
+
sub do_pager {
my ( $self, $r ) = @_;
if ( my $rows = $r->config->rows_per_page ) {
else { return $self }
}
+
+=head2 order
+
+=cut
+
sub order {
my ( $self, $r ) = @_;
- my $order;
my %ok_columns = map { $_ => 1 } $self->columns;
- if ( $order = $r->query->{order} and $ok_columns{$order} ) {
- $order .= ( $r->query->{o2} eq "desc" && " DESC" );
- }
- $order;
+ 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;
}
-sub list : Exported {
- my ( $self, $r ) = @_;
- my $order = $self->order($r);
- $self = $self->do_pager($r);
- if ($order) {
- $r->objects( [ $self->retrieve_all_sorted_by($order) ] );
- }
- else {
- $r->objects( [ $self->retrieve_all ] );
- }
-}
+=head2 setup_database
+
+=cut
sub setup_database {
- my ( $self, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
+ my ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
$dsn ||= $config->dsn;
$u ||= $config->user;
$p ||= $config->pass;
$opts ||= $config->opts;
$config->dsn($dsn);
+ warn "No DSN set in config" unless $dsn;
$config->loader || $config->loader(
Class::DBI::Loader->new(
namespace => $namespace,
dsn => $dsn,
user => $u,
password => $p,
- options => $opts,
+ %$opts,
)
);
$config->{classes} = [ $config->{loader}->classes ];
$config->{tables} = [ $config->{loader}->tables ];
+ warn( 'Loaded tables: ' . join ',', @{ $config->{tables} } )
+ if $namespace->debug;
}
sub class_of {
my ( $self, $r, $table ) = @_;
- return $r->config->loader->_table2class($table);
+ return $r->config->loader->_table2class($table); # why not find_class ?
}
-1;
+sub fetch_objects {
+ my ($class, $r)=@_;
+ my @pcs = $class->primary_columns;
+ if ( $#pcs ) {
+ my %pks;
+ @pks{@pcs}=(@{$r->{args}});
+ return $class->retrieve( %pks );
+ }
+ return $class->retrieve( $r->{args}->[0] );
+}
+
+
+###############################################################################
+# private / internal functions and classes
+sub _column_info {
+ my $class = shift;
+ $class = ref $class || $class;
+ no strict 'refs';
+ return ${$class . '::COLUMN_INFO'};
+}
+
+1;