From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 16 Feb 2013 15:27:23 +0000 (+0100)
Subject: Prevent SQL::Translator::Producer::YAML from seeing our potential $dbh
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=31399b48;p=dbsrgits%2FDBIx-Class-Historic.git

Prevent SQL::Translator::Producer::YAML from seeing our potential $dbh

The failure mode here is extremely convoluted, full of unimaginable fail
and makes baby jesus cry :(

The long story: there are two ways to supply a $schema to the SQLT producer:
via an argument to translate() (sane) or at the time of translator instance
creation (less sane). In the second case this becomes a problem because some
serializing producers (e.g. SQLT::Producer::YAML) take the *entire*
SQLT instance and dump it to YAML. This includes the arguments which include
our schema with its storage and potentially its $dbh. This causes the
weird warnings described in e.g. RT#75394, because YAML creates a dead
DBI object upon de-serialization of said arguments. What's even more sad is
that while the YAML Producer dumps the entire SQLT instance, the YAML Parser
simply takes the ->{schema} part of this structure and throws everything
else away.

Of course we can not just fix the ::Producer - folks may very well be relying
on the structure it spits out (nobody knows if the *only* consumer of the
Producer::YAML output is in fact Parser::YAML). Really the only thing we can
know (well not know, but reasonably assume) is that there is no way that any
user relies on the accessing the storage passed in with a schema instance to
be parsed.

So what we do is the least invasive thing of all - at translate() time we
check the state of the passed in $schema and if it does have a storage
instance we simply detach it (by cloning the $schema instance) and as a
result everything remains happy.
---

diff --git a/Changes b/Changes
index be07d01..c3497d0 100644
--- a/Changes
+++ b/Changes
@@ -9,6 +9,8 @@ Revision history for DBIx::Class
         - Fix duplicated selected columns when calling 'count' when a same
           aggregate function is used more than once in a 'having' clause
           (RT#83305)
+        - Prevent SQL::Translator::Producer::YAML from seeing the $dbh
+          in a potentially connected $schema instance (RT#75394)
 
     * Misc
         - Fixup our distbuilding process to stop creating world-writable
diff --git a/lib/SQL/Translator/Parser/DBIx/Class.pm b/lib/SQL/Translator/Parser/DBIx/Class.pm
index 1817c1c..527d5e5 100644
--- a/lib/SQL/Translator/Parser/DBIx/Class.pm
+++ b/lib/SQL/Translator/Parser/DBIx/Class.pm
@@ -57,6 +57,19 @@ sub parse {
         or DBIx::Class::Exception->throw("Can't load $dbicschema: $@");
     }
 
+    if (
+      ref $args->{dbic_schema}
+        and
+      $args->{dbic_schema}->storage
+    ) {
+      # we have a storage-holding $schema instance in $args
+      # we need to dissociate it from that $storage
+      # otherwise SQLT insanity may ensue due to how some
+      # serializing producers treat $args (crazy crazy shit)
+      local $args->{dbic_schema}{storage};
+      $args->{dbic_schema} = $args->{dbic_schema}->clone;
+    }
+
     my $schema      = $tr->schema;
     my $table_no    = 0;
 
diff --git a/t/99dbic_sqlt_parser.t b/t/99dbic_sqlt_parser.t
index ef08a53..82d9364 100644
--- a/t/99dbic_sqlt_parser.t
+++ b/t/99dbic_sqlt_parser.t
@@ -49,6 +49,45 @@ BEGIN {
 # make sure classname-style works
 lives_ok { isa_ok (create_schema ({ schema => 'DBICTest::Schema' }), 'SQL::Translator::Schema', 'SQLT schema object produced') };
 
+# make sure a connected instance passed via $args does not get the $dbh improperly serialized
+SKIP: {
+
+  # YAML is a build_requires dep of SQLT - it may or may not be here
+  eval { require YAML } or skip "Test requires YAML.pm", 1;
+
+  lives_ok {
+
+    my $s = DBICTest->init_schema(no_populate => 1);
+    ok ($s->storage->connected, '$schema instance connected');
+
+    # roundtrip through YAML
+    my $yaml_rt_schema = SQL::Translator->new(
+      parser => 'SQL::Translator::Parser::YAML'
+    )->translate(
+      data => SQL::Translator->new(
+        parser_args => { package => $s },
+        parser => 'SQL::Translator::Parser::DBIx::Class',
+        producer => 'SQL::Translator::Producer::YAML',
+      )->translate
+    );
+
+    isa_ok ( $yaml_rt_schema, 'SQL::Translator::Schema', 'SQLT schema object produced after YAML roundtrip');
+
+    ok ($s->storage->connected, '$schema instance still connected');
+  }
+
+  eval <<'EOE' or die $@;
+  END {
+    $^W = 1;  # important, otherwise DBI won't trip the next fail()
+    $SIG{__WARN__} = sub {
+      fail "Unexpected global destruction warning"
+        if $_[0] =~ /is not a DBI/;
+      warn @_;
+    };
+  }
+EOE
+
+}
 
 my $schema = DBICTest->init_schema( no_deploy => 1 );