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';
## 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 {
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
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);
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;
# 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;
}
$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;
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;
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;
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(@_);
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 (
strict
warnings
+ constant
+ Config
+
base
mro
overload
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 =~ /^\(/;
}
}
- 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/) {
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');
}
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');
}
}
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;
use Test::Exception;
use lib qw(t/lib);
-use_ok( 'DBICTest' );
-use_ok( 'DBICTest::Schema' );
+use DBICTest;
my $schema = DBICTest->init_schema;
# 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;
}
projects / dbsrgits/DBIx-Class.git / commitdiff