- Fix hang in t/72pg.t when run against DBD::Pg 3.5.0. The ping()
implementation changes due to RT#100648 made an alarm() based
timeout lock-prone.
+ - Fix failures of t/54taint.t on Windows with spaces in the $^X
+ executable path (RT#101615)
* Misc
+ - Remove warning about potential side effects of RT#79576 (scheduled)
- Skip tests in a way more intelligent and speedy manner when optional
dependencies are missing
- Make the Optional::Dependencies error messages cpanm-friendly
Optional::Dependencies::req_group_list (no known users in the wild)
- Depend on newer SQL::Abstract (fixing overly-aggressive parenthesis
opener: RT#99503)
- - Depend on newer Moo, fixing some interoperability issues:
+ - Depend on newer Moo, fixing some interoperability issues: RT#93004 and
http://lists.scsys.co.uk/pipermail/dbix-class/2014-October/011787.html
- Fix intermittent failures in the LeakTracer on 5.18+
'Data::Page' => '2.00',
'Devel::GlobalDestruction' => '0.09',
'Hash::Merge' => '0.12',
- 'Moo' => '1.006001',
+ 'Moo' => '2.000',
'MRO::Compat' => '0.12',
'Module::Find' => '0.07',
'namespace::clean' => '0.24',
}
}
-tests_recursive (qw|
- t
-|);
+tests_recursive (
+ 't',
+ ( (
+ $Module::Install::AUTHOR
+ or
+ $ENV{DBICTEST_RUN_ALL_TESTS}
+ or
+ ( $ENV{TRAVIS}||'' ) eq 'true'
+ or
+ ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL5_CPANM_IS_RUNNING} and ! $ENV{RELEASE_TESTING} )
+ ) ? 'xt' : () ),
+);
install_script (qw|
script/dbicadmin
my ($self, $groups) = @_;
my $reqs = $self->_groups_to_reqs($groups);
- my $mods_missing = $self->modreq_missing_for($groups);
+
+ my $mods_missing = $reqs->{missing_envvars}
+ ? $self->_list_physically_missing_modules( $reqs->{modreqs} )
+ : $self->modreq_missing_for($groups)
+ ;
return '' if
! $mods_missing
}
-# this method tries to load specified modreqs and returns a hashref of
+# this method tries to find/load specified modreqs and returns a hashref of
# module/loaderror pairs for anything that failed
sub _errorlist_for_modreqs {
# args supposedly already went through _groups_to_reqs and are therefore sanitized
$ret;
}
+# Unlike the above DO NOT try to load anything
+# This is executed when some needed envvars are not available
+# which in turn means a module load will never be reached anyway
+# This is important because some modules (especially DBDs) can be
+# *really* fickle when a require() is attempted, with pretty confusing
+# side-effects (especially on windows)
+sub _list_physically_missing_modules {
+ my ($self, $modreqs) = @_;
+
+ # in case there is a coderef in @INC there is nothing we can definitively prove
+ # so short circuit directly
+ return '' if grep { length ref $_ } @INC;
+
+ my @definitely_missing;
+ for my $mod (keys %$modreqs) {
+ (my $fn = $mod . '.pm') =~ s|::|/|g;
+
+ push @definitely_missing, $mod unless grep
+ # this should work on any combination of slashes
+ { $_ and -d $_ and -f "$_/$fn" and -r "$_/$fn" }
+ @INC
+ ;
+ }
+
+ join ' ', map
+ { $modreqs->{$_} ? qq("$_~>=$modreqs->{$_}") : $_ }
+ sort { lc($a) cmp lc($b) } @definitely_missing
+ ;
+}
+
# This is to be called by the author only (automatically in Makefile.PL)
sub _gen_pod {
use DBIx::Class::_Util qw(is_exception qsub);
use Scalar::Util qw(weaken blessed reftype);
use Try::Tiny;
-
-# DO NOT edit away without talking to riba first, he will just put it back
-# BEGIN pre-Moo2 import block
-BEGIN {
- my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
-
- local $ENV{PERL_STRICTURES_EXTRA} = 0;
- # load all of these now, so that lazy-loading does not escape
- # the current PERL_STRICTURES_EXTRA setting
- require Sub::Quote;
- require Sub::Defer;
- require Moo;
- require Moo::Object;
- require Method::Generate::Accessor;
- require Method::Generate::Constructor;
-
- Moo->import;
- ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
-}
-# END pre-Moo2 import block
-
+use Moo;
use namespace::clean;
=head1 NAME
Even if you upgrade DBIx::Class (which works around the bug starting from
version 0.08210) you may still have corrupted/incorrect data in your database.
-DBIx::Class will currently detect when this condition (more than one
-stringifiable object in one CRUD call) is encountered and will issue a warning
-pointing to this section. This warning will be removed 2 years from now,
-around April 2015, You can disable it after you've audited your data by
-setting the C<DBIC_RT79576_NOWARN> environment variable. Note - the warning
-is emitted only once per callsite per process and only when the condition in
-question is encountered. Thus it is very unlikely that your logsystem will be
-flooded as a result of this.
+DBIx::Class warned about this condition for several years, hoping to give
+anyone affected sufficient notice of the potential issues. The warning was
+removed in version 0.082900.
=back
= modver_gt_or_eq('DBD::SQLite', '1.37') ? 1 : 0;
}
- # an attempt to detect former effects of RT#79576, bug itself present between
- # 0.08191 and 0.08209 inclusive (fixed in 0.08210 and higher)
- my $stringifiable = 0;
-
for my $i (0.. $#$bindattrs) {
-
- $stringifiable++ if ( length ref $bind->[$i][1] and is_plain_value($bind->[$i][1]) );
-
if (
defined $bindattrs->[$i]
and
}
}
- carp_unique(
- 'POSSIBLE *PAST* DATA CORRUPTION detected - see '
- . 'DBIx::Class::Storage::DBI::SQLite/RT79576 or '
- . 'http://v.gd/DBIC_SQLite_RT79576 for further details or set '
- . '$ENV{DBIC_RT79576_NOWARN} to disable this warning. Trigger '
- . 'condition encountered'
- ) if (!$ENV{DBIC_RT79576_NOWARN} and $stringifiable > 1);
-
return $bindattrs;
}
use DBIx::Class::_Util qw(sigwarn_silencer qsub);
use IO::Handle ();
-
-# DO NOT edit away without talking to riba first, he will just put it back
-# BEGIN pre-Moo2 import block
-BEGIN {
- my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
-
- local $ENV{PERL_STRICTURES_EXTRA} = 0;
- # load all of these now, so that lazy-loading does not escape
- # the current PERL_STRICTURES_EXTRA setting
- require Sub::Quote;
- require Sub::Defer;
- require Moo;
- require Moo::Object;
- require Method::Generate::Accessor;
- require Method::Generate::Constructor;
-
- Moo->import;
- ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
-}
-# END pre-Moo2 import block
-
+use Moo;
extends 'DBIx::Class';
use namespace::clean;
use Storable 'nfreeze';
use Scalar::Util qw(weaken blessed reftype);
use List::Util qw(first);
-
-# DO NOT edit away without talking to riba first, he will just put it back
-# BEGIN pre-Moo2 import block
-BEGIN {
- my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all};
-
- local $ENV{PERL_STRICTURES_EXTRA} = 0;
- # load all of these now, so that lazy-loading does not escape
- # the current PERL_STRICTURES_EXTRA setting
- require Sub::Quote;
- require Sub::Defer;
-
- Sub::Quote->import('quote_sub');
- ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} );
-}
-sub qsub ($) { goto "e_sub } # no point depping on new Moo just for this
-# END pre-Moo2 import block
+use Sub::Quote qw(qsub quote_sub);
# Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
BEGIN { *deep_clone = \&Storable::dclone }
require File::Spec;
require File::Find;
-my $xt_dirs;
+my $xt_dist_dirs;
File::Find::find(sub {
- return if $xt_dirs->{$File::Find::dir};
- $xt_dirs->{$File::Find::dir} = 1 if (
+ return if $xt_dist_dirs->{$File::Find::dir};
+ $xt_dist_dirs->{$File::Find::dir} = 1 if (
$_ =~ /\.t$/ and -f $_
);
-}, 'xt');
+}, 'xt/dist');
-my @xt_tests = map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dirs;
-
-# this will add the xt tests to the `make test` target among other things
-Meta->tests(join (' ', map { $_ || () } @xt_tests, Meta->tests ) );
+my @xt_dist_tests = map { File::Spec->catfile($_, '*.t') } sort keys %$xt_dist_dirs;
# inject an explicit xt test run, mainly to check the contents of
# lib and the generated POD's *before* anything is copied around
),
# test list
join( ' ',
- map { $mm_proto->quote_literal($_) } @xt_tests
+ map { $mm_proto->quote_literal($_) } @xt_dist_tests
),
)
]}
'$(ABSPERLRUN)',
map { $mm_proto->quote_literal($_) } qw(-Ilib -e $ENV{RELEASE_TESTING}=1;$ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}=1;)
),
- 'xt/whitespace.t xt/footers.t',
+ 'xt/dist/postdistdir/*.t',
)
)
]}
# Stop pre-started RDBMS and sync for some settle time
run_or_err "Stopping MySQL" "sudo /etc/init.d/mysql stop"
-run_or_err "Stopping PostgreSQL" "sudo /etc/init.d/postgresql stop"
+run_or_err "Stopping PostgreSQL" "sudo /etc/init.d/postgresql stop || /bin/true"
/bin/sync
# Sanity check VM before continuing
sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/enabled\tboolean\ttrue" | debconf-set-selections'
sudo bash -c 'echo -e "firebird2.5-super\tshared/firebird/sysdba_password/new_password\tpassword\t123" | debconf-set-selections'
+ run_or_err "Updating APT sources" "sudo apt-get update"
apt_install $common_packages libmysqlclient-dev memcached firebird2.5-super firebird2.5-dev unixodbc-dev expect
run_or_err "Cloning poor man's cache from github" "git clone --depth=1 --single-branch --branch=oracle/10.2.0 https://github.com/poortravis/poormanscache.git $CACHE_DIR && $CACHE_DIR/reassemble"
# returned results, look through lib, find all mentioned ENVvars and
# set them to true and see if anything explodes
for var in \
+ DBICTEST_RUN_ALL_TESTS \
DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER \
$( grep -P '\$ENV\{' -r lib/ --exclude-dir Optional | grep -oP '\bDBIC\w+' | sort -u | grep -vP '^(DBIC_TRACE(_PROFILE)?|DBIC_.+_DEBUG)$' )
do
--- /dev/null
+###
+### This version is rather 5.8-centric, because DBIC itself is 5.8
+### It certainly can be rewritten to degrade well on 5.6
+###
+
+
+BEGIN {
+ if ($] < 5.010) {
+
+ # Pre-5.10 perls pollute %INC on unsuccesfull module
+ # require, making it appear as if the module is already
+ # loaded on subsequent require()s
+ # Can't seem to find the exact RT/perldelta entry
+ #
+ # The reason we can't just use a sane, clean loader, is because
+ # if a Module require()s another module the %INC will still
+ # get filled with crap and we are back to square one. A global
+ # fix is really the only way for this test, as we try to load
+ # each available module separately, and have no control (nor
+ # knowledge) over their common dependencies.
+ #
+ # we want to do this here, in the very beginning, before even
+ # warnings/strict are loaded
+
+ unshift @INC, 't/lib';
+ require DBICTest::Util::OverrideRequire;
+
+ DBICTest::Util::OverrideRequire::override_global_require( sub {
+ my $res = eval { $_[0]->() };
+ if ($@ ne '') {
+ delete $INC{$_[1]};
+ die $@;
+ }
+ return $res;
+ } );
+ }
+}
+
+# Explicitly add 'lib' to the front of INC - this way we will
+# know without ambiguity what was loaded from the local untar
+# and what came from elsewhere
+use lib qw(lib t/lib);
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use Config;
+use File::Find 'find';
+use Module::Runtime 'module_notional_filename';
+use List::Util qw(max min);
+use ExtUtils::MakeMaker;
+use DBICTest::Util 'visit_namespaces';
+
+# load these two to pull in the t/lib armada
+use DBICTest;
+use DBICTest::Schema;
+
+# do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
+sub req_mod ($) {
+ # trap deprecation warnings and whatnot
+ local $SIG{__WARN__} = sub {};
+ local $@;
+ eval "require $_[0]";
+}
+
+sub say_err {
+ print STDERR "\n", @_, "\n";
+}
+
+# needed for WeirdOS
+sub fixup_path ($) {
+ return $_[0] unless ( $^O eq 'MSWin32' and $_[0] );
+
+ # sometimes we can get a short/longname mix, normalize everything to longnames
+ my $fn = Win32::GetLongPathName($_[0]);
+
+ # Fixup (native) slashes in Config not matching (unixy) slashes in INC
+ $fn =~ s|\\|/|g;
+
+ $fn;
+}
+
+my @lib_display_order = qw(
+ sitearch
+ sitelib
+ vendorarch
+ vendorlib
+ archlib
+ privlib
+);
+my $lib_paths = {
+ (map
+ { $Config{$_}
+ ? ( $_ => fixup_path( $Config{"${_}exp"} || $Config{$_} ) )
+ : ()
+ }
+ @lib_display_order
+ ),
+
+ # synthetic, for display
+ './lib' => 'lib',
+};
+
+sub describe_fn {
+ my $fn = shift;
+
+ return '' if !defined $fn;
+
+ $fn = fixup_path( $fn );
+
+ $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
+ for @lib_display_order;
+
+ $fn;
+}
+
+sub md5_of_fn {
+ # we already checked for -r/-f, just bail if can't open
+ open my $fh, '<:raw', $_[0] or return '';
+ require Digest::MD5;
+ Digest::MD5->new->addfile($fh)->hexdigest;
+}
+
+# first run through lib and *try* to load anything we can find
+# within our own project
+find({
+ wanted => sub {
+ -f $_ or return;
+
+ # can't just `require $fn`, as we need %INC to be
+ # populated properly
+ my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
+ or return;
+
+ req_mod join ('::', File::Spec->splitdir($mod));
+ },
+ no_chdir => 1,
+}, 'lib' );
+
+# now run through OptDeps and attempt loading everything else
+#
+# some things needs to be sorted before other things
+# positive - load first
+# negative - load last
+my $load_weights = {
+ # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
+ # clashes with libssl, and will segfault everything coming after them
+ "DBD::Oracle" => -999,
+};
+req_mod $_ for sort
+ { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
+ keys %{
+ DBIx::Class::Optional::Dependencies->req_list_for([
+ grep
+ # some DBDs are notoriously problematic to load
+ # hence only show stuff based on test_rdbms which will
+ # take into account necessary ENVs
+ { $_ !~ /^rdbms_/ }
+ keys %{DBIx::Class::Optional::Dependencies->req_group_list}
+ ])
+ }
+;
+
+my $has_versionpm = eval { require version };
+
+# at this point we've loaded everything we ever could, let's drill through
+# the *ENTIRE* symtable and build a map of versions
+my $version_list = { perl => $] };
+visit_namespaces( action => sub {
+ no strict 'refs';
+ my $pkg = shift;
+
+ # keep going, but nothing to see here
+ return 1 if $pkg eq 'main';
+
+ # private - not interested, including no further descent
+ return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
+
+ # not interested in no-VERSION-containing modules, nor synthetic classes
+ return 1 if (
+ ! defined ${"${pkg}::VERSION"}
+ or
+ ${"${pkg}::VERSION"} =~ /\Qset by base.pm/
+ );
+
+ # make sure a version can be extracted, be noisy when it doesn't work
+ # do this even if we are throwing away the result below in lieu of EUMM
+ my $mod_ver = eval { $pkg->VERSION };
+ if (my $err = $@) {
+ $err =~ s/^/ /mg;
+ say_err
+ "Calling `$pkg->VERSION` resulted in an exception, which should never "
+ . "happen - please file a bug with the distribution containing $pkg. "
+ . "Complete exception text below:\n\n$err"
+ ;
+ }
+ elsif( ! defined $mod_ver or ! length $mod_ver ) {
+ my $ret = defined $mod_ver
+ ? "the empty string ''"
+ : "'undef'"
+ ;
+
+ say_err
+ "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
+ . "is defined, which should never happen - please file a bug with the "
+ . "distribution containing $pkg."
+ ;
+
+ undef $mod_ver;
+ }
+
+ # if this is a real file - extract the version via EUMM whenever possible
+ my $fn = $INC{module_notional_filename($pkg)};
+
+ my $eumm_ver = (
+ $fn
+ and
+ -f $fn
+ and
+ -r $fn
+ and
+ eval { MM->parse_version( $fn ) }
+ ) || undef;
+
+ if (
+ $has_versionpm
+ and
+ defined $eumm_ver
+ and
+ defined $mod_ver
+ and
+ $eumm_ver ne $mod_ver
+ and
+ (
+ ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
+ !=
+ ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
+ )
+ ) {
+ say_err
+ "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
+ . "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} "
+ . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
+ . "This should never happen - please check whether this is still present "
+ . "in the latest version, and then file a bug with the distribution "
+ . "containing $pkg."
+ ;
+ }
+
+ if( defined $eumm_ver ) {
+ $version_list->{$pkg} = $eumm_ver;
+ }
+ elsif( defined $mod_ver ) {
+ $version_list->{$pkg} = $mod_ver;
+ }
+
+ 1;
+});
+
+# In retrospect it makes little sense to omit this information - just
+# show everything at all times.
+# Nevertheless leave the dead code, in case it turns out to be a bad idea...
+my $show_all = 1;
+#my $show_all = $ENV{PERL_DESCRIBE_ALL_DEPS} || !DBICTest::RunMode->is_plain;
+
+# compress identical versions as close to the root as we can
+# unless we are dealing with a smoker - in which case we want
+# to see every MD5 there is
+unless ($show_all) {
+ for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
+ my $parent = $mod;
+
+ while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
+ $version_list->{$parent}
+ and
+ $version_list->{$parent} eq $version_list->{$mod}
+ and
+ ( ( delete $version_list->{$mod} ) or 1 )
+ and
+ last
+ }
+ }
+}
+
+ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
+
+# do not announce anything under ci - we are watching for STDERR silence
+exit if DBICTest::RunMode->is_ci;
+
+# sort stuff into @INC segments
+my $segments;
+
+MODULE:
+for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
+ my $fn = $INC{module_notional_filename($mod)};
+
+ my $tuple = [ $mod ];
+
+ if ( defined $fn && -f $fn && -r $fn ) {
+ push @$tuple, ( $fn = fixup_path($fn) );
+
+ for my $lib (@lib_display_order, './lib') {
+ if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) {
+ push @{$segments->{$lib}}, $tuple;
+ next MODULE;
+ }
+ }
+ }
+
+ # fallthrough for anything without a physical filename, or unknown lib
+ push @{$segments->{''}}, $tuple;
+}
+
+# diag the result out
+my $max_ver_len = max map
+ { length $_ }
+ ( values %$version_list, 'xxx.yyyzzz_bbb' )
+;
+my $max_mod_len = max map { length $_ } keys %$version_list;
+
+my $discl = <<'EOD';
+
+Versions of all loadable modules within both the core and *OPTIONAL* dependency chains present on this system
+Note that *MANY* of these modules will *NEVER* be loaded during normal operation of DBIx::Class
+EOD
+
+$discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n"
+ unless $show_all;
+
+diag $discl;
+
+diag "\n";
+
+for my $seg ( '', @lib_display_order, './lib' ) {
+ next unless $segments->{$seg};
+
+ diag sprintf "=== %s ===\n\n",
+ $seg
+ ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
+ : 'Misc versions'
+ ;
+
+ diag sprintf (
+ "%*s %*s%s\n",
+ $max_ver_len => $version_list->{$_->[0]},
+ -$max_mod_len => $_->[0],
+ ($_->[1]
+ ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
+ : ''
+ ),
+ ) for @{$segments->{$seg}};
+
+ diag "\n\n"
+}
+
+diag "$discl\n";
# test all kinds of population with stringified objects
# or with empty sets
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
);
$rs->delete;
-} [
- # warning to be removed around Apr 1st 2015
- # smokers start failing a month before that
- (
- ( DBICTest::RunMode->is_author and ( time() > 1427846400 ) )
- or
- ( DBICTest::RunMode->is_smoker and ( time() > 1425168000 ) )
- )
- ? ()
- # one unique for populate() and create() each
- : (qr/\QPOSSIBLE *PAST* DATA CORRUPTION detected \E.+\QTrigger condition encountered at @{[ __FILE__ ]} line\E \d/) x 4
-], 'Data integrity warnings as planned';
+} [], 'Data integrity warnings gone as planned';
$schema->is_executed_sql_bind(
sub {
delete $weak_registry->{$addr}
unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++;
}
+ elsif ($names =~ /^DateTime::TimeZone::UTC/m) {
+ # DT is going through a refactor it seems - let it leak zones for now
+ delete $weak_registry->{$addr};
+ }
elsif (
# # if we can look at closed over pieces - we will register it as a global
# !DBICTest::Util::LeakTracer::CV_TRACING
# doesn't work. We don't want to have the user deal with that.
BEGIN { unless ($INC{'t/lib/DBICTest/WithTaint.pm'}) {
+ if ( $^O eq 'MSWin32' and $^X =~ /\x20/ ) {
+ print "1..0 # SKIP Running this test on Windows with spaces within the perl executable path (\$^X) is not possible due to https://rt.perl.org/Ticket/Display.html?id=123907\n";
+ exit 0;
+ }
+
# it is possible the test itself is initially invoked in taint mode
# and with relative paths *and* with a relative $^X and some other
# craziness... in short: just be proactive
"value in database correct ($v_desc)"
);
-# FIXME - temporary smoke-only escape
-SKIP: {
- skip 'Potential for false negatives - investigation pending', 1
- if DBICTest::RunMode->is_plain;
-
# check if math works
# start by adding/subtracting a 50 bit integer, and then divide by 2 for good measure
my ($sqlop, $expect) = $bi < 0
, "simple integer math with@{[ $dtype ? '' : 'out' ]} bindtype in database correct (base $v_desc)")
or diag sprintf '%s != %s', $row->bigint, $expect;
}
-# end of fixme
-}
is_deeply (\@w, [], "No mismatch warnings on bigint operations ($v_desc)" );
sub is_smoker {
return
- ( ($ENV{TRAVIS}||'') eq 'true' )
+ __PACKAGE__->is_ci
||
( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} )
;
}
+sub is_ci {
+ return (
+ ($ENV{TRAVIS}||'') eq 'true'
+ and
+ ($ENV{TRAVIS_REPO_SLUG}||'') eq 'dbsrgits/dbix-class'
+ )
+}
+
sub is_plain {
return (! __PACKAGE__->is_smoker && ! __PACKAGE__->is_author && ! $ENV{RELEASE_TESTING} )
}
use Scalar::Util qw(blessed refaddr);
use base 'Exporter';
-our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args);
+our @EXPORT_OK = qw(local_umask stacktrace check_customcond_args visit_namespaces);
sub local_umask {
return unless defined $Config{d_umask};
$args;
}
+sub visit_namespaces {
+ my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
+
+ my $visited_count = 1;
+
+ # A package and a namespace are subtly different things
+ $args->{package} ||= 'main';
+ $args->{package} = 'main' if $args->{package} =~ /^ :: (?: main )? $/x;
+ $args->{package} =~ s/^:://;
+
+ if ( $args->{action}->($args->{package}) ) {
+ my $ns =
+ ( ($args->{package} eq 'main') ? '' : $args->{package} )
+ .
+ '::'
+ ;
+
+ $visited_count += visit_namespaces( %$args, package => $_ ) for
+ grep
+ # this happens sometimes on %:: traversal
+ { $_ ne '::main' }
+ map
+ { $_ =~ /^(.+?)::$/ ? "$ns$1" : () }
+ do { no strict 'refs'; keys %$ns }
+ ;
+ }
+
+ return $visited_count;
+}
+
1;
use DBIx::Class::_Util qw(refcount hrefaddr refdesc);
use DBIx::Class::Optional::Dependencies;
use Data::Dumper::Concise;
-use DBICTest::Util 'stacktrace';
+use DBICTest::Util qw( stacktrace visit_namespaces );
use constant {
CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
};
$visited_cnt;
}
-sub visit_namespaces {
- my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
-
- my $visited = 1;
-
- $args->{package} ||= '::';
- $args->{package} = '::' if $args->{package} eq 'main';
-
- if ( $args->{action}->($args->{package}) ) {
-
- my $base = $args->{package};
- $base = '' if $base eq '::';
-
-
- $visited += visit_namespaces({ %$args, package => $_ }) for map
- { $_ =~ /(.+?)::$/ ? "${base}::$1" : () }
- grep
- { $_ =~ /(?<!^main)::$/ }
- do { no strict 'refs'; keys %{ $base . '::'} }
- }
-
- return $visited;
-}
-
# compiles a list of addresses stored as globals (possibly even catching
# class data in the form of method closures), so we can skip them further on
sub symtable_referenced_addresses {
no strict 'refs';
my $pkg = shift;
- $pkg = '' if $pkg eq '::';
- $pkg .= '::';
# the unless regex at the end skips some dangerous namespaces outright
# (but does not prevent descent)
action => sub { 1 },
refs => [ map { my $sym = $_;
- # *{"$pkg$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there
- ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}$sym") : () ),
+ # *{"${pkg}::$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there
+ ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}::$sym") : () ),
- ( defined *{"$pkg$sym"}{SCALAR} and length ref ${"$pkg$sym"} and ! isweak( ${"$pkg$sym"} ) )
- ? ${"$pkg$sym"} : ()
+ ( defined *{"${pkg}::$sym"}{SCALAR} and length ref ${"${pkg}::$sym"} and ! isweak( ${"${pkg}::$sym"} ) )
+ ? ${"${pkg}::$sym"} : ()
,
( map {
- ( defined *{"$pkg$sym"}{$_} and ! isweak(defined *{"$pkg$sym"}{$_}) )
- ? *{"$pkg$sym"}{$_}
+ ( defined *{"${pkg}::$sym"}{$_} and ! isweak(defined *{"${pkg}::$sym"}{$_}) )
+ ? *{"${pkg}::$sym"}{$_}
: ()
} qw(HASH ARRAY IO GLOB) ),
- } keys %$pkg ],
- ) unless $pkg =~ /^ :: (?:
+ } keys %{"${pkg}::"} ],
+ ) unless $pkg =~ /^ (?:
DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
- ) :: $/x;
+ ) $/x;
}
);
$tb->note("Auto checked $refs_traced references for leaks - none detected");
}
-# Disable this until better times - SQLT and probably other things
-# still load strictures. Let's just wait until Moo2.0 and go from there
-=begin for tears
# also while we are here and not in plain runmode: make sure we never
# loaded any of the strictures XS bullshit (it's a leak in a sense)
- unless (DBICTest::RunMode->is_plain) {
+ unless (
+ $ENV{MOO_FATAL_WARNINGS}
+ or
+ # FIXME - SQLT loads strictures explicitly, /facedesk
+ # remove this INC check when 0fb58589 and 45287c815 are rectified
+ $INC{'SQL/Translator.pm'}
+ or
+ DBICTest::RunMode->is_plain
+ ) {
for (qw(indirect multidimensional bareword::filehandles)) {
exists $INC{ Module::Runtime::module_notional_filename($_) }
and
$tb->ok(0, "$_ load should not have been attempted!!!" )
}
}
-=cut
-
}
}
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More 'no_plan';
+use lib 't/lib';
+use DBICTest::RunMode;
+
+my $authorcount = scalar do {
+ open (my $fh, '<', 'AUTHORS') or die "Unable to open AUTHORS - can't happen: $!\n";
+ map { chomp; ( ( ! $_ or $_ =~ /^\s*\#/ ) ? () : $_ ) } <$fh>;
+} or die "Known AUTHORS file seems empty... can't happen...";
+
+# do not announce anything under ci - we are watching for STDERR silence
+diag "\n\n$authorcount contributors made this library what it is today\n\n"
+ unless DBICTest::RunMode->is_ci;
+
+ok 1;
my $email_re = qr/( \< [^\<\>]+ \> ) $/x;
-my (%known_authors, $count);
+my %known_authors;
for (@known_authors) {
my ($name_email) = m/ ^ (?: [^\:]+ \: \s )? (.+) /x;
my ($email) = $name_email =~ $email_re;
- if (
+ fail "Duplicate found: $name_email" if (
$known_authors{$name_email}++
or
( $email and $known_authors{$email}++ )
- ) {
- fail "Duplicate found: $name_email";
- }
- else {
- $count++;
- }
+ );
}
-# do not announce anything under travis - we are watching for STDERR silence
-diag "\n\n$count contributors made this library what it is today\n\n"
- unless ($ENV{TRAVIS}||'') eq 'true';
-
# augh taint mode
if (length $ENV{PATH}) {
( $ENV{PATH} ) = join ( $Config{path_sep},
use lib 't/lib';
-BEGIN {
- require DBICTest::RunMode;
- plan( skip_all => "Skipping test on plain module install" )
- if DBICTest::RunMode->is_plain;
-}
-
use DBICTest;
use File::Find;
use File::Spec;
{
# make module loading impossible, regardless of actual libpath contents
- local @INC = (sub { confess('Optional Dep Test') } );
+ local @INC;
# basic test using the deploy target
for ('deploy', ['deploy']) {
like (
DBIx::Class::Optional::Dependencies->modreq_errorlist_for ($_)->{'SQL::Translator'},
- qr/Optional Dep Test/,
- 'custom exception found in errorlist',
+ qr|\QCan't locate SQL/Translator.pm|,
+ 'correct "unable to locate" exception found in errorlist',
);
#make it so module appears loaded
namespace::clean
Try::Tiny
Sub::Name
- strictures
Sub::Defer
Sub::Quote
assert_no_missing_expected_requires();
}
-# make sure we never loaded any of the strictures XS bullshit
-{
- ok( ! exists $INC{ Module::Runtime::module_notional_filename($_) }, "$_ load never attempted" )
- for qw(indirect multidimensional bareword::filehandles);
-}
-
done_testing;
sub register_lazy_loadable_requires {
projects / dbsrgits/DBIx-Class.git / commitdiff