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

diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm
index d99eb50..a5c65f6 100644
--- a/lib/Maypole/Model/CDBI.pm
+++ b/lib/Maypole/Model/CDBI.pm
@@ -1,14 +1,4 @@
 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
@@ -23,153 +13,153 @@ 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
-
-=item adopt
-
-=item class_of
-
-=item do_edit
 
-=item list
+It inherits accessor and helper methods from L<Maypole::Model::Base>.
 
-=item related
+=cut
 
-=item setup_database
+use base qw(Maypole::Model::Base Class::DBI);
+use Maypole::Model::CDBI::AsForm;
+use CGI::Untaint::Maypole;
 
-=item fetch_objects
+use Class::DBI::FromCGI;
+use Class::DBI::Loader;
+use Class::DBI::AbstractSearch;
+use Class::DBI::Plugin::RetrieveAll;
+use Class::DBI::Pager;
 
-=back 
+use Lingua::EN::Inflect::Number qw(to_PL);
+use attributes ();
 
-=head1 Additional Actions
+###############################################################################
+# Helper methods
 
-=over 
+=head1 Action Methods
 
-=item delete
+Action methods are methods that are accessed through web (or other public) interface.
 
-Unsuprisingly, this command causes a database record to be forever lost.
+=item do_edit
 
-=item search
+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.
 
-The search action 
+=cut
 
-=back
+sub do_edit : Exported {
+  my ($self, $r, $obj) = @_;
 
-=head1 Helper Methods
+  my $config   = $r->config;
+  my $table    = $r->table;
 
-=over 
+  # handle cancel button hits
+  if ( $r->{params}->{cancel} ) {
+    $r->template("list");
+    $r->objects( [$self->retrieve_all] );
+    return;
+  }
 
-=item order
+  my $required_cols = $config->{$table}->{required_cols} || [];
+  my $ignored_cols = $r->{config}{ $r->{table} }{ignore_cols} || [];
 
-=item stringify_column
+  ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_cols);
 
-=item do_pager
+  # handle errors, if none, proceed to view the newly created/updated object
+  my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors;
 
-=item related_class
+  if (%errors) {
+    # Set it up as it was:
+    $r->template_args->{cgi_params} = $r->params;
+    $r->template_args->{errors}     = \%errors;
 
-Given an accessor name as a method, this function returns the class this accessor returns.
+    undef $obj if $creating;
+    $r->template("edit");
+  } else {
+    $r->template("view");
+  }
 
-=back
+  $r->objects( $obj ? [$obj] : []);
+}
 
-=cut
+# 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++;
+  }
 
-sub related {
-    my ( $self, $r ) = @_;
-    return keys %{ $self->meta_info('has_many') || {} };
+  return $obj, $fatal, $creating;
 }
 
-sub related_class {
-    my ( $self, $r, $accessor ) = @_;
 
-    my $related = $self->meta_info( has_many => $accessor ) ||
-                  $self->meta_info( has_a    => $accessor ) ||
-                  return;
+=head2 do_delete
 
-    my $mapping = $related->{args}->{mapping};
-    if ( @$mapping ) {
-        return $related->{foreign_class}->meta_info('has_a')->{ $$mapping[0] }
-          ->{foreign_class};
-    }
-    else {
-        return $related->{foreign_class};
-    }
-}
-
-sub do_edit : Exported {
-    my ( $self, $r ) = @_;
-    my $h        = CGI::Untaint->new( %{ $r->{params} } );
-    my $creating = 0;
-    my ($obj) = @{ $r->objects || [] };
-    my $fatal;
-    if ($obj) {
-        # We have something to edit
-        eval {
-            $obj->update_from_cgi( $h =>
-                { required => $r->{config}{ $r->{table} }{required_cols} || [], }
-            );
-        };
-        $fatal = $@;
-    }
-    else {
-        eval {
-            $obj =
-                $self->create_from_cgi( $h =>
-                    { required => $r->{config}{ $r->{table} }{required_cols} || [], }
-            );
-        };
-        if ($fatal = $@) {
-            warn "$fatal" if $r->debug;
-        }
-        $creating++;
-    }
-    if ( my %errors = $fatal ? (FATAL => $fatal) : $obj->cgi_update_errors ) {
+Unsuprisingly, this command causes a database record to be forever lost.
 
-        # Set it up as it was:
-        $r->{template_args}{cgi_params} = $r->{params};
-        $r->{template_args}{errors}     = \%errors;
+This method replaces the, now deprecated, delete method provided in prior versions
 
-        undef $obj if $creating;
-        $r->template("edit");
-    }
-    else {
-        $r->{template} = "view";
-    }
-    $r->objects( $obj ? [$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 { /(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
@@ -192,6 +182,261 @@ sub search : Exported {
     $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_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 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 ) {
@@ -201,6 +446,11 @@ sub do_pager {
     else { return $self }
 }
 
+
+=head2 order
+
+=cut
+
 sub order {
     my ( $self, $r ) = @_;
     my %ok_columns = map { $_ => 1 } $self->columns;
@@ -211,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 ) = @_;
@@ -248,7 +490,7 @@ sub setup_database {
 
 sub class_of {
     my ( $self, $r, $table ) = @_;
-    return $r->config->loader->_table2class($table);
+    return $r->config->loader->_table2class($table); # why not find_class ?
 }
 
 sub fetch_objects {
@@ -262,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;