X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=4a6eaa8ad96522f3d47b1d6667ad32bccdd8a6a1;hb=04ebc6f4d9b90ad04258ef202c3879b509dd0b09;hp=055f89a44e6474af09765482ba0abeddbc4bb84c;hpb=f97f9210550436b841141e791ee25dd3c723ab63;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index 055f89a..4a6eaa8 100644
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -29,6 +29,8 @@ DBIx::Class::ResultSource - Result source object
 A ResultSource is a component of a schema from which results can be directly
 retrieved, most usually a table (see L<DBIx::Class::ResultSource::Table>)
 
+Basic view support also exists, see L<<DBIx::Class::ResultSource::View>.
+
 =head1 METHODS
 
 =pod
@@ -72,7 +74,7 @@ the hashref as the column_info for that column. Repeated calls of this
 method will add more columns, not replace them.
 
 The column names given will be created as accessor methods on your
-L<DBIx::Class::Row> objects, you can change the name of the accessor
+L<DBIx::Class::Row> objects. You can change the name of the accessor
 by supplying an L</accessor> in the column_info hash.
 
 The contents of the column_info are not set in stone. The following
@@ -123,8 +125,12 @@ L<DBIx::Class::Schema/deploy>.
 =item default_value
 
 Set this to the default value which will be inserted into a column
-by the database. Can contain either a value or a function. This is
-currently only used by L<DBIx::Class::Schema/deploy>.
+by the database. Can contain either a value or a function (use a
+reference to a scalar e.g. C<\'now()'> if you want a function). This
+is currently only used by L<DBIx::Class::Schema/deploy>.
+
+See the note on L<DBIx::Class::Row/new> for more information about possible
+issues related to db-side default values.
 
 =item sequence
 
@@ -136,7 +142,7 @@ automatically.
 =item auto_nextval
 
 Set this to a true value for a column whose value is retrieved
-automatically from an oracle sequence. If you do not use an oracle
+automatically from an oracle sequence. If you do not use an Oracle
 trigger to get the nextval, you have to set sequence as well.
 
 =item extra
@@ -544,6 +550,76 @@ sub unique_constraint_columns {
   return @{ $unique_constraints{$constraint_name} };
 }
 
+=head2 sqlt_deploy_callback
+
+=over
+
+=item Arguments: $callback
+
+=back
+
+  __PACKAGE__->sqlt_deploy_callback('mycallbackmethod');
+
+An accessor to set a callback to be called during deployment of
+the schema via L<DBIx::Class::Schema/create_ddl_dir> or
+L<DBIx::Class::Schema/deploy>.
+
+The callback can be set as either a code reference or the name of a
+method in the current result class.
+
+If not set, the L</default_sqlt_deploy_hook> is called.
+
+Your callback will be passed the $source object representing the
+ResultSource instance being deployed, and the
+L<SQL::Translator::Schema::Table> object being created from it. The
+callback can be used to manipulate the table object or add your own
+customised indexes. If you need to manipulate a non-table object, use
+the L<DBIx::Class::Schema/sqlt_deploy_hook>.
+
+See L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To
+Your SQL> for examples.
+
+This sqlt deployment callback can only be used to manipulate
+SQL::Translator objects as they get turned into SQL. To execute
+post-deploy statements which SQL::Translator does not currently
+handle, override L<DBIx::Class::Schema/deploy> in your Schema class
+and call L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
+
+=head2 default_sqlt_deploy_hook
+
+=over
+
+=item Arguments: $source, $sqlt_table
+
+=item Return value: undefined
+
+=back
+
+This is the sensible default for L</sqlt_deploy_callback>.
+
+If a method named C<sqlt_deploy_hook> exists in your Result class, it
+will be called and passed the current C<$source> and the
+C<$sqlt_table> being deployed.
+
+=cut
+
+sub default_sqlt_deploy_hook {
+  my $self = shift;
+
+  my $class = $self->result_class;
+
+  if ($class and $class->can('sqlt_deploy_hook')) {
+    $class->sqlt_deploy_hook(@_);
+  }
+}
+
+sub _invoke_sqlt_deploy_hook {
+  my $self = shift;
+  if ( my $hook = $self->sqlt_deploy_callback) {
+    $self->$hook(@_);
+  }
+}
+
 =head2 resultset
 
 =over 4
@@ -577,7 +653,7 @@ but is cached from then on unless resultset_class changes.
 
   $source->resultset_class('My::ResultSet::Class');
 
