From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 3 Apr 2013 13:59:16 +0000 (+0200)
Subject: Make sure external DBIC envvars do not cause tests to fail
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=eed5492f;p=dbsrgits%2FDBIx-Class-Historic.git

Make sure external DBIC envvars do not cause tests to fail

Run the appropriate tests on travis to detect future problems
---

diff --git a/.travis.yml b/.travis.yml
index f457959..5db8be1 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -113,21 +113,23 @@ matrix:
         - BREWOPTS="-Duseithreads -Dusemorebits"
         - BREWVER=5.8.8
 
-    # some permutations of tracing envvar testing
+    # some permutations of tracing and envvar poisoning
     - perl: 5.16
       env:
         - CLEANTEST=false
-        - DBIC_TRACE=1
+        - POISON_ENV=true
 
     - perl: 5.16
       env:
         - CLEANTEST=true
+        - POISON_ENV=true
         - DBIC_TRACE=1
         - DBIC_TRACE_PROFILE=console
 
     - perl: 5.16
       env:
         - CLEANTEST=false
+        - POISON_ENV=true
         - DBIC_TRACE=1
         - DBIC_TRACE_PROFILE=console_monochrome
 
diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm
index 0daf5cb..6685ad9 100644
--- a/lib/DBIx/Class/Row.pm
+++ b/lib/DBIx/Class/Row.pm
@@ -132,16 +132,16 @@ sub __new_related_find_or_new_helper {
   my $proc_data = { $new_rel_obj->get_columns };
 
   if ($self->__their_pk_needs_us($relname)) {
-    MULTICREATE_DEBUG and warn "MC $self constructing $relname via new_result";
+    MULTICREATE_DEBUG and print STDERR "MC $self constructing $relname via new_result\n";
     return $new_rel_obj;
   }
   elsif ($rsrc->_pk_depends_on($relname, $proc_data )) {
     if (! keys %$proc_data) {
       # there is nothing to search for - blind create
-      MULTICREATE_DEBUG and warn "MC $self constructing default-insert $relname";
+      MULTICREATE_DEBUG and print STDERR "MC $self constructing default-insert $relname\n";
     }
     else {
-      MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
+      MULTICREATE_DEBUG and print STDERR "MC $self constructing $relname via find_or_new\n";
       # this is not *really* find or new, as we don't want to double-new the
       # data (thus potentially double encoding or whatever)
       my $exists = $rel_rs->find ($proc_data);
@@ -212,7 +212,7 @@ sub new {
             $new->{_rel_in_storage}{$key} = 1;
             $new->set_from_related($key, $rel_obj);
           } else {
-            MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj\n";
+            MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj\n";
           }
 
           $related->{$key} = $rel_obj;
@@ -232,7 +232,7 @@ sub new {
               $rel_obj->throw_exception ('A multi relationship can not be pre-existing when doing multicreate. Something went wrong');
             } else {
               MULTICREATE_DEBUG and
-                warn "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
+                print STDERR "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
             }
             push(@objects, $rel_obj);
           }
@@ -249,7 +249,7 @@ sub new {
             $new->{_rel_in_storage}{$key} = 1;
           }
           else {
-            MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj";
+            MULTICREATE_DEBUG and print STDERR "MC $new uninserted $key $rel_obj\n";
           }
           $inflated->{$key} = $rel_obj;
           next;
@@ -361,7 +361,7 @@ sub insert {
       # The guard will save us if we blow out of this scope via die
       $rollback_guard ||= $storage->txn_scope_guard;
 
-      MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
+      MULTICREATE_DEBUG and print STDERR "MC $self pre-reconstructing $relname $rel_obj\n";
 
       my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns };
       my $existing;
@@ -393,7 +393,7 @@ sub insert {
 
   MULTICREATE_DEBUG and do {
     no warnings 'uninitialized';
-    warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
+    print STDERR "MC $self inserting (".join(', ', $self->get_columns).")\n";
   };
 
   # perform the insert - the storage will return everything it is asked to
@@ -438,14 +438,14 @@ sub insert {
         $obj->set_from_related($_, $self) for keys %$reverse;
         if ($self->__their_pk_needs_us($relname)) {
           if (exists $self->{_ignore_at_insert}{$relname}) {
-            MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname";
+            MULTICREATE_DEBUG and print STDERR "MC $self skipping post-insert on $relname\n";
           }
           else {
-            MULTICREATE_DEBUG and warn "MC $self inserting $relname $obj";
+            MULTICREATE_DEBUG and print STDERR "MC $self inserting $relname $obj\n";
             $obj->insert;
           }
         } else {
-          MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
+          MULTICREATE_DEBUG and print STDERR "MC $self post-inserting $obj\n";
           $obj->insert();
         }
       }
diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash
index d41ce4c..99e0815 100755
--- a/maint/travis-ci_scripts/30_before_script.bash
+++ b/maint/travis-ci_scripts/30_before_script.bash
@@ -3,6 +3,14 @@
 source maint/travis-ci_scripts/common.bash
 if [[ -n "$SHORT_CIRCUIT_SMOKE" ]] ; then return ; fi
 
+# poison the environment - basically look through lib, find all mentioned
+# ENVvars and set them to true and see if anything explodes
+if [[ "$POISON_ENV" = "true" ]] ; then
+  for var in $(grep -P '\$ENV\{' -r lib/ | grep -oP 'DBIC_\w+' | sort -u | grep -v DBIC_TRACE) ; do
+    export $var=1
+  done
+fi
+
 # try Schwern's latest offering on a stock perl and a threaded blead
 # can't do this with CLEANTEST=true yet because a lot of our deps fail
 # tests left and right under T::B 1.5
diff --git a/t/100populate.t b/t/100populate.t
index b6ea7d9..f2a3936 100644
--- a/t/100populate.t
+++ b/t/100populate.t
@@ -312,6 +312,8 @@ lives_ok {
 
 # test all kinds of population with stringified objects
 warnings_like {
+  local $ENV{DBIC_RT79576_NOWARN};
+
   my $rs = $schema->resultset('Artist')->search({}, { columns => [qw(name rank)], order_by => 'artistid' });
 
   # the stringification has nothing to do with the artist name
diff --git a/t/103many_to_many_warning.t b/t/103many_to_many_warning.t
index f2944b4..9e5c19a 100644
--- a/t/103many_to_many_warning.t
+++ b/t/103many_to_many_warning.t
@@ -12,6 +12,8 @@ my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/;
   my @w;
   local $SIG{__WARN__} = sub { $_[0] =~ $exp_warn ? push @w, $_[0] : warn $_[0] };
   my $code = gen_code ( suffix => 1 );
+
+  local $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK};
   eval "$code";
   ok (! $@, 'Eval code without warnings suppression')
     || diag $@;
diff --git a/t/61findnot.t b/t/61findnot.t
index 7a539d6..b8b0d31 100644
--- a/t/61findnot.t
+++ b/t/61findnot.t
@@ -65,6 +65,7 @@ throws_ok {
 } qr/Unable to satisfy requested constraint 'primary'/;
 
 for (1, 0) {
+  local $ENV{DBIC_NULLABLE_KEY_NOWARN};
   warnings_like
     sub {
       $artist_rs->find({ artistid => undef }, { key => 'primary' })
diff --git a/t/85utf8.t b/t/85utf8.t
index ea630a2..a07e42a 100644
--- a/t/85utf8.t
+++ b/t/85utf8.t
@@ -37,6 +37,7 @@ warnings_are (
 
 warnings_like (
   sub {
+    local $ENV{DBIC_UTF8COLUMNS_OK};
     package A::Test1Loud;
     use base 'DBIx::Class::Core';
     __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
diff --git a/t/86might_have.t b/t/86might_have.t
index c1a66de..0ca9a06 100644
--- a/t/86might_have.t
+++ b/t/86might_have.t
@@ -40,6 +40,8 @@ is($queries, 1, 'liner_notes (might_have) prefetched - do not load
 liner_notes on update');
 
 warning_like {
+  local $ENV{DBIC_DONT_VALIDATE_RELS};
+
   DBICTest::Schema::Bookmark->might_have(
     linky => 'DBICTest::Schema::Link',
     { "foreign.id" => "self.link" },
diff --git a/t/94versioning.t b/t/94versioning.t
index 146c7c3..299ac2f 100644
--- a/t/94versioning.t
+++ b/t/94versioning.t
@@ -35,6 +35,9 @@ BEGIN {
   my $s = DBICTest::Schema->connect($dsn, $user, $pass);
 }
 
+# in case it came from the env
+$ENV{DBIC_NO_VERSION_CHECK} = 0;
+
 use_ok('DBICVersion_v1');
 
 my $version_table_name = 'dbix_class_schema_versions';
diff --git a/t/storage/base.t b/t/storage/base.t
index b16938b..948d49a 100644
--- a/t/storage/base.t
+++ b/t/storage/base.t
@@ -121,6 +121,7 @@ my $invocations = {
 };
 
 for my $type (keys %$invocations) {
+  local $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK};
 
   # we can not use a cloner portably because of the coderef
   # so compare dumps instead
@@ -129,7 +130,7 @@ for my $type (keys %$invocations) {
 
   warnings_exist (
     sub { $storage->connect_info ($invocations->{$type}{args}) },
-     $invocations->{$type}{warn} || (),
+     $invocations->{$type}{warn} || [],
     'Warned about ignored attributes',
   );