X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSet.pm;h=ac74e0fbc95912033bb88e0d80f39da409b757c0;hb=c40f97742c724386cf5888497c6fcc73a48c576a;hp=900355c20e9639fb29b267ee85e1eb1b433623fc;hpb=45eeb990ab0d8e4b23163a8e735f69ce22b0e6d1;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 900355c..ac74e0f 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -8,6 +8,7 @@ use DBIx::Class::Exception;
 use DBIx::Class::ResultSetColumn;
 use Scalar::Util qw/blessed weaken/;
 use Try::Tiny;
+use Data::Compare (); # no imports!!! guard against insane architecture
 
 # not importing first() as it will clash with our own method
 use List::Util ();
@@ -73,6 +74,34 @@ However, if it is used in a boolean context it is B<always> true.  So if
 you want to check if a resultset has any results, you must use C<if $rs
 != 0>.
 
+=head1 CUSTOM ResultSet CLASSES THAT USE Moose
+
+If you want to make your custom ResultSet classes with L<Moose>, use a template
+similar to:
+
+    package MyApp::Schema::ResultSet::User;
+
+    use Moose;
+    use namespace::autoclean;
+    use MooseX::NonMoose;
+    extends 'DBIx::Class::ResultSet';
+
+    sub BUILDARGS { $_[2] }
+
+    ...your code...
+
+    __PACKAGE__->meta->make_immutable;
+
+    1;
+
+The L<MooseX::NonMoose> is necessary so that the L<Moose> constructor does not
+clash with the regular ResultSet constructor. Alternatively, you can use:
+
+    __PACKAGE__->meta->make_immutable(inline_constructor => 0);
+
+The L<BUILDARGS|Moose::Manual::Construction/BUILDARGS> is necessary because the
+signature of the ResultSet C<new> is C<< ->new($source, \%args) >>.
+
 =head1 EXAMPLES
 
 =head2 Chaining resultsets
