From: Peter Rabbitson <ribasushi@cpan.org>
Date: Mon, 17 Sep 2012 13:55:30 +0000 (+0200)
Subject: Reorganize constants handling, add escapes for fork-less OSes
X-Git-Tag: v0.08204~18
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=commitdiff_plain;h=0d8817bcb744bb46adf787f359f34e49b092d42e

Reorganize constants handling, add escapes for fork-less OSes
---

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index 861ee1c..aa79715 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -19,48 +19,41 @@ BEGIN {
   package # hide from pause
     DBIx::Class::_ENV_;
 
-  if ($] < 5.009_005) {
-    require MRO::Compat;
-    *OLD_MRO = sub () { 1 };
-  }
-  else {
-    require mro;
-    *OLD_MRO = sub () { 0 };
-  }
+  use Config;
 
-  # ::Runmode would only be loaded by DBICTest, which in turn implies t/
-  *DBICTEST = eval { DBICTest::RunMode->is_author }
-    ? sub () { 1 }
-    : sub () { 0 }
-  ;
+  use constant {
 
-  # There was a brief period of p5p insanity when $@ was invisible in a DESTROY
-  *INVISIBLE_DOLLAR_AT = ($] >= 5.013001 and $] <= 5.013007)
-    ? sub () { 1 }
-    : sub () { 0 }
-  ;
+    # but of course
+    BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0,
 
-  # During 5.13 dev cycle HELEMs started to leak on copy
-  *PEEPEENESS = (defined $ENV{DBICTEST_ALL_LEAKS}
-    # request for all tests would force "non-leaky" illusion and vice-versa
-    ? ! $ENV{DBICTEST_ALL_LEAKS}
+    HAS_ITHREADS => $Config{useithreads} ? 1 : 0,
 
-    # otherwise confess that this perl is busted ONLY on smokers
-    : do {
-      if (eval { DBICTest::RunMode->is_smoker }) {
+    # ::Runmode would only be loaded by DBICTest, which in turn implies t/
+    DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0,
 
-        # leaky 5.13.6 (fixed in blead/cefd5c7c)
-        if ($] == '5.013006') { 1 }
+    # During 5.13 dev cycle HELEMs started to leak on copy
+    PEEPEENESS =>
+      # request for all tests would force "non-leaky" illusion and vice-versa
+      defined $ENV{DBICTEST_ALL_LEAKS}                                              ? !$ENV{DBICTEST_ALL_LEAKS}
+      # otherwise confess that this perl is busted ONLY on smokers
+    : eval { DBICTest::RunMode->is_smoker } && ($] >= 5.013005 and $] <= 5.013006)  ? 1
+      # otherwise we are good
+                                                                                    : 0
+    ,
 
-        # not sure why this one leaks, but disable anyway - ANDK seems to make it weep
-        elsif ($] == '5.013005') { 1 }
+    # There was a brief period of p5p insanity when $@ was invisible in a DESTROY
+    INVISIBLE_DOLLAR_AT => ($] >= 5.013001 and $] <= 5.013007) ? 1 : 0,
 
-        else { 0 }
-      }
-      else { 0 }
-    }
-  ) ? sub () { 1 } : sub () { 0 };
+  };
 
+  if ($] < 5.009_005) {
+    require MRO::Compat;
+    constant->import( OLD_MRO => 1 );
+  }
+  else {
+    require mro;
+    constant->import( OLD_MRO => 0 );
+  }
 }
 
 use mro 'c3';
diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm
index ecd0864..6970c10 100644
--- a/lib/DBIx/Class/Carp.pm
+++ b/lib/DBIx/Class/Carp.pm
@@ -114,7 +114,7 @@ sub import {
     ## FIXME FIXME FIXME - something is tripping up V::M on 5.8.1, leading
     # to segfaults. When n::c/B::H::EndOfScope is rewritten in terms of tie()
     # see if this starts working
-    unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN();
+    unless DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN;
 }
 
 sub unimport {
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index ac84176..adf99a7 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -207,7 +207,7 @@ sub new {
   END {
     local $?; # just in case the DBI destructor changes it somehow
 
-    # destroy just the object if not native to this process/thread
+    # destroy just the object if not native to this process
     $_->_verify_pid for (grep
       { defined $_ }
       values %seek_and_destroy
@@ -233,7 +233,7 @@ sub DESTROY {
   my $self = shift;
 
   # some databases spew warnings on implicit disconnect
-  $self->_verify_pid;
+  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   local $SIG{__WARN__} = sub {};
   $self->_dbh(undef);
 
@@ -885,7 +885,7 @@ sub connected {
 sub _seems_connected {
   my $self = shift;
 
-  $self->_verify_pid;
+  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
 
   my $dbh = $self->_dbh
     or return 0;
@@ -933,7 +933,7 @@ sub dbh {
 # this is the internal "get dbh or connect (don't check)" method
 sub _get_dbh {
   my $self = shift;
-  $self->_verify_pid;
+  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   $self->_populate_dbh unless $self->_dbh;
   return $self->_dbh;
 }
@@ -1007,7 +1007,7 @@ sub _populate_dbh {
 
   $self->_dbh($self->_connect(@info));
 
-  $self->_conn_pid($$) if $^O ne 'MSWin32'; # on win32 these are in fact threads
+  $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
 
   $self->_determine_driver;
 
@@ -1366,7 +1366,7 @@ sub _exec_txn_begin {
 sub txn_commit {
   my $self = shift;
 
-  $self->_verify_pid if $self->_dbh;
+  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   $self->throw_exception("Unable to txn_commit() on a disconnected storage")
     unless $self->_dbh;
 
@@ -1397,7 +1397,7 @@ sub _exec_txn_commit {
 sub txn_rollback {
   my $self = shift;
 
-  $self->_verify_pid if $self->_dbh;
+  $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   $self->throw_exception("Unable to txn_rollback() on a disconnected storage")
     unless $self->_dbh;
 
@@ -1430,7 +1430,7 @@ for my $meth (qw/svp_begin svp_release svp_rollback/) {
   no strict qw/refs/;
   *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
     my $self = shift;
-    $self->_verify_pid if $self->_dbh;
+    $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
     $self->throw_exception("Unable to $meth() on a disconnected storage")
       unless $self->_dbh;
     $self->next::method(@_);
diff --git a/lib/DBIx/Class/Storage/TxnScopeGuard.pm b/lib/DBIx/Class/Storage/TxnScopeGuard.pm
index 3263096..d8ab75c 100644
--- a/lib/DBIx/Class/Storage/TxnScopeGuard.pm
+++ b/lib/DBIx/Class/Storage/TxnScopeGuard.pm
@@ -111,7 +111,7 @@ sub DESTROY {
   return if $self->{inactivated};
 
   # if our dbh is not ours anymore, the $dbh weakref will go undef
-  $self->{storage}->_verify_pid;
+  $self->{storage}->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
   return unless $self->{dbh};
 
   my $exception = $@ if (
diff --git a/t/53lean_startup.t b/t/53lean_startup.t
index b590b4a..248925a 100644
--- a/t/53lean_startup.t
+++ b/t/53lean_startup.t
@@ -32,6 +32,9 @@ BEGIN {
     strict
     warnings
 
+    constant
+    Config
+
     base
     mro
     overload
diff --git a/t/55namespaces_cleaned.t b/t/55namespaces_cleaned.t
index 5a5cd63..b7d81a8 100644
--- a/t/55namespaces_cleaned.t
+++ b/t/55namespaces_cleaned.t
@@ -109,7 +109,7 @@ for my $mod (@modules) {
 
     for my $name (keys %all_method_like) {
 
-      next if ( DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN() and $name =~ /^carp(?:_unique|_once)?$/ );
+      next if ( DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN and $name =~ /^carp(?:_unique|_once)?$/ );
 
       # overload is a funky thing - it is not cleaned, and its imports are named funny
       next if $name =~ /^\(/;
@@ -154,7 +154,7 @@ for my $mod (@modules) {
       }
     }
 
-    next if DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN();
+    next if DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN;
 
     # some common import names (these should never ever be methods)
     for my $f (qw/carp carp_once carp_unique croak confess cluck try catch finally/) {
diff --git a/t/71mysql.t b/t/71mysql.t
index c656a7f..e86a760 100644
--- a/t/71mysql.t
+++ b/t/71mysql.t
@@ -388,7 +388,7 @@ ZEROINSEARCH: {
 
     TODO: {
       local $TODO = "Perl $] is known to leak like a sieve"
-        if DBIx::Class::_ENV_::PEEPEENESS();
+        if DBIx::Class::_ENV_::PEEPEENESS;
 
       ok (! defined $orig_dbh, 'Parent $dbh handle is gone');
     }
@@ -412,7 +412,7 @@ ZEROINSEARCH: {
 
     TODO: {
       local $TODO = "Perl $] is known to leak like a sieve"
-        if DBIx::Class::_ENV_::PEEPEENESS();
+        if DBIx::Class::_ENV_::PEEPEENESS;
 
       ok (! defined $orig_dbh, 'DBIC operation triggered reconnect - old $dbh is gone');
     }
diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm
index a0d9d63..c330d67 100644
--- a/t/lib/DBICTest.pm
+++ b/t/lib/DBICTest.pm
@@ -189,7 +189,7 @@ sub _database {
 }
 
 sub __mk_disconnect_guard {
-  return if DBIx::Class::_ENV_::PEEPEENESS(); # leaks handles, delaying DESTROY, can't work right
+  return if DBIx::Class::_ENV_::PEEPEENESS; # leaks handles, delaying DESTROY, can't work right
 
   my $db_file = shift;
   return unless -f $db_file;
diff --git a/t/storage/error.t b/t/storage/error.t
index 44cc1c9..d5980eb 100644
--- a/t/storage/error.t
+++ b/t/storage/error.t
@@ -6,8 +6,7 @@ use Test::Warn;
 use Test::Exception;
 
 use lib qw(t/lib);
-use_ok( 'DBICTest' );
-use_ok( 'DBICTest::Schema' );
+use DBICTest;
 
 my $schema = DBICTest->init_schema;
 
@@ -35,7 +34,7 @@ throws_ok (
 # exception fallback:
 
 SKIP: {
-  if (DBIx::Class::_ENV_::PEEPEENESS()) {
+  if (DBIx::Class::_ENV_::PEEPEENESS) {
     skip "Your perl version $] appears to leak like a sieve - skipping garbage collected \$schema test", 1;
   }