From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 4 Jun 2014 03:30:26 +0000 (+0200)
Subject: Consolidate handling of "is this a literal" and "is this a value"
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3705e3b2801ea6a8f770b6f0c528b119bea92fe9;p=dbsrgits%2FDBIx-Class-Historic.git

Consolidate handling of "is this a literal" and "is this a value"

In the process fix inability of IC to deal with \[], and simplify
the overal codepath bind value passing codepath

Aside from the bugfixes there should be no functional changes

Work inspired by a report and preliminary patch from dim0xff++
---

diff --git a/Changes b/Changes
index bbd5815..0b971bd 100644
--- a/Changes
+++ b/Changes
@@ -11,9 +11,15 @@ Revision history for DBIx::Class
           up by create() and populate()
         - Ensure definitive condition extractor handles bizarre corner cases
           without bombing out (RT#93244)
+        - Fix set_inflated_column incorrectly handling \[] literals (GH#44)
+        - Ensure that setting a column to a literal invariably marks it dirty
         - Fix inability to handle multiple consecutive transactions with
           savepoints on DBD::SQLite < 1.39
 
+    * Misc
+        - Stop explicitly stringifying objects before passing them to DBI,
+          instead assume that the DBI/DBD combo will take care of things
+
 0.08270 2014-01-30 21:54 (PST)
     * Fixes
         - Fix 0.08260 regression in DBD::SQLite bound int handling. Inserted
diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index ac9f581..85450ac 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -356,6 +356,8 @@ debolaz: Anders Nor Berle <berle@cpan.org>
 
 dew: Dan Thomas <dan@godders.org>
 
+dim0xff: Dmitry Latin <dim0xff@gmail.com>
+
 dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
 
 dnm: Justin Wheeler <jwheeler@datademons.com>
diff --git a/lib/DBIx/Class/InflateColumn.pm b/lib/DBIx/Class/InflateColumn.pm
index 9214582..e9cc417 100644
--- a/lib/DBIx/Class/InflateColumn.pm
+++ b/lib/DBIx/Class/InflateColumn.pm
@@ -3,7 +3,9 @@ package DBIx::Class::InflateColumn;
 use strict;
 use warnings;
 
-use base qw/DBIx::Class::Row/;
+use base 'DBIx::Class::Row';
+use DBIx::Class::_Util 'is_literal_value';
+use namespace::clean;
 
 =head1 NAME
 
@@ -104,24 +106,36 @@ sub inflate_column {
 sub _inflated_column {
   my ($self, $col, $value) = @_;
   return $value unless defined $value; # NULL is NULL is NULL
+
   my $info = $self->column_info($col)
     or $self->throw_exception("No column info for $col");
+
   return $value unless exists $info->{_inflate_info};
+
   my $inflate = $info->{_inflate_info}{inflate};
   $self->throw_exception("No inflator for $col") unless defined $inflate;
+
   return $inflate->($value, $self);
 }
 
 sub _deflated_column {
   my ($self, $col, $value) = @_;
-#  return $value unless ref $value && blessed($value); # If it's not an object, don't touch it
-  ## Leave scalar refs (ala SQL::Abstract literal SQL), untouched, deflate all other refs
-  return $value unless (ref $value && ref($value) ne 'SCALAR');
+
+  ## Deflate any refs except for literals, pass through plain values
+  return $value if (
+    ! length ref $value
+      or
+    is_literal_value($value)
+  );
+
   my $info = $self->column_info($col) or
     $self->throw_exception("No column info for $col");
+
   return $value unless exists $info->{_inflate_info};
+
   my $deflate = $info->{_inflate_info}{deflate};
   $self->throw_exception("No deflator for $col") unless defined $deflate;
+
   return $deflate->($value, $self);
 }
 
@@ -144,7 +158,8 @@ sub get_inflated_column {
     if exists $self->{_inflated_column}{$col};
 
   my $val = $self->get_column($col);
-  return $val if ref $val eq 'SCALAR';  #that would be a not-yet-reloaded sclarref update
+
+  return $val if is_literal_value($val);  #that would be a not-yet-reloaded literal update
 
   return $self->{_inflated_column}{$col} = $self->_inflated_column($col, $val);
 }
@@ -161,8 +176,8 @@ analogous to L<DBIx::Class::Row/set_column>.
 sub set_inflated_column {
   my ($self, $col, $inflated) = @_;
   $self->set_column($col, $self->_deflated_column($col, $inflated));
-#  if (blessed $inflated) {
-  if (ref $inflated && ref($inflated) ne 'SCALAR') {
+
+  if (length ref $inflated and ! is_literal_value($inflated) ) {
     $self->{_inflated_column}{$col} = $inflated;
   } else {
     delete $self->{_inflated_column}{$col};
@@ -181,14 +196,17 @@ as dirty. This is directly analogous to L<DBIx::Class::Row/store_column>.
 
 sub store_inflated_column {
   my ($self, $col, $inflated) = @_;
-#  unless (blessed $inflated) {
-  unless (ref $inflated && ref($inflated) ne 'SCALAR') {
-      delete $self->{_inflated_column}{$col};
-      $self->store_column($col => $inflated);
-      return $inflated;
+
+  if (is_literal_value($inflated)) {
+    delete $self->{_inflated_column}{$col};
+    $self->store_column($col => $inflated);
   }
-  delete $self->{_column_data}{$col};
-  return $self->{_inflated_column}{$col} = $inflated;
+  else {
+    delete $self->{_column_data}{$col};
+    $self->{_inflated_column}{$col} = $inflated;
+  }
+
+  return $inflated;
 }
 
 =head1 SEE ALSO
diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 292dbc3..e2c87dd 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -6,7 +6,9 @@ use base qw/DBIx::Class/;
 use DBIx::Class::Carp;
 use DBIx::Class::ResultSetColumn;
 use Scalar::Util qw/blessed weaken reftype/;
-use DBIx::Class::_Util 'fail_on_internal_wantarray';
+use DBIx::Class::_Util qw(
+  fail_on_internal_wantarray is_plain_value is_literal_value
+);
 use Try::Tiny;
 use Data::Compare (); # no imports!!! guard against insane architecture
 
@@ -2446,19 +2448,11 @@ sub _merge_with_rscond {
 
       for my $c (keys %$implied) {
         my $v = $implied->{$c};
-        if (
-          ! ref $v
-            or
-          overload::Method($v, '""')
-        ) {
+        if ( ! length ref $v or is_plain_value($v) ) {
           $new_data{$c} = $v;
         }
         elsif (
-          ref $v eq 'HASH' and keys %$v == 1 and exists $v->{'='} and (
-            ref $v->{'='} eq 'SCALAR'
-              or
-            ( ref $v->{'='} eq 'REF' and ref ${$v->{'='}} eq 'ARRAY' )
-          )
+          ref $v eq 'HASH' and keys %$v == 1 and exists $v->{'='} and is_literal_value($v->{'='})
         ) {
           $new_data{$c} = $v->{'='};
         }
diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index 8e8da7f..e1ebbf7 100644
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -9,6 +9,7 @@ use DBIx::Class::ResultSet;
 use DBIx::Class::ResultSourceHandle;
 
 use DBIx::Class::Carp;
+use DBIx::Class::_Util 'is_literal_value';
 use Devel::GlobalDestruction;
 use Try::Tiny;
 use List::Util 'first';
@@ -1741,9 +1742,7 @@ sub _resolve_condition {
         if (
           ref $joinfree_cond->{$c}
             and
-          ref $joinfree_cond->{$c} ne 'SCALAR'
-            and
-          ref $joinfree_cond->{$c} ne 'REF'
+          ! is_literal_value( $joinfree_cond->{$c} )
         ) {
           push @$cond_cols, $colname;
           next;
diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm
index ce08fbd..05d19a5 100644
--- a/lib/DBIx/Class/Row.pm
+++ b/lib/DBIx/Class/Row.pm
@@ -9,6 +9,7 @@ use Scalar::Util 'blessed';
 use List::Util 'first';
 use Try::Tiny;
 use DBIx::Class::Carp;
+use DBIx::Class::_Util 'is_literal_value';
 
 ###
 ### Internal method
@@ -985,6 +986,13 @@ sub _eq_column_values {
   elsif (not defined $old) {  # both undef
     return 1;
   }
+  elsif (
+    is_literal_value $old
+      or
+    is_literal_value $new
+  ) {
+    return 0;
+  }
   elsif ($old eq $new) {
     return 1;
   }
diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm
index 319d3fb..5b5181f 100644
--- a/lib/DBIx/Class/SQLMaker.pm
+++ b/lib/DBIx/Class/SQLMaker.pm
@@ -270,7 +270,6 @@ sub _recurse_fields {
 
     return ($select, @rhs_bind);
   }
-  # Is the second check absolutely necessary?
   elsif ( $ref eq 'REF' and ref($$fields) eq 'ARRAY' ) {
     return @{$$fields};
   }
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 75c8434..a213c95 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -13,8 +13,8 @@ use List::Util qw/first/;
 use Sub::Name 'subname';
 use Context::Preserve 'preserve_context';
 use Try::Tiny;
-use overload ();
 use Data::Compare (); # no imports!!! guard against insane architecture
+use DBIx::Class::_Util qw(is_plain_value is_literal_value);
 use namespace::clean;
 
 # default cursor class, overridable in connect_info attributes
@@ -1741,7 +1741,7 @@ sub _resolve_bindattrs {
         and
       length ref $resolved->[1]
         and
-      ! overload::Method($resolved->[1], '""')
+      ! is_plain_value $resolved->[1]
     ) {
       require Data::Dumper;
       local $Data::Dumper::Maxdepth = 1;
@@ -1895,15 +1895,9 @@ sub _bind_sth_params {
       );
     }
     else {
-      # FIXME SUBOPTIMAL - most likely this is not necessary at all
-      # confirm with dbi-dev whether explicit stringification is needed
-      my $v = ( length ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""') )
-        ? "$bind->[$i][1]"
-        : $bind->[$i][1]
-      ;
       $sth->bind_param(
         $i + 1,
-        $v,
+        $bind->[$i][1],
         $bind_attrs->[$i],
       );
     }
@@ -1923,9 +1917,7 @@ sub _prefetch_autovalues {
       (
         ! exists $to_insert->{$col}
           or
-        ref $to_insert->{$col} eq 'SCALAR'
-          or
-        (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY')
+        is_literal_value($to_insert->{$col})
       )
     ) {
       $values{$col} = $self->_sequence_fetch(
@@ -1962,11 +1954,9 @@ sub insert {
     }
 
     # nothing to retrieve when explicit values are supplied
-    next if (defined $to_insert->{$col} and ! (
-      ref $to_insert->{$col} eq 'SCALAR'
-        or
-      (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY')
-    ));
+    next if (
+      defined $to_insert->{$col} and ! is_literal_value($to_insert->{$col})
+    );
 
     # the 'scalar keys' is a trick to preserve the ->columns declaration order
     $retrieve_cols{$col} = scalar keys %retrieve_cols if (
@@ -2046,18 +2036,6 @@ sub insert_bulk {
 
   my @col_range = (0..$#$cols);
 
-  # FIXME SUBOPTIMAL - most likely this is not necessary at all
-  # confirm with dbi-dev whether explicit stringification is needed
-  #
-  # forcibly stringify whatever is stringifiable
-  # ResultSet::populate() hands us a copy - safe to mangle
-  for my $r (0 .. $#$data) {
-    for my $c (0 .. $#{$data->[$r]}) {
-      $data->[$r][$c] = "$data->[$r][$c]"
-        if ( length ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') );
-    }
-  }
-
   my $colinfos = $source->columns_info($cols);
 
   local $self->{_autoinc_supplied_for_op} =
@@ -2184,7 +2162,7 @@ sub insert_bulk {
         }
       }
       elsif (! defined $value_type_by_col_idx->{$col_idx} ) {  # regular non-literal value
-        if (ref $val eq 'SCALAR' or (ref $val eq 'REF' and ref $$val eq 'ARRAY') ) {
+        if (is_literal_value($val)) {
           $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx);
         }
       }
diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm
index 2778dbd..3024e89 100644
--- a/lib/DBIx/Class/Storage/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm
@@ -6,7 +6,7 @@ use warnings;
 use base qw/DBIx::Class::Storage::DBI/;
 use mro 'c3';
 
-use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer);
+use DBIx::Class::_Util qw(modver_gt_or_eq sigwarn_silencer is_plain_value);
 use DBIx::Class::Carp;
 use Try::Tiny;
 use namespace::clean;
@@ -326,7 +326,7 @@ sub _dbi_attrs_for_bind {
 
   for my $i (0.. $#$bindattrs) {
 
-    $stringifiable++ if ( length ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""') );
+    $stringifiable++ if ( length ref $bind->[$i][1] and is_plain_value($bind->[$i][1]) );
 
     if (
       defined $bindattrs->[$i]
diff --git a/lib/DBIx/Class/Storage/DBIHacks.pm b/lib/DBIx/Class/Storage/DBIHacks.pm
index aa11286..7a3587d 100644
--- a/lib/DBIx/Class/Storage/DBIHacks.pm
+++ b/lib/DBIx/Class/Storage/DBIHacks.pm
@@ -16,6 +16,7 @@ use mro 'c3';
 use List::Util 'first';
 use Scalar::Util 'blessed';
 use Sub::Name 'subname';
+use DBIx::Class::_Util qw(is_plain_value is_literal_value);
 use namespace::clean;
 
 #
@@ -1142,7 +1143,7 @@ sub _collapse_cond_unroll_pairs {
 
           my ($l, $r) = %$p;
 
-          push @conds, ( ! ref $r or overload::Method($r, '""' ) )
+          push @conds, ( ! length ref $r or is_plain_value($r) )
             ? { $l => $r }
             : { $l => { '=' => $r } }
           ;
@@ -1204,16 +1205,10 @@ sub _extract_fixed_condition_columns {
   for my $c (keys %$where_hash) {
     if (defined (my $v = $where_hash->{$c}) ) {
       if (
-        ! ref $v
+        ! length ref $v
           or
         (ref $v eq 'HASH' and keys %$v == 1 and defined $v->{'='} and (
-          ! ref $v->{'='}
-            or
-          ref $v->{'='} eq 'SCALAR'
-            or
-          ( ref $v->{'='} eq 'REF' and ref ${$v->{'='}} eq 'ARRAY' )
-            or
-          overload::Method($v->{'='}, '""')
+          is_literal_value($v->{'='}) or is_plain_value( $v->{'='})
         ))
       ) {
         $res->{$c} = 1;
diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 518457c..1407ddc 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -55,9 +55,15 @@ use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
 
 use Carp 'croak';
 use Scalar::Util qw(weaken blessed reftype);
+use List::Util qw(first);
+use overload ();
 
 use base 'Exporter';
-our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray refcount hrefaddr is_exception);
+our @EXPORT_OK = qw(
+  sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray
+  refcount hrefaddr is_exception
+  is_plain_value is_literal_value
+);
 
 sub sigwarn_silencer ($) {
   my $pattern = shift;
@@ -153,6 +159,43 @@ sub modver_gt_or_eq ($$) {
   eval { $mod->VERSION($ver) } ? 1 : 0;
 }
 
+sub is_literal_value ($) {
+  (
+    ref $_[0] eq 'SCALAR'
+      or
+    ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' )
+  ) ? 1 : 0;
+}
+
+# FIXME XSify - this can be done so much more efficiently
+sub is_plain_value ($) {
+  no strict 'refs';
+  (
+    # plain scalar
+    (! length ref $_[0])
+      or
+    (
+      blessed $_[0]
+        and
+      # deliberately not using Devel::OverloadInfo - the checks we are
+      # intersted in are much more limited than the fullblown thing, and
+      # this is a relatively hot piece of code
+      (
+        # either has stringification which DBI prefers out of the box
+        #first { *{$_ . '::(""'}{CODE} } @{ mro::get_linear_isa( ref $_[0] ) }
+        overload::Method($_[0], '""')
+          or
+        # has nummification and fallback is *not* disabled
+        (
+          $_[1] = first { *{"${_}::(0+"}{CODE} } @{ mro::get_linear_isa( ref $_[0] ) }
+            and
+          ( ! defined ${"$_[1]::()"} or ${"$_[1]::()"} )
+        )
+      )
+    )
+  ) ? 1 : 0;
+}
+
 {
   my $list_ctx_ok_stack_marker;
 
diff --git a/t/100populate.t b/t/100populate.t
index 4a3f0ac..27eb3ef 100644
--- a/t/100populate.t
+++ b/t/100populate.t
@@ -416,7 +416,7 @@ warnings_like {
   )
     ? ()
     # one unique for populate() and create() each
-    : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 2
+    : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 3
 ], 'Data integrity warnings as planned';
 
 lives_ok {
diff --git a/t/inflate/datetime.t b/t/inflate/datetime.t
index 7062563..f0c6102 100644
--- a/t/inflate/datetime.t
+++ b/t/inflate/datetime.t
@@ -98,4 +98,52 @@ is("$varchar_datetime", '2006-05-22T19:05:07', 'Correct date/time');
 my $skip_inflation = $event->skip_inflation;
 is ("$skip_inflation", '2006-04-21 18:04:06', 'Correct date/time');
 
+# create and update with literals
+{
+  my $d = {
+    created_on => \ '2001-09-11',
+    starts_at => \[ '?' => '2001-10-26' ],
+  };
+
+  my $ev = $schema->resultset('Event')->create($d);
+
+  for my $col (qw(created_on starts_at)) {
+    ok (ref $ev->$col, "literal untouched in $col");
+    is_deeply( $ev->$col, $d->{$col});
+    is_deeply( $ev->get_inflated_column($col), $d->{$col});
+    is_deeply( $ev->get_column($col), $d->{$col});
+  }
+
+  $ev->discard_changes;
+
+  is_deeply(
+    { $ev->get_dirty_columns },
+    {}
+  );
+
+  for my $col (qw(created_on starts_at)) {
+    isa_ok ($ev->$col, "DateTime", "$col properly inflated on retrieve");
+  }
+
+  for my $meth (qw(set_inflated_columns set_columns)) {
+
+    $ev->$meth({%$d});
+
+    is_deeply(
+      { $ev->get_dirty_columns },
+      $d,
+      "Expected dirty cols after setting literals via $meth",
+    );
+
+    $ev->update;
+
+    for my $col (qw(created_on starts_at)) {
+      ok (ref $ev->$col, "literal untouched in $col updated via $meth");
+      is_deeply( $ev->$col, $d->{$col});
+      is_deeply( $ev->get_inflated_column($col), $d->{$col});
+      is_deeply( $ev->get_column($col), $d->{$col});
+    }
+  }
+}
+
 done_testing;
diff --git a/t/internals/is_plain_value.t b/t/internals/is_plain_value.t
new file mode 100644
index 0000000..81fe902
--- /dev/null
+++ b/t/internals/is_plain_value.t
@@ -0,0 +1,60 @@
+use warnings;
+use strict;
+
+use Test::More;
+use Test::Warn;
+
+use lib qw(t/lib);
+use DBICTest;
+
+use DBIx::Class::_Util 'is_plain_value';
+
+{
+  package # hideee
+    DBICTest::SillyInt;
+
+  use overload
+    # *DELIBERATELY* unspecified
+    #fallback => 1,
+    '0+' => sub { ${$_[0]} },
+  ;
+
+
+  package # hideee
+    DBICTest::SillyInt::Subclass;
+
+  our @ISA = 'DBICTest::SillyInt';
+
+
+  package # hideee
+    DBICTest::CrazyInt;
+
+  use overload
+    '0+' => sub { 666 },
+    '""' => sub { 999 },
+    fallback => 1,
+  ;
+}
+
+# check DBI behavior when fed a stringifiable/nummifiable value
+{
+  my $crazynum = bless {}, 'DBICTest::CrazyInt';
+  cmp_ok( $crazynum, '==', 666 );
+  cmp_ok( $crazynum, 'eq', 999 );
+
+  my $schema = DBICTest->init_schema( no_populate => 1 );
+  $schema->storage->dbh_do(sub {
+    $_[1]->do('INSERT INTO artist (name) VALUES (?)', {}, $crazynum );
+  });
+
+  is( $schema->resultset('Artist')->next->name, 999, 'DBI preferred stringified version' );
+}
+
+# make sure we recognize overloaded stuff properly
+{
+  my $num = bless( \do { my $foo = 69 }, 'DBICTest::SillyInt::Subclass' );
+  ok( is_plain_value $num, 'parent-fallback-provided stringification detected' );
+  is("$num", 69, 'test overloaded object stringifies, without specified fallback');
+}
+
+done_testing;