From: Matt S Trout <mst@shadowcat.co.uk>
Date: Sat, 10 Aug 2024 23:14:29 +0000 (+0000)
Subject: Work around DBIx::Class leak test bug for users of SQLA based DBIC
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Fdbic-leak-test-fix;p=dbsrgits%2FSQL-Abstract.git

Work around DBIx::Class leak test bug for users of SQLA based DBIC

t/52leaks.t mistakenly treats non-closure anon sub declarations (which perl
caches in the optree) as a leak; introducing a spurious but minimally
invasive lexical makes them into closures and works around this.

Since people are considering testing SQLA against DBIx::Class via downgrading
to the last release before the hostile fork of SQLA::Classic and that release
is set in stone, this seems like the least horribad way to still pass the
DBIC t/ and xt/ test suites.
---

diff --git a/Changes b/Changes
index 31fe196..b0aade9 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for SQL::Abstract
 
+  - Work around DBIx::Class leak test bug for users of SQLA based DBIC
   - Make puke() and belch() methods, ala the SQLA::Classic change
   - Syntax error fixes for 5.8 from ilmari
 
diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index 1016433..1b32845 100644
--- a/lib/SQL/Abstract.pm
+++ b/lib/SQL/Abstract.pm
@@ -207,6 +207,29 @@ sub new {
   my $class = ref($self) || $self;
   my %opt = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
 
+  # Work around bug in DBIx::Class t/52leaks.t
+  #
+  # Newer perls cache anon subs with no closed over values since the result
+  # is constant, but only on first evaluation, so when the perl5 VM creates
+  # them on-demand during new() the DBIx::Class leak test code sees them as
+  # created and not freed, therefore leaked.
+  #
+  # So to make this work for users pinned to v0.082841 of DBIx::Class
+  # (the last version before the hostile fork of this module) we need to
+  # create an ersatz closed over value that defeats the perl5 VM's
+  # improvement.
+  #
+  # We do this by creating a faux scalar that's never used for anything, and
+  # then in subroutines that need to -not- be cached to pass, add
+  #
+  #   $fake_out_dbic_leak_test_bug if 0;
+  #
+  # which the peephole optimiser will turn into an OP_NULL because it can
+  # spot that it's an if with a false condition, so any performance overhead
+  # should be minimal.
+
+  my $fake_out_dbic_leak_test_bug;
+
   # choose our case by keeping an option around
   delete $opt{case} if $opt{case} && $opt{case} ne 'lower';
 
@@ -272,12 +295,17 @@ sub new {
     }
     if (__PACKAGE__->can('_table') ne $class->can('_table')) {
       $opt{expand_clause}{'select.from'} = sub {
+        $fake_out_dbic_leak_test_bug if 0;
         return +{ -literal => [ $_[0]->_table($_[2]) ] };
       };
     }
     if (__PACKAGE__->can('_order_by') ne $class->can('_order_by')) {
-      $opt{expand_clause}{'select.order_by'} = sub { $_[2] };
+      $opt{expand_clause}{'select.order_by'} = sub {
+        $fake_out_dbic_leak_test_bug if 0;
+        $_[2]
+      };
       $opt{render_clause}{'select.order_by'} = sub {
+        $fake_out_dbic_leak_test_bug if 0;
         [ $_[0]->_order_by($_[2]) ];
       };
     }
@@ -312,11 +340,13 @@ sub new {
       $opt{warn_once_on_nest} = 1;
       $opt{disable_old_special_ops} = 1;
       $opt{render_clause}{'select.where'} = sub {
+        $fake_out_dbic_leak_test_bug if 0;
         my ($sql, @bind) = $_[0]->where($_[2]);
         s/\A\s+//, s/\s+\Z// for $sql;
         return [ $sql, @bind ];
       };
       $opt{expand_op}{ident} = $class->make_unop_expander(sub {
+        $fake_out_dbic_leak_test_bug if 0;
         my ($self, undef, $body) = @_;
         $body = $body->from if Scalar::Util::blessed($body);
         $self->_expand_ident(ident => $body);
@@ -357,7 +387,10 @@ sub new {
     $opt{join_sql_parts} ||= sub { SQL::Abstract::Parts->new(@_) };
   }
 
-  $opt{join_sql_parts} ||= sub { join $_[0], @_[1..$#_] };
+  $opt{join_sql_parts} ||= sub {
+   $fake_out_dbic_leak_test_bug if 0;
+   join $_[0], @_[1..$#_];
+  };
 
   return bless \%opt, $class;
 }