X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=a2a461b95304722c8fd702b927fa8404f1ba438f;hb=76031e147d6f0d80ab3ec73a12d373962ade1252;hp=3b68af1d7a1f5d4aaf19f0c90e9f06b56858321f;hpb=2baa36f491033fadc057fc0d1be2256200281e9c;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 3b68af1..a2a461b 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -829,7 +829,7 @@ sub find {
 
   # Run the query, passing the result_class since it should propagate for find
   my $rs = $self->search ($final_cond, {result_class => $self->result_class, %$attrs});
-  if (keys %{$rs->_resolved_attrs->{collapse}}) {
+  if ($rs->_resolved_attrs->{collapse}) {
     my $row = $rs->next;
     carp "Query returned more than one row" if $rs->next;
     return $row;
@@ -1038,11 +1038,9 @@ sub single {
 
   my $attrs = $self->_resolved_attrs_copy;
 
-  if (keys %{$attrs->{collapse}}) {
-    $self->throw_exception(
-      'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead'
-    );
-  }
+  $self->throw_exception(
+    'single() can not be used on resultsets prefetching has_many. Use find( \%cond ) or next() instead'
+  ) if $attrs->{collapse};
 
   if ($where) {
     if (defined $attrs->{where}) {
@@ -1056,12 +1054,12 @@ sub single {
     }
   }
 
-  my @data = $self->result_source->storage->select_single(
+  my $data = [ $self->result_source->storage->select_single(
     $attrs->{from}, $attrs->{select},
     $attrs->{where}, $attrs
-  );
+  )];
 
-  return (@data ? ($self->_construct_object(@data))[0] : undef);
+  return @$data ? $self->_construct_objects($data)->[0] : undef;
 }
 
 
@@ -1218,161 +1216,119 @@ first record from the resultset.
 
 sub next {
   my ($self) = @_;
+
   if (my $cache = $self->get_cache) {
     $self->{all_cache_position} ||= 0;
     return $cache->[$self->{all_cache_position}++];
   }
+
   if ($self->{attrs}{cache}) {
     delete $self->{pager};
     $self->{all_cache_position} = 1;
     return ($self->all)[0];
   }
-  if ($self->{stashed_objects}) {
-    my $obj = shift(@{$self->{stashed_objects}});
-    delete $self->{stashed_objects} unless @{$self->{stashed_objects}};
-    return $obj;
-  }
-  my @row = (
-    exists $self->{stashed_row}
-      ? @{delete $self->{stashed_row}}
-      : $self->cursor->next
-  );
-  return undef unless (@row);
-  my ($row, @more) = $self->_construct_object(@row);
-  $self->{stashed_objects} = \@more if @more;
-  return $row;
-}
 
-sub _construct_object {
-  my ($self, @row) = @_;
-
-  my $info = $self->_collapse_result($self->{_attrs}{as}, \@row)
-    or return ();
-  my @new = $self->result_class->inflate_result($self->result_source, @$info);
-  @new = $self->{_attrs}{record_filter}->(@new)
-    if exists $self->{_attrs}{record_filter};
-  return @new;
-}
+  return shift(@{$self->{stashed_objects}}) if @{ $self->{stashed_objects}||[] };
 
-sub _collapse_result {
-  my ($self, $as_proto, $row) = @_;
+  $self->{stashed_objects} = $self->_construct_objects
+    or return undef;
 
-  my @copy = @$row;
-
-  # 'foo'         => [ undef, 'foo' ]
-  # 'foo.bar'     => [ 'foo', 'bar' ]
-  # 'foo.bar.baz' => [ 'foo.bar', 'baz' ]
-
-  my @construct_as = map { [ (/^(?:(.*)\.)?([^.]+)$/) ] } @$as_proto;
-
-  my %collapse = %{$self->{_attrs}{collapse}||{}};
-
-  my @pri_index;
-
-  # if we're doing collapsing (has_many prefetch) we need to grab records
-  # until the PK changes, so fill @pri_index. if not, we leave it empty so
-  # we know we don't have to bother.
-
-  # the reason for not using the collapse stuff directly is because if you
-  # had for e.g. two artists in a row with no cds, the collapse info for
-  # both would be NULL (undef) so you'd lose the second artist
+  return shift @{$self->{stashed_objects}};
+}
 
-  # store just the index so we can check the array positions from the row
-  # without having to contruct the full hash
+# takes a single DBI-row of data and coinstructs as many objects
+# as the resultset attributes call for.
+# This can be a bit of an action at a distance - it takes as an argument
+# the *current* cursor-row (already taken off the $sth), but if
+# collapsing is requested it will keep advancing the cursor either
+# until the current row-object is assembled (the collapser was able to
+# order the result sensibly) OR until the cursor is exhausted (an
+# unordered collapsing resultset effectively triggers ->all)
+sub _construct_objects {
+  my ($self, $fetched_row, $fetch_all) = @_;
 
-  if (keys %collapse) {
-    my %pri = map { ($_ => 1) } $self->result_source->_pri_cols;
-    foreach my $i (0 .. $#construct_as) {
-      next if defined($construct_as[$i][0]); # only self table
-      if (delete $pri{$construct_as[$i][1]}) {
-        push(@pri_index, $i);
-      }
-      last unless keys %pri; # short circuit (Johnny Five Is Alive!)
-    }
+  my $attrs = $self->_resolved_attrs;
+  my $unordered = 0;  # will deal with this later
+
+  # this will be used as both initial raw-row collector AND as a RV of
+  # _construct_objects. Not regrowing the   # array twice matters a lot...
+  # a suprising amount actually
+  my $rows;
+
+  # $fetch_all implies all() which means all stashes have been cleared
+  # and the cursor reset
+  if ($fetch_all) {
+    # FIXME - we can do better, cursor->all (well a diff. method) should return a ref
+    $rows = [ $self->cursor->all ];
+  }
+  elsif ($unordered) {
+    $rows = [
+      $fetched_row||(),
+      @{ delete $self->{stashed_rows} || []},
+      $self->cursor->all,
+    ];
+  }
+  else {  # simple single object
+    $rows = [ $fetched_row || ( @{$self->{stashed_rows}||[]} ? shift @{$self->{stashed_rows}} : [$self->cursor->next] ) ];
   }
 
-  # no need to do an if, it'll be empty if @pri_index is empty anyway
-
-  my %pri_vals = map { ($_ => $copy[$_]) } @pri_index;
-
-  my @const_rows;
-
-  do { # no need to check anything at the front, we always want the first row
-
-    my %const;
+  return undef unless @{$rows->[0]||[]};
 
-    foreach my $this_as (@construct_as) {
-      $const{$this_as->[0]||''}{$this_as->[1]} = shift(@copy);
+  my $rsrc = $self->result_source;
+  my $res_class = $self->result_class;
+  my $inflator = $res_class->can ('inflate_result')
+    or $self->throw_exception("Inflator $res_class does not provide an inflate_result() method");
+
+  # construct a much simpler array->hash folder for the one-table cases right here
+  if ($attrs->{_single_object_inflation} and ! $attrs->{collapse}) {
+    # FIXME SUBOPTIMAL this is a very very very hot spot
+    # while rather optimal we can *still* do much better, by
+    # building a smarter [Row|HRI]::inflate_result(), and
+    # switch to feeding it data via a much leaner interface
+    #
+    my $infmap = $attrs->{as};
+    my @as_idx = 0..$#$infmap;
+    for my $r (@$rows) {
+      $r = [{ map { $infmap->[$_] => $r->[$_] } @as_idx }]
     }
 
-    push(@const_rows, \%const);
-
-  } until ( # no pri_index => no collapse => drop straight out
-      !@pri_index
-    or
-      do { # get another row, stash it, drop out if different PK
-
-        @copy = $self->cursor->next;
-        $self->{stashed_row} = \@copy;
-
-        # last thing in do block, counts as true if anything doesn't match
-
-        # check xor defined first for NULL vs. NOT NULL then if one is
-        # defined the other must be so check string equality
-
-        grep {
-          (defined $pri_vals{$_} ^ defined $copy[$_])
-          || (defined $pri_vals{$_} && ($pri_vals{$_} ne $copy[$_]))
-        } @pri_index;
-      }
-  );
+    # FIXME - this seems to be faster than the hashmapper above, especially
+    # on more rows, but need a better bench-environment to confirm
+    #eval sprintf (
+    #  '$_ = [{ %s }] for @$rows',
+    #  join (', ', map { "\$infmap->[$_] => \$_->[$_]" } 0..$#$infmap )
+    #);
+  }
+  else {
+    push @$rows, @{$self->{stashed_rows}||[]};
 
-  my $alias = $self->{attrs}{alias};
-  my $info = [];
+    my $perl = $rsrc->_mk_row_parser({
+      inflate_map => $attrs->{as},
+      selection => $attrs->{select},
+      collapse => $attrs->{collapse},
+      unordered => $unordered,
+    });
 
-  my %collapse_pos;
+    (eval "sub { no warnings; no strict; $perl }")->( # disable of strictures seems to have some effect, weird
+      $rows,  # modify in-place, shrinking/extending as necessary
+      ($attrs->{collapse} and ! $fetch_all and ! $unordered)
+        ? (
+            sub { my @r = $self->cursor->next or return undef; \@r },
+            ($self->{stashed_rows} = []), # this is where we empty things and prepare for leftovers
+          )
+        : ()
+      ,
+    );
+  }
 
-  my @const_keys;
+  $_ = $res_class->$inflator($rsrc, @$_) for @$rows;
 
-  foreach my $const (@const_rows) {
-    scalar @const_keys or do {
-      @const_keys = sort { length($a) <=> length($b) } keys %$const;
-    };
-    foreach my $key (@const_keys) {
-      if (length $key) {
-        my $target = $info;
-        my @parts = split(/\./, $key);
-        my $cur = '';
-        my $data = $const->{$key};
-        foreach my $p (@parts) {
-          $target = $target->[1]->{$p} ||= [];
-          $cur .= ".${p}";
-          if ($cur eq ".${key}" && (my @ckey = @{$collapse{$cur}||[]})) {
-            # collapsing at this point and on final part
-            my $pos = $collapse_pos{$cur};
-            CK: foreach my $ck (@ckey) {
-              if (!defined $pos->{$ck} || $pos->{$ck} ne $data->{$ck}) {
-                $collapse_pos{$cur} = $data;
-                delete @collapse_pos{ # clear all positioning for sub-entries
-                  grep { m/^\Q${cur}.\E/ } keys %collapse_pos
-                };
-                push(@$target, []);
-                last CK;
-              }
-            }
-          }
-          if (exists $collapse{$cur}) {
-            $target = $target->[-1];
-          }
-        }
-        $target->[0] = $data;
-      } else {
-        $info->[0] = $const->{$key};
-      }
-    }
+  # CDBI compat stuff
+  if ($attrs->{record_filter}) {
+    $_ = $attrs->{record_filter}->($_) for @$rows;
   }
 
-  return $info;
+  return $rows;
 }
 
 =head2 result_source
@@ -1543,7 +1499,7 @@ sub _count_subq_rs {
 
   # if we multi-prefetch we group_by something unique, as this is what we would
   # get out of the rs via ->next/->all. We *DO WANT* to clobber old group_by regardless
-  if ( keys %{$attrs->{collapse}}  ) {
+  if ( $attrs->{collapse}  ) {
     $sub_attrs->{group_by} = [ map { "$attrs->{alias}.$_" } @{
       $rsrc->_identifying_column_set || $self->throw_exception(
         'Unable to construct a unique group_by criteria properly collapsing the '
@@ -1660,33 +1616,23 @@ Returns all elements in the resultset.
 sub all {
   my $self = shift;
   if(@_) {
-      $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()");
+    $self->throw_exception("all() doesn't take any arguments, you probably wanted ->search(...)->all()");
   }
 
-  return @{ $self->get_cache } if $self->get_cache;
-
-  my @obj;
-
-  if (keys %{$self->_resolved_attrs->{collapse}}) {
-    # Using $self->cursor->all is really just an optimisation.
-    # If we're collapsing has_many prefetches it probably makes
-    # very little difference, and this is cleaner than hacking
-    # _construct_object to survive the approach
-    $self->cursor->reset;
-    my @row = $self->cursor->next;
-    while (@row) {
-      push(@obj, $self->_construct_object(@row));
-      @row = (exists $self->{stashed_row}
-               ? @{delete $self->{stashed_row}}
-               : $self->cursor->next);
-    }
-  } else {
-    @obj = map { $self->_construct_object(@$_) } $self->cursor->all;
+  delete $self->{stashed_rows};
+  delete $self->{stashed_objects};
+
+  if (my $c = $self->get_cache) {
+    return @$c;
   }
 
-  $self->set_cache(\@obj) if $self->{attrs}{cache};
+  $self->cursor->reset;
+
+  my $objs = $self->_construct_objects(undef, 'fetch_all') || [];
+
+  $self->set_cache($objs) if $self->{attrs}{cache};
 
-  return @obj;
+  return @$objs;
 }
 
 =head2 reset
@@ -1707,7 +1653,10 @@ another query.
 
 sub reset {
   my ($self) = @_;
-  delete $self->{_attrs} if exists $self->{_attrs};
+  delete $self->{_attrs};
+  delete $self->{stashed_rows};
+  delete $self->{stashed_objects};
+
   $self->{all_cache_position} = 0;
   $self->cursor->reset;
   return $self;
@@ -1810,7 +1759,7 @@ sub _rs_update_delete {
   my $existing_group_by = delete $attrs->{group_by};
 
   # make a new $rs selecting only the PKs (that's all we really need for the subq)
-  delete $attrs->{$_} for qw/collapse _collapse_order_by select _prefetch_selector_range as/;
+  delete $attrs->{$_} for qw/collapse select _prefetch_selector_range as/;
   $attrs->{columns} = [ map { "$attrs->{alias}.$_" } @$idcols ];
   $attrs->{group_by} = \ '';  # FIXME - this is an evil hack, it causes the optimiser to kick in and throw away the LEFT joins
   my $subrs = (ref $self)->new($rsrc, $attrs);
@@ -3038,7 +2987,7 @@ sub related_resultset {
 
     if (my $cache = $self->get_cache) {
       if ($cache->[0] && $cache->[0]->related_resultset($rel)->get_cache) {
-        $new_cache = [ map { @{$_->related_resultset($rel)->get_cache} }
+        $new_cache = [ map { @{$_->related_resultset($rel)->get_cache||[]} }
                         @$cache ];
       }
     }
@@ -3098,9 +3047,9 @@ source alias of the current result set:
 
     my $me = $self->current_source_alias;
 
-    return $self->search(
+    return $self->search({
       "$me.modified" => $user->id,
-    );
+    });
   }
 
 =cut
@@ -3341,14 +3290,10 @@ sub _resolved_attrs {
     if $attrs->{select};
 
   # assume all unqualified selectors to apply to the current alias (legacy stuff)
-  for (@sel) {
-    $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_";
-  }
+  $_ = (ref $_ or $_ =~ /\./) ? $_ : "$alias.$_" for @sel;
 
-  # disqualify all $alias.col as-bits (collapser mandated)
-  for (@as) {
-    $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_;
-  }
+  # disqualify all $alias.col as-bits (inflate-map mandated)
+  $_ = ($_ =~ /^\Q$alias.\E(.+)$/) ? $1 : $_ for @as;
 
   # de-duplicate the result (remove *identical* select/as pairs)
   # and also die on duplicate {as} pointing to different {select}s
@@ -3435,15 +3380,17 @@ sub _resolved_attrs {
     }
   }
 
-  $attrs->{collapse} ||= {};
-  if ($attrs->{prefetch}) {
+  # generate selections based on the prefetch helper
+  my $prefetch;
+  $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} )
+    if defined $attrs->{prefetch};
+
+  if ($prefetch) {
 
     $self->throw_exception("Unable to prefetch, resultset contains an unnamed selector $attrs->{_dark_selector}{string}")
       if $attrs->{_dark_selector};
 
-    my $prefetch = $self->_merge_joinpref_attr( {}, delete $attrs->{prefetch} );
-
-    my $prefetch_ordering = [];
+    $attrs->{collapse} = 1;
 
     # this is a separate structure (we don't look in {from} directly)
     # as the resolver needs to shift things off the lists to work
@@ -3466,8 +3413,7 @@ sub _resolved_attrs {
       }
     }
 
-    my @prefetch =
-      $source->_resolve_prefetch( $prefetch, $alias, $join_map, $prefetch_ordering, $attrs->{collapse} );
+    my @prefetch = $source->_resolve_prefetch( $prefetch, $alias, $join_map );
 
     # we need to somehow mark which columns came from prefetch
     if (@prefetch) {
@@ -3477,11 +3423,34 @@ sub _resolved_attrs {
 
     push @{ $attrs->{select} }, (map { $_->[0] } @prefetch);
     push @{ $attrs->{as} }, (map { $_->[1] } @prefetch);
+  }
+
+  # run through the resulting joinstructure (starting from our current slot)
+  # and unset collapse if proven unnesessary
+  if ($attrs->{collapse} && ref $attrs->{from} eq 'ARRAY') {
+
+    if (@{$attrs->{from}} > 1) {
 
-    push( @{$attrs->{order_by}}, @$prefetch_ordering );
-    $attrs->{_collapse_order_by} = \@$prefetch_ordering;
+      # find where our table-spec starts and consider only things after us
+      my @fromlist = @{$attrs->{from}};
+      while (@fromlist) {
+        my $t = shift @fromlist;
+        $t = $t->[0] if ref $t eq 'ARRAY';  #me vs join from-spec mismatch
+        last if ($t->{-alias} && $t->{-alias} eq $alias);
+      }
+
+      for (@fromlist) {
+        $attrs->{collapse} = ! $_->[0]{-is_single}
+          and last;
+      }
+    }
+    else {
+      # no joins - no collapse
+      $attrs->{collapse} = 0;
+    }
   }
 
+  $attrs->{_single_object_inflation} = ! List::Util::first { $_ =~ /\./ } @{$attrs->{as}};
 
   # if both page and offset are specified, produce a combined offset
   # even though it doesn't make much sense, this is what pre 081xx has
@@ -4231,6 +4200,24 @@ rows per page if the page attribute or method is used.
 Specifies the (zero-based) row number for the  first row to be returned, or the
 of the first row of the first page if paging is used.
 
+=head2 software_limit
+
+=over 4
+
+=item Value: (0 | 1)
+
+=back
+
+When combined with L</rows> and/or L</offset> the generated SQL will not
+include any limit dialect stanzas. Instead the entire result will be selected
+as if no limits were specified, and DBIC will perform the limit locally, by
+artificially advancing and finishing the resulting L</cursor>.
+
+This is the recommended way of performing resultset limiting when no sane RDBMS
+implementation is available (e.g.
+L<Sybase ASE|DBIx::Class::Storage::DBI::Sybase::ASE> using the
+L<Generic Sub Query|DBIx::Class::SQLMaker::LimitDialects/GenericSubQ> hack)
+
 =head2 group_by
 
 =over 4