Reduce warnings introduced in 450e6dbf to one per callsite

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSet.pm

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index b0a1550..7b659ef 100644 (file)
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -271,15 +271,22 @@ sub search {
   my $self = shift;
   my $rs = $self->search_rs( @_ );
 
-  my $want = wantarray;
-  if ($want) {
+  if (wantarray) {
     return $rs->all;
   }
-  elsif (defined $want) {
+  elsif (defined wantarray) {
     return $rs;
   }
   else {
-    $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense');
+    # we can be called by a relationship helper, which in
+    # turn may be called in void context due to some braindead
+    # overload or whatever else the user decided to be clever
+    # at this particular day. Thus limit the exception to
+    # external code calls only
+    $self->throw_exception ('->search is *not* a mutator, calling it in void context makes no sense')
+      if (caller)[0] !~ /^\QDBIx::Class::/;
+
+    return ();
   }
 }
 
@@ -298,6 +305,7 @@ always return a resultset, even in list context.
 
 =cut
 
+my $callsites_warned;
 sub search_rs {
   my $self = shift;
 
@@ -363,8 +371,17 @@ sub search_rs {
 
   } if @_;
 
-  carp 'search( %condition ) is deprecated, use search( \%condition ) instead'
-    if (@_ > 1 and ! $self->result_source->result_class->isa('DBIx::Class::CDBICompat') );
+  if( @_ > 1 and ! $self->result_source->result_class->isa('DBIx::Class::CDBICompat') ) {
+    # determine callsite obeying Carp::Clan rules (fucking ugly but don't have better ideas)
+    my $callsite = do {
+      my $w;
+      local $SIG{__WARN__} = sub { $w = shift };
+      carp;
+      $w
+    };
+    carp 'search( %condition ) is deprecated, use search( \%condition ) instead'
+      unless $callsites_warned->{$callsite}++;
+  }
 
   for ($old_where, $call_cond) {
     if (defined $_) {
@@ -1306,10 +1323,42 @@ sub _count_subq_rs {
         if (ref $sel eq 'HASH' and $sel->{-as});
     }
 
-    for my $g_part (@$g) {
-      my $colpiece = $sel_index->{$g_part} || $g_part;
+    # anything from the original select mentioned on the group-by needs to make it to the inner selector
+    # also look for named aggregates referred in the having clause
+    # having often contains scalarrefs - thus parse it out entirely
+    my @parts = @$g;
+    if ($attrs->{having}) {
+      local $sql_maker->{having_bind};
+      local $sql_maker->{quote_char} = $sql_maker->{quote_char};
+      local $sql_maker->{name_sep} = $sql_maker->{name_sep};
+      unless (defined $sql_maker->{quote_char} and length $sql_maker->{quote_char}) {
+        $sql_maker->{quote_char} = [ "\x00", "\xFF" ];
+        # if we don't unset it we screw up retarded but unfortunately working
+        # 'MAX(foo.bar)' => { '>', 3 }
+        $sql_maker->{name_sep} = '';
+      }
 
-      # disqualify join-based group_by's. Arcane but possible query
+      my ($lquote, $rquote, $sep) = map { quotemeta $_ } ($sql_maker->_quote_chars, $sql_maker->name_sep);
+
+      my $sql = $sql_maker->_parse_rs_attrs ({ having => $attrs->{having} });
+
+      # search for both a proper quoted qualified string, for a naive unquoted scalarref
+      # and if all fails for an utterly naive quoted scalar-with-function
+      while ($sql =~ /
+        $rquote $sep $lquote (.+?) $rquote
+          |
+        [\s,] \w+ \. (\w+) [\s,]
+          |
+        [\s,] $lquote (.+?) $rquote [\s,]
+      /gx) {
+        push @parts, ($1 || $2 || $3);  # one of them matched if we got here
+      }
+    }
+
+    for (@parts) {
+      my $colpiece = $sel_index->{$_} || $_;
+
+      # unqualify join-based group_by's. Arcane but possible query
       # also horrible horrible hack to alias a column (not a func.)
       # (probably need to introduce SQLA syntax)
       if ($colpiece =~ /\./ && $colpiece !~ /^$attrs->{alias}\./) {
@@ -2713,7 +2762,7 @@ sub is_paged {
 
 sub is_ordered {
   my ($self) = @_;
-  return scalar $self->result_source->storage->_extract_order_columns($self->{attrs}{order_by});
+  return scalar $self->result_source->storage->_extract_order_criteria($self->{attrs}{order_by});
 }
 
 =head2 related_resultset
@@ -3156,16 +3205,6 @@ sub _resolved_attrs {
     $_->{as} = [  map { $_ =~ /^\Q$alias.\E(.+)$/ ? $1 : $_ } @{$_->{as}} ];
   }
 
-  # FIXME !!!
-  # Blatant bugwardness encoded into multiple tests.
-  # While columns behaves sensibly, +columns is expected
-  # to dump *any* foreign columns into the main object
-  # /me vomits
-  $selection_pieces->{'+columns'}{as} = [ map
-    { (split /\./, $_)[-1] }
-    @{$selection_pieces->{'+columns'}{as}}
-  ];
-
   # merge everything
   for (@sel_pairs) {
     $attrs->{select} = $self->_merge_attr ($attrs->{select}, $selection_pieces->{$_}{select});
@@ -3965,7 +4004,11 @@ HAVING is a select statement attribute that is applied between GROUP BY and
 ORDER BY. It is applied to the after the grouping calculations have been
 done.
 
-  having => { 'count(employee)' => { '>=', 100 } }
+  having => { 'count_employee' => { '>=', 100 } }
+
+or with an in-place function in which case literal SQL is required:
+
+  having => \[ 'count(employee) >= ?', [ count => 100 ] ]
 
 =head2 distinct