X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fdeploy_methods%2Fcoderef-leakage.t;fp=t%2Fdeploy_methods%2Fcoderef-leakage.t;h=7254ca7b6b4895dde9777e5d5675283b59d59355;hb=a89cd737a24077f9d021d975a8ee628dc23bfb06;hp=0000000000000000000000000000000000000000;hpb=7c78f0972c8d306eb6d61e8b3941b5b4d6297b96;p=dbsrgits%2FDBIx-Class-DeploymentHandler.git

diff --git a/t/deploy_methods/coderef-leakage.t b/t/deploy_methods/coderef-leakage.t
new file mode 100644
index 0000000..7254ca7
--- /dev/null
+++ b/t/deploy_methods/coderef-leakage.t
@@ -0,0 +1,45 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use aliased 'DBIx::Class::DeploymentHandler::DeployMethod::SQL::Translator';
+use File::Temp;
+
+use lib 't/lib';
+
+use DBICDHTest;
+
+my $dbh = DBICDHTest::dbh();
+my @connection = (sub { $dbh }, { ignore_version => 1 });
+
+DBICDHTest::ready;
+
+use_ok 'DBICVersion_v1';
+my $s = DBICVersion::Schema->connect(@connection);
+my $dm = Translator->new({ schema => $s });
+
+my ($fname1, $fname2) = @_;
+
+{
+   my $fh = File::Temp->new(UNLINK => 0);
+   print {$fh} 'sub leak {} sub { leak() }';
+   $fname1 = $fh->filename;
+   close $fh;
+}
+
+{
+   my $fh = File::Temp->new(UNLINK => 0);
+   print {$fh} 'sub { leak() }';
+   $fname2 = $fh->filename;
+   close $fh;
+}
+
+$dm->_run_perl($fname1, [1]);
+dies_ok { $dm->_run_perl($fname2, [1]) } 'info should not leak between coderefs';
+
+done_testing;
+
+END { unlink $fname1; unlink $fname2 }