-Set the class of the resultset, this is useful if you want to create your
+Set the class of the resultset. This is useful if you want to create your
 own resultset methods. Create your own class derived from
 L<DBIx::Class::ResultSet>, and set it here. If called with no arguments,
 this method returns the name of the existing resultset class, if one
@@ -765,7 +841,7 @@ relationship.
 =back
 
 Throws an exception if the condition is improperly supplied, or cannot
-be resolved using L</resolve_join>.
+be resolved.
 
 =cut
 
@@ -805,7 +881,7 @@ sub add_relationship {
   }
   return unless $f_source; # Can't test rel without f_source
 
-  eval { $self->resolve_join($rel, 'me') };
+  eval { $self->_resolve_join($rel, 'me') };
 
   if ($@) { # If the resolve failed, back out and re-throw the error
     delete $rels{$rel}; #
@@ -939,29 +1015,22 @@ sub reverse_relationship_info {
       my @other_cond = keys(%$othercond);
       my @other_refkeys = map {/^\w+\.(\w+)$/} @other_cond;
       my @other_keys = map {$othercond->{$_} =~ /^\w+\.(\w+)$/} @other_cond;
-      next if (!$self->compare_relationship_keys(\@refkeys, \@other_keys) ||
-               !$self->compare_relationship_keys(\@other_refkeys, \@keys));
+      next if (!$self->_compare_relationship_keys(\@refkeys, \@other_keys) ||
+               !$self->_compare_relationship_keys(\@other_refkeys, \@keys));
       $ret->{$otherrel} =  $otherrel_info;
     }
   }
   return $ret;
 }
 