@@ -445,7 +474,7 @@ sub _normalize_selection {
   $attrs->{'+columns'} = $self->_merge_attr($attrs->{'+columns'}, delete $attrs->{include_columns})
     if exists $attrs->{include_columns};
 
-  # columns are always placed first, however 
+  # columns are always placed first, however
 
   # Keep the X vs +X separation until _resolved_attrs time - this allows to
   # delay the decision on whether to use a default select list ($rsrc->columns)
@@ -529,17 +558,61 @@ sub _normalize_selection {
 
 sub _stack_cond {
   my ($self, $left, $right) = @_;
+
+  # collapse single element top-level conditions
+  # (single pass only, unlikely to need recursion)
+  for ($left, $right) {
+    if (ref $_ eq 'ARRAY') {
+      if (@$_ == 0) {
+        $_ = undef;
+      }
+      elsif (@$_ == 1) {
+        $_ = $_->[0];
+      }
+    }
+    elsif (ref $_ eq 'HASH') {
+      my ($first, $more) = keys %$_;
+
+      # empty hash
+      if (! defined $first) {
+        $_ = undef;
+      }
+      # one element hash
+      elsif (! defined $more) {
+        if ($first eq '-and' and ref $_->{'-and'} eq 'HASH') {
+          $_ = $_->{'-and'};
+        }
+        elsif ($first eq '-or' and ref $_->{'-or'} eq 'ARRAY') {
+          $_ = $_->{'-or'};
+        }
+      }
+    }
+  }
+
+  # merge hashes with weeding out of duplicates (simple cases only)
+  if (ref $left eq 'HASH' and ref $right eq 'HASH') {
+
+    # shallow copy to destroy
+    $right = { %$right };
+    for (grep { exists $right->{$_} } keys %$left) {
+      # the use of eq_deeply here is justified - the rhs of an
+      # expression can contain a lot of twisted weird stuff
+      delete $right->{$_} if Data::Compare::Compare( $left->{$_}, $right->{$_} );
+    }
+
+    $right = undef unless keys %$right;
+  }
+
+
   if (defined $left xor defined $right) {
     return defined $left ? $left : $right;
   }
-  elsif (defined $left) {
-    return { -and => [ map
-      { ref $_ eq 'ARRAY' ? [ -or => $_ ] : $_ }
-      ($left, $right)
-    ]};
+  elsif (! defined $left) {
+    return undef;
+  }
+  else {
+    return { -and => [ $left, $right ] };
   }
-
-  return undef;
 }
 
 =head2 search_literal
@@ -657,22 +730,33 @@ sub find {
 
   my $rsrc = $self->result_source;
 
+  my $constraint_name;
+  if (exists $attrs->{key}) {
+    $constraint_name = defined $attrs->{key}
+      ? $attrs->{key}
+      : $self->throw_exception("An undefined 'key' resultset attribute makes no sense")
+    ;
+  }
+
   # Parse out the condition from input
   my $call_cond;
+
   if (ref $_[0] eq 'HASH') {
     $call_cond = { %{$_[0]} };
   }
   else {
-    my $constraint = exists $attrs->{key} ? $attrs->{key} : 'primary';
-    my @c_cols = $rsrc->unique_constraint_columns($constraint);
+    # if only values are supplied we need to default to 'primary'
+    $constraint_name = 'primary' unless defined $constraint_name;
+
+    my @c_cols = $rsrc->unique_constraint_columns($constraint_name);
 
     $self->throw_exception(
-      "No constraint columns, maybe a malformed '$constraint' constraint?"
+      "No constraint columns, maybe a malformed '$constraint_name' constraint?"
     ) unless @c_cols;
 
     $self->throw_exception (
       'find() expects either a column/value hashref, or a list of values '
-    . "corresponding to the columns of the specified unique constraint '$constraint'"
+    . "corresponding to the columns of the specified unique constraint '$constraint_name'"
     ) unless @c_cols == @_;
 
     $call_cond = {};
@@ -703,11 +787,11 @@ sub find {
 
   my $alias = exists $attrs->{alias} ? $attrs->{alias} : $self->{attrs}{alias};
   my $final_cond;
-  if (exists $attrs->{key}) {
+  if (defined $constraint_name) {
     $final_cond = $self->_qualify_cond_columns (
 
       $self->_build_unique_cond (
-        $attrs->{key},
+        $constraint_name,
         $call_cond,
       ),
 
@@ -1785,7 +1869,7 @@ sub update_all {
     unless ref $values eq 'HASH';
 
   my $guard = $self->result_source->schema->txn_scope_guard;
-  $_->update($values) for $self->all;
+  $_->update({%$values}) for $self->all;  # shallow copy - update will mangle it
   $guard->commit;
   return 1;
 }
@@ -1927,13 +2011,15 @@ sub populate {
   # cruft placed in standalone method
   my $data = $self->_normalize_populate_args(@_);
 
+  return unless @$data;
+
   if(defined wantarray) {
     my @created;
     foreach my $item (@$data) {
       push(@created, $self->create($item));
     }
     return wantarray ? @created : \@created;
-  } 
+  }
   else {
     my $first = $data->[0];
 
@@ -2031,7 +2117,10 @@ sub _normalize_populate_args {
   my ($self, $arg) = @_;
 
   if (ref $arg eq 'ARRAY') {
-    if (ref $arg->[0] eq 'HASH') {
+    if (!@$arg) {
+      return [];
+    }
+    elsif (ref $arg->[0] eq 'HASH') {
       return $arg;
     }
     elsif (ref $arg->[0] eq 'ARRAY') {
@@ -2065,107 +2154,6 @@ C<total_entries> on the L<Data::Page> object.
 
 =cut
 
-# make a wizard good for both a scalar and a hashref
-my $mk_lazy_count_wizard = sub {
-  require Variable::Magic;
-
-  my $stash = { total_rs => shift };
-  my $slot = shift; # only used by the hashref magic
-
-  my $magic = Variable::Magic::wizard (
-    data => sub { $stash },
-
-    (!$slot)
-    ? (
-      # the scalar magic
-      get => sub {
-        # set value lazily, and dispell for good
-        ${$_[0]} = $_[1]{total_rs}->count;
-        Variable::Magic::dispell (${$_[0]}, $_[1]{magic_selfref});
-        return 1;
-      },
-      set => sub {
-        # an explicit set implies dispell as well
-        # the unless() is to work around "fun and giggles" below
-        Variable::Magic::dispell (${$_[0]}, $_[1]{magic_selfref})
-          unless (caller(2))[3] eq 'DBIx::Class::ResultSet::pager';
-        return 1;
-      },
-    )
-    : (
-      # the uvar magic
-      fetch => sub {
-        if ($_[2] eq $slot and !$_[1]{inactive}) {
-          my $cnt = $_[1]{total_rs}->count;
-          $_[0]->{$slot} = $cnt;
-
-          # attempting to dispell in a fetch handle (works in store), seems
-          # to invariable segfault on 5.10, 5.12, 5.13 :(
-          # so use an inactivator instead
-          #Variable::Magic::dispell (%{$_[0]}, $_[1]{magic_selfref});
-          $_[1]{inactive}++;
-        }
-        return 1;
-      },
-      store => sub {
-        if (! $_[1]{inactive} and $_[2] eq $slot) {
-          #Variable::Magic::dispell (%{$_[0]}, $_[1]{magic_selfref});
-          $_[1]{inactive}++
-            unless (caller(2))[3] eq 'DBIx::Class::ResultSet::pager';
-        }
-        return 1;
-      },
-    ),
-  );
-
-  $stash->{magic_selfref} = $magic;
-  weaken ($stash->{magic_selfref}); # this fails on 5.8.1
-
-  return $magic;
-};
-
-# the tie class for 5.8.1
-{
-  package # hide from pause
-    DBIx::Class::__DBIC_LAZY_RS_COUNT__;
-  use base qw/Tie::Hash/;
-
-  sub FIRSTKEY { my $dummy = scalar keys %{$_[0]{data}}; each %{$_[0]{data}} }
-  sub NEXTKEY  { each %{$_[0]{data}} }
-  sub EXISTS   { exists $_[0]{data}{$_[1]} }
-  sub DELETE   { delete $_[0]{data}{$_[1]} }
-  sub CLEAR    { %{$_[0]{data}} = () }
-  sub SCALAR   { scalar %{$_[0]{data}} }
-
-  sub TIEHASH {
-    $_[1]{data} = {%{$_[1]{selfref}}};
-    %{$_[1]{selfref}} = ();
-    Scalar::Util::weaken ($_[1]{selfref});
-    return bless ($_[1], $_[0]);
-  };
-
-  sub FETCH {
-    if ($_[1] eq $_[0]{slot}) {
-      my $cnt = $_[0]{data}{$_[1]} = $_[0]{total_rs}->count;
-      untie %{$_[0]{selfref}};
-      %{$_[0]{selfref}} = %{$_[0]{data}};
-      return $cnt;
-    }
-    else {
-      $_[0]{data}{$_[1]};
-    }
-  }
-
-  sub STORE {
-    $_[0]{data}{$_[1]} = $_[2];
-    if ($_[1] eq $_[0]{slot}) {
-      untie %{$_[0]{selfref}};
-      %{$_[0]{selfref}} = %{$_[0]{data}};
-    }
-    $_[2];
-  }
-}
-
 sub pager {
   my ($self) = @_;
 
@@ -2184,70 +2172,15 @@ sub pager {
   # with a subselect) to get the real total count
   my $count_attrs = { %$attrs };
   delete $count_attrs->{$_} for qw/rows offset page pager/;
-  my $total_rs = (ref $self)->new($self->result_source, $count_attrs);
 
+  my $total_rs = (ref $self)->new($self->result_source, $count_attrs);
 
-### the following may seem awkward and dirty, but it's a thought-experiment
-### necessary for future development of DBIx::DS. Do *NOT* change this code
-### before talking to ribasushi/mst
-
-  require Data::Page;
-  my $pager = Data::Page->new(
-    0,  #start with an empty set
+  require DBIx::Class::ResultSet::Pager;
+  return $self->{pager} = DBIx::Class::ResultSet::Pager->new(
+    sub { $total_rs->count },  #lazy-get the total
     $attrs->{rows},
     $self->{attrs}{page},
   );
-
-  my $data_slot = 'total_entries';
-
-  # Since we are interested in a cached value (once it's set - it's set), every
-  # technique will detach from the magic-host once the time comes to fire the
-  # ->count (or in the segfaulting case of >= 5.10 it will deactivate itself)
-
-  if ($] < 5.008003) {
-    # 5.8.1 throws 'Modification of a read-only value attempted' when one tries
-    # to weakref the magic container :(
-    # tested on 5.8.1
-    tie (%$pager, 'DBIx::Class::__DBIC_LAZY_RS_COUNT__',
-      { slot => $data_slot, total_rs => $total_rs, selfref => $pager }
-    );
-  }
-  elsif ($] < 5.010) {
-    # We can use magic on the hash value slot. It's interesting that the magic is
-    # attached to the hash-slot, and does *not* stop working once I do the dummy
-    # assignments after the cast()
-    # tested on 5.8.3 and 5.8.9
-    my $magic = $mk_lazy_count_wizard->($total_rs);
-    Variable::Magic::cast ( $pager->{$data_slot}, $magic );
-
-    # this is for fun and giggles
-    $pager->{$data_slot} = -1;
-    $pager->{$data_slot} = 0;
-
-    # this does not work for scalars, but works with
-    # uvar magic below
-    #my %vals = %$pager;
-    #%$pager = ();
-    #%{$pager} = %vals;
-  }
-  else {
-    # And the uvar magic
-    # works on 5.10.1, 5.12.1 and 5.13.4 in its current form,
-    # however see the wizard maker for more notes
-    my $magic = $mk_lazy_count_wizard->($total_rs, $data_slot);
-    Variable::Magic::cast ( %$pager, $magic );
-
-    # still works
-    $pager->{$data_slot} = -1;
-    $pager->{$data_slot} = 0;
-
-    # this now works
-    my %vals = %$pager;
-    %$pager = ();
-    %{$pager} = %vals;
-  }
-
-  return $self->{pager} = $pager;
 }
 
 =head2 page
@@ -2815,7 +2748,7 @@ supplied by the database (e.g. an auto_increment primary key column).
 In normal usage, the value of such columns should NOT be included at
 all in the call to C<update_or_new>, even when set to C<undef>.
 
-See also L</find>, L</find_or_create> and L</find_or_new>. 
+See also L</find>, L</find_or_create> and L</find_or_new>.
 
 =cut
 
@@ -3535,6 +3468,7 @@ sub _merge_joinpref_attr {
       $position++;
     }
     my ($import_key) = ( ref $import_element eq 'HASH' ) ? keys %{$import_element} : ($import_element);
+    $import_key = '' if not defined $import_key;
 
     if ($best_candidate->{score} == 0 || exists $seen_keys->{$import_key}) {
       push( @{$orig}, $import_element );
@@ -3649,6 +3583,11 @@ sub STORABLE_freeze {
   # A cursor in progress can't be serialized (and would make little sense anyway)
   delete $to_serialize->{cursor};
 
+  # nor is it sensical to store a not-yet-fired-count pager
+  if ($to_serialize->{pager} and ref $to_serialize->{pager}{total_entries} eq 'CODE') {
+    delete $to_serialize->{pager};
+  }
+
   Storable::nfreeze($to_serialize);
 }