X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI.pm;h=a5c65f65166c417f1171ee051e97768713ee188e;hb=f19715f56244cc6d862169c2dd656b8a2f3845b5;hp=6ae19f53fa12db0ee355dcebb6425e26b30fe256;hpb=12d8a77a713d5ed4f08414e5f34e96d45f60e2d3;p=maypole.git

diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm
index 6ae19f5..a5c65f6 100644
--- a/lib/Maypole/Model/CDBI.pm
+++ b/lib/Maypole/Model/CDBI.pm
@@ -1,18 +1,4 @@
 package Maypole::Model::CDBI;
-use base qw(Maypole::Model::Base Class::DBI);
-use Class::DBI::AsForm;
-# use Maypole::Form::CDBI;
-use CGI::Untaint;
-# use Maypole::Form;
-
-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 strict;
 
 =head1 NAME
@@ -27,55 +13,329 @@ 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>.
+
+=cut
+
+use base qw(Maypole::Model::Base Class::DBI);
+use Maypole::Model::CDBI::AsForm;
+use CGI::Untaint::Maypole;
+
+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 attributes ();
+
+###############################################################################
+# Helper methods
 
-=item adopt
+=head1 Action Methods
 
-=item class_of
+Action methods are methods that are accessed through web (or other public) interface.
 
 =item do_edit
 
-=item list
+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.
+
+=cut
+
+sub do_edit : Exported {
+  my ($self, $r, $obj) = @_;
+
+  my $config   = $r->config;
+  my $table    = $r->table;
+
+  # handle cancel button hits
+  if ( $r->{params}->{cancel} ) {
+    $r->template("list");
+    $r->objects( [$self->retrieve_all] );
+    return;
+  }
+
+  my $required_cols = $config->{$table}->{required_cols} || [];
+  my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
 
-=item related
+  ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
 
-=item setup_database
+  # handle errors, if none, proceed to view the newly created/updated object
+  my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
 
-=item fetch_objects
+  if (%errors) {
+    # Set it up as it was:
+    $r->template_args->{cgi_params} = $r->params;
+    $r->template_args->{errors}     = \%errors;
 
-=back 
+    undef $obj if $creating;
+    $r->template("edit");
+  } else {
+    $r->template("view");
+  }
 
-=head1 Additional Actions
+  $r->objects( $obj ? [$obj] : []);
+}
+
+# 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++;
+  }
+
+  return $obj, $fatal, $creating;
+}
 
-=over 
 
-=item delete
+=head2 do_delete
 
 Unsuprisingly, this command causes a database record to be forever lost.
 
-=item search
+This method replaces the, now deprecated, delete method provided in prior versions
+
+=cut
+
+sub delete : Exported {
+  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 do_delete {
+  my ( $self, $r ) = @_;
+  $_->SUPER::delete for @{ $r->objects || [] };
+  $r->objects( [ $self->retrieve_all ] );
+  $r->{template} = "list";
+  $self->list($r);
+}
+
+
+=head2 do_search
+
+This action method searches for database records, it replaces
+the, now deprecated, search method previously provided.
+
+=cut
+
+sub search : Exported {
+  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(@_);
+}
+
+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{$_} && length ($params{$_}) && $fields{$_} }
+      keys %params;
+
+    $r->template("list");
+    if ( !%values ) { return $self->list($r) }
+    my $order = $self->order($r);
+    $self = $self->do_pager($r);
+    $r->objects(
+        [
+            $self->search_where(
+                \%values, ( $order ? { order_by => $order } : () )
+            )
+        ]
+    );
+    $r->{template_args}{search} = 1;
+}
 
-The search action 
+=head2 list
 
-=back
+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
 
-=over 
 
-=item order
+=head2 adopt
 
-=item stringify_column
+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.
 
-=item do_pager
+=cut
 
-=item related_class
+sub adopt {
+    my ( $self, $child ) = @_;
+    $child->autoupdate(1);
+    if ( my $col = $child->stringify_column ) {
+        $child->columns( Stringify => $col );
+    }
+}
 
-Given an accessor name as a method, this function returns the class this accessor returns.
+=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;
+}
 
-=back
+
+=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
 
@@ -84,6 +344,13 @@ sub related {
     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;
@@ -104,80 +371,58 @@ sub related_class {
      }
  }
 
+=head2 isa_class
 
-sub do_edit : Exported 
-{
-    my ($self, $r, $obj) = @_;
-
-    my $config   = $r->config;
-    my $table    = $r->table;
-    
-    my $required_cols = $config->{$table}->{required_cols} || [];
-    
-    ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols);
-    
-    # handle errors, if none, proceed to view the newly created/updated object
-    my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
-    
-    if (%errors) 
-    {
-        # Set it up as it was:
-        $r->template_args->{cgi_params} = $r->params;
-        $r->template_args->{errors}     = \%errors;
-
-        undef $obj if $creating;
-        $r->template("edit");
-    }
-    else 
-    {
-        $r->template("view");
-    }
-    
-    $r->objects( $obj ? [$obj] : []);
-}
+Returns class of a column inherited by is_a, assumes something can be more than one thing (have * is_a rels)
 
-# drb - I've (probably temporarily) split this out from do_edit, so it's 
-# reported by Mp::P::Trace
-sub _do_update_or_create
-{
-    my ($self, $r, $obj, $required_cols) = @_;
-    
-    my $fatal;
-    my $creating = 0;
-    my $h = CGI::Untaint->new( %{$r->params} );
-    
-    # update or create
-    if ($obj) 
-    {
-        # We have something to edit
-        eval { $obj->update_from_cgi( $h => {required => $required_cols} ) };
-        $fatal = $@;
-    }
-    else 
-    {
-        eval { 
-            $obj = $self->create_from_cgi( $h => {required => $required_cols} ) 
-        };
-        
-        if ($fatal = $@) 
-        {
-            warn "$fatal" if $r->debug;
-        }
-        $creating++;
-    }
-    
-    return $obj, $fatal, $creating;
+=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 
 }
-    
-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);
+
+=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 (
@@ -188,39 +433,9 @@ sub stringify_column {
     )[0];
 }
 
-sub adopt {
-    my ( $self, $child ) = @_;
-    $child->autoupdate(1);
-    if ( my $col = $child->stringify_column ) {
-        $child->columns( Stringify => $col );
-    }
-}
-
-sub search : Exported {
-    return shift->SUPER::search(@_) if caller ne "Maypole::Model::Base";
-
-    # A real CDBI search.
-    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{$_} && length ($params{$_}) && $fields{$_} }
-      keys %params;
+=head2 do_pager
 
-    $r->template("list");
-    if ( !%values ) { return $self->list($r) }
-    my $order = $self->order($r);
-    $self = $self->do_pager($r);
-    $r->objects(
-        [
-            $self->search_where(
-                \%values, ( $order ? { order_by => $order } : () )
-            )
-        ]
-    );
-    $r->{template_args}{search} = 1;
-}
+=cut
 
 sub do_pager {
     my ( $self, $r ) = @_;
@@ -231,6 +446,11 @@ sub do_pager {
     else { return $self }
 }
 
+
+=head2 order
+
+=cut
+
 sub order {
     my ( $self, $r ) = @_;
     my %ok_columns = map { $_ => 1 } $self->columns;
@@ -241,17 +461,9 @@ sub order {
     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 ( $class, $config, $namespace, $dsn, $u, $p, $opts ) = @_;
@@ -292,4 +504,15 @@ sub fetch_objects {
     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;