X-Git-Url: https://git.decadent.org.uk/gitweb/?a=blobdiff_plain;f=lib%2FMaypole%2FModel%2FCDBI.pm;h=dd9af06c71472df111a129e51bda562173becf65;hb=41a93152a01bdeab5ada42fd423f985554ade78e;hp=171c9164b21de239d2dcde9e75f20200eebb2765;hpb=2225b4184a391bab5f1d9498d5b695ba0c2f09f2;p=maypole.git

diff --git a/lib/Maypole/Model/CDBI.pm b/lib/Maypole/Model/CDBI.pm
index 171c916..dd9af06 100644
--- a/lib/Maypole/Model/CDBI.pm
+++ b/lib/Maypole/Model/CDBI.pm
@@ -1,6 +1,27 @@
 package Maypole::Model::CDBI;
+use strict;
+
+=head1 NAME
+
+Maypole::Model::CDBI - Model class based on Class::DBI
+
+=head1 DESCRIPTION
+
+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.
+
+It inherits accessor and helper methods from L<Maypole::Model::Base>.
+
+=cut
+
 use base qw(Maypole::Model::Base Class::DBI);
-use Class::DBI::AsForm;
+use Maypole::Model::CDBI::AsForm;
+use CGI::Untaint::Maypole;
+
 use Class::DBI::FromCGI;
 use Class::DBI::Loader;
 use Class::DBI::AbstractSearch;
@@ -8,96 +29,144 @@ use Class::DBI::Plugin::RetrieveAll;
 use Class::DBI::Pager;
 
 use Lingua::EN::Inflect::Number qw(to_PL);
-use CGI::Untaint;
-use strict;
 
-=head1 NAME
 
-Maypole::Model::CDBI - Model class based on Class::DBI
+###############################################################################
+# Helper methods
 
-=head1 DESCRIPTION
+=head1 Action Methods
 
-This is a master model class which uses C<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.
+Action methods are methods that are accessed through web (or other public) interface.
+
+=item do_edit
+
+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 related {
-    my ( $self, $r ) = @_;
-    return keys %{ $self->meta_info('has_many') || {} };
+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} || [];
+
+  ($obj, my $fatal, my $creating) = $self->_do_update_or_create($r, $obj, $required_cols, $ignored_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] : []);
 }
 
-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 ) {
+# 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) = @_;
 
-        # 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";
+  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;
     }
-    $r->objects( [$obj] );
+    $creating++;
+  }
+
+  return $obj, $fatal, $creating;
 }
 
+
+=head2 do_delete
+
+Unsuprisingly, this command causes a database record to be forever lost.
+
+This method replaces the, now deprecated, delete method provided in prior versions
+
+=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 { $params{$_} and $fields{$_} } keys %params;
+      grep { defined $params{$_} && length ($params{$_}) && $fields{$_} }
+      keys %params;
 
     $r->template("list");
     if ( !%values ) { return $self->list($r) }
@@ -106,13 +175,299 @@ sub search : Exported {
     $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 ) {
@@ -122,52 +477,73 @@ sub do_pager {
     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;