-=head2 compare_relationship_keys
-
-=over 4
-
-=item Arguments: \@keys1, \@keys2
-
-=item Return value: 1/0 (true/false)
-
-=back
-
-Returns true if both sets of keynames are the same, false otherwise.
-
-=cut
-
 sub compare_relationship_keys {
+  carp 'compare_relationship_keys is a private method, stop calling it';
+  my $self = shift;
+  $self->_compare_relationship_keys (@_);
+}
+
+# Returns true if both sets of keynames are the same, false otherwise.
+sub _compare_relationship_keys {
   my ($self, $keys1, $keys2) = @_;
 
   # Make sure every keys1 is in keys2
@@ -994,44 +1063,54 @@ sub compare_relationship_keys {
   return $found;
 }
 
-=head2 resolve_join
-
-=over 4
-
-=item Arguments: $relation
+sub resolve_join {
+  carp 'resolve_join is a private method, stop calling it';
+  my $self = shift;
+  $self->_resolve_join (@_);
+}
 
-=item Return value: Join condition arrayref
+# Returns the {from} structure used to express JOIN conditions
+sub _resolve_join {
+  my ($self, $join, $alias, $seen, $force_left, $jpath) = @_;
 
-=back
+  # we need a supplied one, because we do in-place modifications, no returns
+  $self->throw_exception ('You must supply a seen hashref as the 3rd argument to _resolve_join')
+    unless $seen;
 
-Returns the join structure required for the related result source.
+  $force_left ||= { force => 0 };
 
-=cut
+  # This isn't quite right, we should actually dive into $seen and reconstruct
+  # the entire path (the reference entry point would be the join conditional
+  # with depth == current_depth - 1. At this point however nothing depends on
+  # having the entire path, transcending related_resultset, so just leave it
+  # as is, hairy enough already.
+  $jpath ||= [];  
 
-sub resolve_join {
-  my ($self, $join, $alias, $seen, $force_left) = @_;
-  $seen ||= {};
-  $force_left ||= { force => 0 };
   if (ref $join eq 'ARRAY') {
-    return map { $self->resolve_join($_, $alias, $seen) } @$join;
+    return
+      map {
+        local $force_left->{force} = $force_left->{force};
+        $self->_resolve_join($_, $alias, $seen, $force_left, [@$jpath]);
+      } @$join;
   } elsif (ref $join eq 'HASH') {
     return
       map {
-        my $as = ($seen->{$_} ? $_.'_'.($seen->{$_}+1) : $_);
-        local $force_left->{force};
+        my $as = ($seen->{$_} ? join ('_', $_, $seen->{$_} + 1) : $_);  # the actual seen value will be incremented below
+        local $force_left->{force} = $force_left->{force};
         (
-          $self->resolve_join($_, $alias, $seen, $force_left),
-          $self->related_source($_)->resolve_join(
-            $join->{$_}, $as, $seen, $force_left
+          $self->_resolve_join($_, $alias, $seen, $force_left, [@$jpath]),
+          $self->related_source($_)->_resolve_join(
+            $join->{$_}, $as, $seen, $force_left, [@$jpath, $_]
           )
         );
       } keys %$join;
   } elsif (ref $join) {
     $self->throw_exception("No idea how to resolve join reftype ".ref $join);
   } else {
+
     my $count = ++$seen->{$join};
-    #use Data::Dumper; warn Dumper($seen);
     my $as = ($count > 1 ? "${join}_${count}" : $join);
+
     my $rel_info = $self->relationship_info($join);
     $self->throw_exception("No such relationship ${join}") unless $rel_info;
     my $type;
@@ -1042,28 +1121,25 @@ sub resolve_join {
       $force_left->{force} = 1 if lc($type) eq 'left';
     }
     return [ { $as => $self->related_source($join)->from,
-               -join_type => $type },
-             $self->resolve_condition($rel_info->{cond}, $as, $alias) ];
+               -join_type => $type,
+               -join_path => [@$jpath, $join],
+               -join_alias => $as,
+               -relation_chain_depth => $seen->{-relation_chain_depth} || 0,
+             },
+             $self->_resolve_condition($rel_info->{cond}, $as, $alias) ];
   }
 }
 
-=head2 pk_depends_on
-
-=over 4
-
-=item Arguments: $relname, $rel_data
-
-=item Return value: 1/0 (true/false)
-
-=back
-
-Determines whether a relation is dependent on an object from this source
-having already been inserted. Takes the name of the relationship and a
-hashref of columns of the related object.
-
-=cut
-
 sub pk_depends_on {
+  carp 'pk_depends_on is a private method, stop calling it';
+  my $self = shift;
+  $self->_pk_depends_on (@_);
+}
+
+# Determines whether a relation is dependent on an object from this source
+# having already been inserted. Takes the name of the relationship and a
+# hashref of columns of the related object.
+sub _pk_depends_on {
   my ($self, $relname, $rel_data) = @_;
   my $cond = $self->relationship_info($relname)->{cond};
 
@@ -1092,23 +1168,18 @@ sub pk_depends_on {
   return 1;
 }
 
-=head2 resolve_condition
-
-=over 4
-
-=item Arguments: $cond, $as, $alias|$object
-
-=back
-
-Resolves the passed condition to a concrete query fragment. If given an alias,
-returns a join condition; if given an object, inverts that object to produce
-a related conditional from that object.
-
-=cut
+sub resolve_condition {
+  carp 'resolve_condition is a private method, stop calling it';
+  my $self = shift;
+  $self->_resolve_condition (@_);
+}
 
+# Resolves the passed condition to a concrete query fragment. If given an alias,
+# returns a join condition; if given an object, inverts that object to produce
+# a related conditional from that object.
 our $UNRESOLVABLE_CONDITION = \'1 = 0';
 
-sub resolve_condition {
+sub _resolve_condition {
   my ($self, $cond, $as, $for) = @_;
   #warn %$cond;
   if (ref $cond eq 'HASH') {
@@ -1124,7 +1195,11 @@ sub resolve_condition {
         #warn "$self $k $for $v";
         unless ($for->has_column_loaded($v)) {
           if ($for->in_storage) {
-            $self->throw_exception("Column ${v} not loaded on ${for} trying to resolve relationship");
+            $self->throw_exception(
+              "Column ${v} not loaded or not passed to new() prior to insert()"
+                ." on ${for} trying to resolve relationship (maybe you forgot "
+                  ."to call ->reload_from_storage to get defaults from the db)"
+            );
           }
           return $UNRESOLVABLE_CONDITION;
         }
@@ -1145,66 +1220,18 @@ sub resolve_condition {
     }
     return \%ret;
   } elsif (ref $cond eq 'ARRAY') {
-    return [ map { $self->resolve_condition($_, $as, $for) } @$cond ];
+    return [ map { $self->_resolve_condition($_, $as, $for) } @$cond ];
   } else {
    die("Can't handle this yet :(");
   }
 }
 
-=head2 resolve_prefetch
-
-=over 4
-
-=item Arguments: hashref/arrayref/scalar
-
-=back
-
-Accepts one or more relationships for the current source and returns an
-array of column names for each of those relationships. Column names are
-prefixed relative to the current source, in accordance with where they appear
-in the supplied relationships. Examples:
-
-  my $source = $schema->resultset('Tag')->source;
-  @columns = $source->resolve_prefetch( { cd => 'artist' } );
-
-  # @columns =
-  #(
-  #  'cd.cdid',
-  #  'cd.artist',
-  #  'cd.title',
-  #  'cd.year',
-  #  'cd.artist.artistid',
-  #  'cd.artist.name'
-  #)
-
-  @columns = $source->resolve_prefetch( qw[/ cd /] );
-
-  # @columns =
-  #(
-  #   'cd.cdid',
-  #   'cd.artist',
-  #   'cd.title',
-  #   'cd.year'
-  #)
-
-  $source = $schema->resultset('CD')->source;
-  @columns = $source->resolve_prefetch( qw[/ artist producer /] );
-
-  # @columns =
-  #(
-  #  'artist.artistid',
-  #  'artist.name',
-  #  'producer.producerid',
-  #  'producer.name'
-  #)
-
-=cut
-
+# Legacy code, needs to go entirely away (fully replaced by _resolve_prefetch)
 sub resolve_prefetch {
+  carp 'resolve_prefetch is a private method, stop calling it';
+
   my ($self, $pre, $alias, $seen, $order, $collapse) = @_;
   $seen ||= {};
-  #$alias ||= $self->name;
-  #warn $alias, Dumper $pre;
   if( ref $pre eq 'ARRAY' ) {
     return
       map { $self->resolve_prefetch( $_, $alias, $seen, $order, $collapse ) }
@@ -1217,7 +1244,6 @@ sub resolve_prefetch {
       $self->related_source($_)->resolve_prefetch(
                $pre->{$_}, "${alias}.$_", $seen, $order, $collapse)
     } keys %$pre;
-    #die Dumper \@ret;
     return @ret;
   }
   elsif( ref $pre ) {
@@ -1270,8 +1296,92 @@ sub resolve_prefetch {
 
     return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
       $rel_source->columns;
-    #warn $alias, Dumper (\@ret);
-    #return @ret;
+  }
+}
+
+# Accepts one or more relationships for the current source and returns an
+# array of column names for each of those relationships. Column names are
+# prefixed relative to the current source, in accordance with where they appear
+# in the supplied relationships. Needs an alias_map generated by
+# $rs->_joinpath_aliases
+
+sub _resolve_prefetch {
+  my ($self, $pre, $alias, $alias_map, $order, $collapse, $pref_path) = @_;
+  $pref_path ||= [];
+
+  if( ref $pre eq 'ARRAY' ) {
+    return
+      map { $self->_resolve_prefetch( $_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ) }
+        @$pre;
+  }
+  elsif( ref $pre eq 'HASH' ) {
+    my @ret =
+    map {
+      $self->_resolve_prefetch($_, $alias, $alias_map, $order, $collapse, [ @$pref_path ] ),
+      $self->related_source($_)->_resolve_prefetch(
+               $pre->{$_}, "${alias}.$_", $alias_map, $order, $collapse, [ @$pref_path, $_] )
+    } keys %$pre;
+    return @ret;
+  }
+  elsif( ref $pre ) {
+    $self->throw_exception(
+      "don't know how to resolve prefetch reftype ".ref($pre));
+  }
+  else {
+
+    my $p = $alias_map;
+    $p = $p->{$_} for (@$pref_path, $pre);
+
+    $self->throw_exception (
+      "Unable to resolve prefetch $pre - join alias map does not contain an entry for path "
+      . join (' -> ', @$pref_path, $pre)
+    ) if (ref $p->{-join_aliases} ne 'ARRAY' or not @{$p->{-join_aliases}} );
+    
+    my $as = shift @{$p->{-join_aliases}};
+
+    my $rel_info = $self->relationship_info( $pre );
+    $self->throw_exception( $self->name . " has no such relationship '$pre'" )
+      unless $rel_info;
+    my $as_prefix = ($alias =~ /^.*?\.(.+)$/ ? $1.'.' : '');
+    my $rel_source = $self->related_source($pre);
+
+    if (exists $rel_info->{attrs}{accessor}
+         && $rel_info->{attrs}{accessor} eq 'multi') {
+      $self->throw_exception(
+        "Can't prefetch has_many ${pre} (join cond too complex)")
+        unless ref($rel_info->{cond}) eq 'HASH';
+      my $dots = @{[$as_prefix =~ m/\./g]} + 1; # +1 to match the ".${as_prefix}"
+      if (my ($fail) = grep { @{[$_ =~ m/\./g]} == $dots }
+                         keys %{$collapse}) {
+        my ($last) = ($fail =~ /([^\.]+)$/);
+        carp (
+          "Prefetching multiple has_many rels ${last} and ${pre} "
+          .(length($as_prefix)
+            ? "at the same level (${as_prefix}) "
+            : "at top level "
+          )
+          . 'will currently disrupt both the functionality of $rs->count(), '
+          . 'and the amount of objects retrievable via $rs->next(). '
+          . 'Use at your own risk.'
+        );
+      }
+      #my @col = map { (/^self\.(.+)$/ ? ("${as_prefix}.$1") : ()); }
+      #              values %{$rel_info->{cond}};
+      $collapse->{".${as_prefix}${pre}"} = [ $rel_source->primary_columns ];
+        # action at a distance. prepending the '.' allows simpler code
+        # in ResultSet->_collapse_result
+      my @key = map { (/^foreign\.(.+)$/ ? ($1) : ()); }
+                    keys %{$rel_info->{cond}};
+      my @ord = (ref($rel_info->{attrs}{order_by}) eq 'ARRAY'
+                   ? @{$rel_info->{attrs}{order_by}}
+                   : (defined $rel_info->{attrs}{order_by}
+                       ? ($rel_info->{attrs}{order_by})
+                       : ()));
+      push(@$order, map { "${as}.$_" } (@key, @ord));
+    }
+
+    return map { [ "${as}.$_", "${as_prefix}${pre}.$_", ] }
+      $rel_source->columns;
   }
 }
 
@@ -1367,8 +1477,6 @@ and don't actually accomplish anything on their own:
 
 Creates a new ResultSource object.  Not normally called directly by end users.
 
-=cut
-
 =head2 column_info_from_storage
 
 =over
@@ -1379,81 +1487,12 @@ Creates a new ResultSource object.  Not normally called directly by end users.
 
 =back
 
+  __PACKAGE__->column_info_from_storage(1);
+
 Enables the on-demand automatic loading of the above column
 metadata from storage as neccesary.  This is *deprecated*, and
 should not be used.  It will be removed before 1.0.
 
-  __PACKAGE__->column_info_from_storage(1);
-
-=head2 sqlt_deploy_callback
-
-An attribute which contains the callback to trigger on L</sqlt_deploy_hook>.
-Defaults to L</default_sqlt_deploy_hook>. Can be a code reference or the name
-of a method in the current result class. You would change the default value
-in case you want to share a hook between several result sources, or if you 
-want to use a result source without a declared result class.
-
-=head2 default_sqlt_deploy_hook
-
-=over
-
-=item Arguments: $source, $sqlt_table
-
-=item Return value: undefined
-
-=back
-
-Proxies its arguments to a C<sqlt_deploy_hook> method on the C<result_class>
-if such a method exists. This is useful to make L<SQL::Translator> create
-non-unique indexes, or set table options such as C<Engine=INNODB>. For 
-examples of what you can do with this, see
-L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
-
-=cut
-
-sub default_sqlt_deploy_hook {
-  my $self = shift;
-
-  my $class = $self->result_class;
-
-  if ($class and $class->can('sqlt_deploy_hook')) {
-    $class->sqlt_deploy_hook(@_);
-  }
-}
-
-
-=head2 sqlt_deploy_hook
-
-=over 4
-
-=item Arguments: $source, $sqlt_table
-
-=item Return value: undefined
-
-=back
-
-This is the entry point invoked by L<SQL::Translator::Parser::DBIx::Class>
-during the execution of L<DBIx::Class::Storage::DBI/deployment_statements>.
-Delegates to the method name or code reference specified in
-L</sqlt_deploy_callback>.
-
-Note that the code is called by 
-L<DBIx::Class::Storage::DBI/deployment_statements>, which in turn is called
-before L<DBIx::Class::Schema/deploy>. Therefore the hook can be used only
-to manipulate the L<SQL::Translator::Table> object before it is turned into
-SQL fed to the database. If you want to execute post-deploy statements which
-currently can can not be generated by L<SQL::Translator>, the suggested
-method is to overload L<DBIx::Class::Storage/deploy> and use
-L<dbh_do|DBIx::Class::Storage::DBI/dbh_do>.
-
-=cut
-
-sub sqlt_deploy_hook {
-  my $self = shift;
-  if ( my $hook = $self->sqlt_deploy_callback) {
-    $self->$hook(@_);
-  }
-}
 
 =head1 AUTHORS