X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=da9dcedfd32a4eb903cb906460a1101ee0c8ef41;hb=f183eccd611133789a4f03bafde6a7e8979b26ff;hp=328b7061c1a4fe1753f6f2039fd8536b1a502f77;hpb=1c258fc1b3bc48e162b6b05e325625d6a75cb217;p=dbsrgits%2FDBIx-Class-Historic.git

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 328b706..da9dced 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -8,6 +8,7 @@ use overload
         fallback => 1;
 use Data::Page;
 use Storable;
+use Scalar::Util qw/weaken/;
 
 use base qw/DBIx::Class/;
 __PACKAGE__->load_components(qw/AccessorGroup/);
@@ -71,8 +72,9 @@ sub new {
   return $class->new_result(@_) if ref $class;
   
   my ($source, $attrs) = @_;
-  #use Data::Dumper; warn Dumper($attrs);
+  weaken $source;
   $attrs = Storable::dclone($attrs || {}); # { %{ $attrs || {} } };
+  #use Data::Dumper; warn Dumper($attrs);
   my $alias = ($attrs->{alias} ||= 'me');
   
   $attrs->{columns} ||= delete $attrs->{cols} if $attrs->{cols};
@@ -83,7 +85,7 @@ sub new {
   $attrs->{as} ||= [ map { m/^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$attrs->{select}} ];
   if (my $include = delete $attrs->{include_columns}) {
     push(@{$attrs->{select}}, @$include);
-    push(@{$attrs->{as}}, map { m/([^\.]+)$/; $1; } @$include);
+    push(@{$attrs->{as}}, map { m/([^.]+)$/; $1; } @$include);
   }
   #use Data::Dumper; warn Dumper(@{$attrs}{qw/select as/});
 
@@ -168,9 +170,7 @@ sub search {
     
     my $attrs = { %{$self->{attrs}} };
     my $having = delete $attrs->{having};
-    if (@_ > 1 && ref $_[$#_] eq 'HASH') {
-     $attrs = { %$attrs, %{ pop(@_) } };
-    }
+    $attrs = { %$attrs, %{ pop(@_) } } if @_ > 1 and ref $_[$#_] eq 'HASH';
 
     my $where = (@_
                   ? ((@_ == 1 || ref $_[0] eq "HASH")
@@ -181,28 +181,26 @@ sub search {
                           : {@_}))
                   : undef());
     if (defined $where) {
-      $where = (defined $attrs->{where}
+      $attrs->{where} = (defined $attrs->{where}
                 ? { '-and' =>
                     [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
                         $where, $attrs->{where} ] }
                 : $where);
-      $attrs->{where} = $where;
     }
 
     if (defined $having) {
-      $having = (defined $attrs->{having}
+      $attrs->{having} = (defined $attrs->{having}
                 ? { '-and' =>
                     [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
                         $having, $attrs->{having} ] }
                 : $having);
-      $attrs->{having} = $having;
     }
 
     $rs = (ref $self)->new($self->result_source, $attrs);
   }
   else {
     $rs = $self;
-    $rs->reset();
+    $rs->reset;
   }
   return (wantarray ? $rs->all : $rs);
 }
@@ -254,7 +252,7 @@ sub find {
   my @cols = $self->result_source->primary_columns;
   if (exists $attrs->{key}) {
     my %uniq = $self->result_source->unique_constraints;
-    $self->( "Unknown key " . $attrs->{key} . " on " . $self->name )
+    $self->throw_exception( "Unknown key $attrs->{key} on '" . $self->result_source->name . "'" )
       unless exists $uniq{$attrs->{key}};
     @cols = @{ $uniq{$attrs->{key}} };
   }
@@ -271,9 +269,8 @@ sub find {
   } else {
     $query = {@vals};
   }
-  foreach (keys %$query) {
-    next if m/\./;
-    $query->{$self->{attrs}{alias}.'.'.$_} = delete $query->{$_};
+  foreach my $key (grep { ! m/\./ } keys %$query) {
+    $query->{"$self->{attrs}{alias}.$key"} = delete $query->{$key};
   }
   #warn Dumper($query);
   
@@ -306,8 +303,7 @@ Returns a storage-driven cursor to the given resultset.
 
 sub cursor {
   my ($self) = @_;
-  my ($attrs) = $self->{attrs};
-  $attrs = { %$attrs };
+  my $attrs = { %{$self->{attrs}} };
   return $self->{cursor}
     ||= $self->result_source->storage->select($self->{from}, $attrs->{select},
           $attrs->{where},$attrs);
@@ -320,18 +316,17 @@ Inflates the first result without creating a cursor
 =cut
 
 sub single {
-  my ($self, $extra) = @_;
-  my ($attrs) = $self->{attrs};
-  $attrs = { %$attrs };
-  if ($extra) {
+  my ($self, $where) = @_;
+  my $attrs = { %{$self->{attrs}} };
+  if ($where) {
     if (defined $attrs->{where}) {
       $attrs->{where} = {
-        '-and'
-          => [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
-               delete $attrs->{where}, $extra ]
+        '-and' => 
+            [ map { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
+               $where, delete $attrs->{where} ]
       };
     } else {
-      $attrs->{where} = $extra;
+      $attrs->{where} = $where;
     }
   }
   my @data = $self->result_source->storage->select_single(
@@ -352,12 +347,9 @@ For more information, see L<DBIx::Class::Manual::Cookbook>.
 =cut
 
 sub search_like {
-  my $class    = shift;
-  my $attrs = { };
-  if (@_ > 1 && ref $_[$#_] eq 'HASH') {
-    $attrs = pop(@_);
-  }
-  my $query    = ref $_[0] eq "HASH" ? { %{shift()} }: {@_};
+  my $class = shift;
+  my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
+  my $query = ref $_[0] eq 'HASH' ? { %{shift()} }: {@_};
   $query->{$_} = { 'like' => $query->{$_} } for keys %$query;
   return $class->search($query, { %$attrs });
 }
@@ -395,12 +387,9 @@ Can be used to efficiently iterate over records in the resultset:
 
 sub next {
   my ($self) = @_;
-  my $cache;
-  if( @{$cache = $self->{all_cache} || []}) {
+  if (@{$self->{all_cache} || []}) {
     $self->{all_cache_position} ||= 0;
-    my $obj = $cache->[$self->{all_cache_position}];
-    $self->{all_cache_position}++;
-    return $obj;
+    return $self->{all_cache}->[$self->{all_cache_position}++];
   }
   if ($self->{attrs}{cache}) {
     $self->{all_cache_position} = 1;
@@ -417,14 +406,13 @@ sub next {
 sub _construct_object {
   my ($self, @row) = @_;
   my @as = @{ $self->{attrs}{as} };
-
+  
   my $info = $self->_collapse_result(\@as, \@row);
-
+  
   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;
 }
 
@@ -439,11 +427,11 @@ sub _collapse_result {
     if (defined $prefix) {
       if ($this_as =~ m/^\Q${prefix}.\E(.+)$/) {
         my $remain = $1;
-        $remain =~ /^(?:(.*)\.)?([^\.]+)$/;
+        $remain =~ /^(?:(.*)\.)?([^.]+)$/;
         $const{$1||''}{$2} = $val;
       }
     } else {
-      $this_as =~ /^(?:(.*)\.)?([^\.]+)$/;
+      $this_as =~ /^(?:(.*)\.)?([^.]+)$/;
       $const{$1||''}{$2} = $val;
     }
   }
@@ -487,7 +475,7 @@ sub _collapse_result {
       $tree = $self->_collapse_result($as, $row, $c_prefix);
       #warn Data::Dumper::Dumper($tree, $row);
     }
-    @{$target} = @final;
+    @$target = @final;
   }
 
   return $info;
@@ -516,46 +504,47 @@ clause.
 
 sub count {
   my $self = shift;
-  return $self->search(@_)->count if @_ && defined $_[0];
-  unless (defined $self->{count}) {
-    return scalar @{ $self->get_cache }
-      if @{ $self->get_cache };
-    my $group_by;
-    my $select = { 'count' => '*' };
-    my $attrs = { %{ $self->{attrs} } };
-    if( $group_by = delete $attrs->{group_by} ) {
-      delete $attrs->{having};
-      my @distinct = (ref $group_by ?  @$group_by : ($group_by));
-      # todo: try CONCAT for multi-column pk
-      my @pk = $self->result_source->primary_columns;
-      if( scalar(@pk) == 1 ) {
-        my $pk = shift(@pk);
-        my $alias = $attrs->{alias};
-        my $re = qr/^($alias\.)?$pk$/;
-        foreach my $column ( @distinct) {
-          if( $column =~ $re ) {
-            @distinct = ( $column );
-            last;
-          }
-        } 
-      }
+  return $self->search(@_)->count if @_ and defined $_[0];
+  return scalar @{ $self->get_cache } if @{ $self->get_cache };
 
-      $select = { count => { 'distinct' => \@distinct } };
-      #use Data::Dumper; die Dumper $select;
-    }
+  my $count = $self->_count;
+  return 0 unless $count;
 
-    $attrs->{select} = $select;
-    $attrs->{as} = [ 'count' ];
-    # offset, order by and page are not needed to count. record_filter is cdbi
-    delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/;
-        
-    ($self->{count}) = (ref $self)->new($self->result_source, $attrs)->cursor->next;
-  }
-  return 0 unless $self->{count};
-  my $count = $self->{count};
   $count -= $self->{attrs}{offset} if $self->{attrs}{offset};
   $count = $self->{attrs}{rows} if
-    ($self->{attrs}{rows} && $self->{attrs}{rows} < $count);
+    $self->{attrs}{rows} and $self->{attrs}{rows} < $count;
+  return $count;
+}
+
+sub _count { # Separated out so pager can get the full count
+  my $self = shift;
+  my $select = { count => '*' };
+  my $attrs = { %{ $self->{attrs} } };
+  if (my $group_by = delete $attrs->{group_by}) {
+    delete $attrs->{having};
+    my @distinct = (ref $group_by ?  @$group_by : ($group_by));
+    # todo: try CONCAT for multi-column pk
+    my @pk = $self->result_source->primary_columns;
+    if (@pk == 1) {
+      foreach my $column (@distinct) {
+        if ($column =~ qr/^(?:\Q$attrs->{alias}.\E)?$pk[0]$/) {
+          @distinct = ($column);
+          last;
+        }
+      } 
+    }
+
+    $select = { count => { distinct => \@distinct } };
+    #use Data::Dumper; die Dumper $select;
+  }
+
+  $attrs->{select} = $select;
+  $attrs->{as} = [qw/count/];
+
+  # offset, order by and page are not needed to count. record_filter is cdbi
+  delete $attrs->{$_} for qw/rows offset order_by page pager record_filter/;
+        
+  my ($count) = (ref $self)->new($self->result_source, $attrs)->cursor->next;
   return $count;
 }
 
@@ -576,8 +565,7 @@ is returned in list context.
 
 sub all {
   my ($self) = @_;
-  return @{ $self->get_cache }
-    if @{ $self->get_cache };
+  return @{ $self->get_cache } if @{ $self->get_cache };
 
   my @obj;
 
@@ -586,20 +574,19 @@ sub all {
       # 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
-    my @row;
     $self->cursor->reset;
-    while (@row = $self->cursor->next) {
+    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;
-  }
-
-  if( $self->{attrs}->{cache} ) {
-    $self->set_cache( \@obj );
+    @obj = map { $self->_construct_object(@$_) } $self->cursor->all;
   }
 
+  $self->set_cache(\@obj) if $self->{attrs}{cache};
   return @obj;
 }
 
@@ -668,26 +655,41 @@ Deletes the contents of the resultset from its result source.
 sub delete {
   my ($self) = @_;
   my $del = {};
-  $self->throw_exception("Can't delete on resultset with condition unless hash or array")
-    unless (ref($self->{cond}) eq 'HASH' || ref($self->{cond}) eq 'ARRAY');
-  if (ref $self->{cond} eq 'ARRAY') {
+
+  if (!ref($self->{cond})) {
+
+    # No-op. No condition, we're deleting everything
+
+  } elsif (ref $self->{cond} eq 'ARRAY') {
+
     $del = [ map { my %hash;
       foreach my $key (keys %{$_}) {
-        $key =~ /([^\.]+)$/;
+        $key =~ /([^.]+)$/;
         $hash{$1} = $_->{$key};
       }; \%hash; } @{$self->{cond}} ];
-  } elsif ((keys %{$self->{cond}})[0] eq '-and') {
-    $del->{-and} = [ map { my %hash;
-      foreach my $key (keys %{$_}) {
-        $key =~ /([^\.]+)$/;
-        $hash{$1} = $_->{$key};
-      }; \%hash; } @{$self->{cond}{-and}} ];
-  } else {
-    foreach my $key (keys %{$self->{cond}}) {
-      $key =~ /([^\.]+)$/;
-      $del->{$1} = $self->{cond}{$key};
+
+  } elsif (ref $self->{cond} eq 'HASH') {
+
+    if ((keys %{$self->{cond}})[0] eq '-and') {
+
+      $del->{-and} = [ map { my %hash;
+        foreach my $key (keys %{$_}) {
+          $key =~ /([^.]+)$/;
+          $hash{$1} = $_->{$key};
+        }; \%hash; } @{$self->{cond}{-and}} ];
+
+    } else {
+
+      foreach my $key (keys %{$self->{cond}}) {
+        $key =~ /([^.]+)$/;
+        $del->{$1} = $self->{cond}{$key};
+      }
     }
+  } else {
+    $self->throw_exception(
+      "Can't delete on resultset with condition unless hash or array");
   }
+
   $self->result_source->storage->delete($self->result_source->from, $del);
   return 1;
 }
@@ -717,9 +719,8 @@ sub pager {
   my $attrs = $self->{attrs};
   $self->throw_exception("Can't create pager for non-paged rs") unless $self->{page};
   $attrs->{rows} ||= 10;
-  $self->count;
   return $self->{pager} ||= Data::Page->new(
-    $self->{count}, $attrs->{rows}, $self->{page});
+    $self->_count, $attrs->{rows}, $self->{page});
 }
 
 =head2 page
@@ -754,11 +755,11 @@ sub new_result {
   my %new = %$values;
   my $alias = $self->{attrs}{alias};
   foreach my $key (keys %{$self->{cond}||{}}) {
-    $new{$1} = $self->{cond}{$key} if ($key =~ m/^(?:$alias\.)?([^\.]+)$/);
+    $new{$1} = $self->{cond}{$key} if ($key =~ m/^(?:\Q${alias}.\E)?([^.]+)$/);
   }
   my $obj = $self->result_class->new(\%new);
   $obj->result_source($self->result_source) if $obj->can('result_source');
-  $obj;
+  return $obj;
 }
 
 =head2 create
@@ -811,9 +812,9 @@ See also L</find> and L</update_or_create>.
 sub find_or_create {
   my $self     = shift;
   my $attrs    = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
-  my $hash     = ref $_[0] eq "HASH" ? shift : {@_};
+  my $hash     = ref $_[0] eq 'HASH' ? shift : {@_};
   my $exists   = $self->find($hash, $attrs);
-  return defined($exists) ? $exists : $self->create($hash);
+  return defined $exists ? $exists : $self->create($hash);
 }
 
 =head2 update_or_create
@@ -849,9 +850,8 @@ See also L</find> and L</find_or_create>.
 
 sub update_or_create {
   my $self = shift;
-
   my $attrs = (@_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {});
-  my $hash  = ref $_[0] eq "HASH" ? shift : {@_};
+  my $hash = ref $_[0] eq 'HASH' ? shift : {@_};
 
   my %unique_constraints = $self->result_source->unique_constraints;
   my @constraint_names   = (exists $attrs->{key}
@@ -870,20 +870,16 @@ sub update_or_create {
       if (scalar keys %unique_hash == scalar @unique_cols);
   }
 
-  my $row;
   if (@unique_hashes) {
-    $row = $self->search(\@unique_hashes, { rows => 1 })->first;
-    if ($row) {
+    my $row = $self->single(\@unique_hashes);
+    if (defined $row) {
       $row->set_columns($hash);
       $row->update;
+      return $row;
     }
   }
 
-  unless ($row) {
-    $row = $self->create($hash);
-  }
-
-  return $row;
+  return $self->create($hash);
 }
 
 =head2 get_cache
@@ -893,8 +889,7 @@ Gets the contents of the cache for the resultset.
 =cut
 
 sub get_cache {
-  my $self = shift;
-  return $self->{all_cache} || [];
+  shift->{all_cache} || [];
 }
 
 =head2 set_cache
@@ -922,8 +917,7 @@ Clears the cache for the resultset.
 =cut
 
 sub clear_cache {
-  my $self = shift;
-  $self->set_cache([]);
+  shift->set_cache([]);
 }
 
 =head2 related_resultset
@@ -937,36 +931,28 @@ Returns a related resultset for the supplied relationship name.
 sub related_resultset {
   my ( $self, $rel, @rest ) = @_;
   $self->{related_resultsets} ||= {};
-  my $resultsets = $self->{related_resultsets};
-  if( !exists $resultsets->{$rel} ) {
-    #warn "fetching related resultset for rel '$rel'";
-    my $rel_obj = $self->result_source->relationship_info($rel);
-    $self->throw_exception(
-      "search_related: result source '" . $self->result_source->name .
-      "' has no such relationship ${rel}")
-      unless $rel_obj; #die Dumper $self->{attrs};
-    my $rs = $self->search(undef, { join => $rel });
-    #if( $self->{attrs}->{cache} ) {
-    #  $rs = $self->search(undef);
-    #}
-    #else {
-    #}
-    #use Data::Dumper; die Dumper $rs->{attrs};#$rs = $self->search( undef );
-    #use Data::Dumper; warn Dumper $self->{attrs}, Dumper $rs->{attrs};
-    my $alias = (defined $rs->{attrs}{seen_join}{$rel}
-                  && $rs->{attrs}{seen_join}{$rel} > 1
-                ? join('_', $rel, $rs->{attrs}{seen_join}{$rel})
-                : $rel);
-    $resultsets->{$rel} =
+  return $self->{related_resultsets}{$rel} ||= do {
+      #warn "fetching related resultset for rel '$rel'";
+      my $rel_obj = $self->result_source->relationship_info($rel);
+      $self->throw_exception(
+        "search_related: result source '" . $self->result_source->name .
+        "' has no such relationship ${rel}")
+        unless $rel_obj; #die Dumper $self->{attrs};
+
+      my $rs = $self->search(undef, { join => $rel });
+      my $alias = defined $rs->{attrs}{seen_join}{$rel}
+                    && $rs->{attrs}{seen_join}{$rel} > 1
+                  ? join('_', $rel, $rs->{attrs}{seen_join}{$rel})
+                  : $rel;
+
       $self->result_source->schema->resultset($rel_obj->{class}
            )->search( undef,
              { %{$rs->{attrs}},
                alias => $alias,
-               select => undef(),
-               as => undef() }
-           )->search(@rest);
-  }
-  return $resultsets->{$rel};
+               select => undef,
+               as => undef }
+           )->search(@rest);      
+  };
 }
 
 =head2 throw_exception