t/lib/ANFANG.pm

   1 package # hide from pauses
   2   ANFANG;
   3
   4 # load-time critical
   5 BEGIN {
   6   if ( $ENV{RELEASE_TESTING} ) {
   7     require warnings and warnings->import;
   8     require strict and strict->import;
   9   }
  10 }
  11
  12 #
  13 # FROM THIS POINT ONWARD EVERYTHING HAPPENS LINEARLY AT RUNTIME
  14 #
  15 our $anfang_loaded;
  16
  17 # this allows the obscure but possible call case to behave correctly:
  18 #
  19 #   perl -Mt::lib::ANFANG -e 'do "./t/lib/ANFANG.pm" or die ( $@ || $! )'
  20 #
  21 return 1 if $anfang_loaded;
  22
  23 # cover even more bases
  24 $INC{$_} ||= __FILE__ for (qw( ANFANG.pm t/lib/ANFANG.pm ./t/lib/ANFANG.pm ));
  25
  26 {
  27   # load-me-first sanity check
  28   if (
  29
  30     # nobody shut us off
  31     ! $ENV{DBICTEST_ANFANG_DEFANG}
  32
  33       and
  34
  35     # if these are set - all bets are off
  36     ! (
  37       $ENV{PERL5OPT}
  38         or
  39       scalar grep { $_ =~ m| \/ sitecustomize\.pl $ |x } keys %INC
  40     )
  41
  42       and
  43
  44     # -d:Confess / -d:TraceUse and the like
  45     ! $^P
  46
  47       and
  48
  49     # a ghetto way of recognizing cperl without loading Config.pm
  50     # the $] guard is there because touching $^V on pre-5.10 loads
  51     # the entire utf8 stack (wtf!!!)
  52     ( "$]" < 5.010 or $^V !~ /\d+c$/ )
  53
  54       and
  55
  56     # just don't check anything under RELEASE_TESTING
  57     # a naive approach would be to simply whitelist both
  58     # strict and warnings, but pre 5.10 there were even
  59     # more modules loaded by these two:
  60     #
  61     #   perlbrew exec perl -Mstrict -Mwarnings -e 'warn join "\n", sort keys %INC'
  62     #
  63     ! $ENV{RELEASE_TESTING}
  64
  65       and
  66
  67     my @undesirables = grep {
  68
  69       ($INC{$_}||'') ne __FILE__
  70
  71         and
  72
  73       # allow direct loads via -M
  74       $_ !~ m{^ DBICTest (?: /Schema )? \.pm $}x
  75
  76     } keys %INC
  77
  78   ) {
  79
  80     my ( $fr, @frame );
  81     while (@frame = caller(++$fr)) {
  82       last if $frame[1] !~ m{ (?: \A | [\/\\] ) t [\/\\] lib [\/\\] }x;
  83     }
  84
  85     die __FILE__ . " must be loaded before any other module (i.e. @{[ join ', ', map { qq('$_') } sort @undesirables ]}) at $frame[1] line $frame[2]\n";
  86   }
  87
  88
  89   if ( $ENV{DBICTEST_VERSION_WARNS_INDISCRIMINATELY} ) {
  90     my $ov = UNIVERSAL->can("VERSION");
  91
  92     require Carp;
  93
  94     # in case we loaded warnings.pm / used -w
  95     # ( do not do `no warnings ...` as it is also a load )
  96     local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /redefined/ };
  97
  98     *UNIVERSAL::VERSION = sub {
  99       Carp::carp( 'Argument "blah bleh bloh" isn\'t numeric in subroutine entry' );
 100       &$ov;
 101     };
 102   }
 103
 104
 105   if (
 106     $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION}
 107       or
 108     # keep it always on during CI
 109     (
 110       ($ENV{TRAVIS}||'') eq 'true'
 111         and
 112       ($ENV{TRAVIS_REPO_SLUG}||'') =~ m|\w+/dbix-class$|
 113     )
 114   ) {
 115     # two levels of if() because of taint mode tangling the %ENV-checks
 116     # with the require() call, sigh...
 117
 118     if ( eval { require Try::Tiny } ) {
 119       my $orig = \&Try::Tiny::try;
 120
 121       # in case we loaded warnings.pm / used -w
 122       # ( do not do `no warnings ...` as it is also a load )
 123       local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /redefined/ };
 124
 125       *Try::Tiny::try = sub (&;@) {
 126         my ($fr, $first_pkg) = 0;
 127         while( $first_pkg = caller($fr++) ) {
 128           last if $first_pkg !~ /^
 129             __ANON__
 130               |
 131             \Q(eval)\E
 132           $/x;
 133         }
 134
 135         if ($first_pkg =~ /DBIx::Class/) {
 136           require Test::Builder;
 137           Test::Builder->new->ok(0,
 138             'Using try{} within DBIC internals is a mistake - use dbic_internal_try{} instead'
 139           );
 140         }
 141
 142         goto $orig;
 143       };
 144     }
 145   }
 146 }
 147
 148
 149 unshift @INC, 't/lib';
 150
 151
 152 # everything expects this to be there
 153 ! -d 't/var'
 154   and
 155 (
 156   mkdir 't/var'
 157     or
 158   # creation is inherently racy
 159   do {
 160     my $err = $!;
 161     require Errno;
 162     die "Unable to create 't/var': $err\n"
 163       unless $err == Errno::EEXIST();
 164   }
 165 );
 166
 167
 168 # Back in ab340f7f ribasushi stupidly introduced a "did you check your deps"
 169 # verification tied very tightly to Module::Install. The check went away, and
 170 # so eventually will M::I, but bisecting can bring all of this back from the
 171 # dead. In order to reduce hair-pulling make sure that ./inc/ is always there
 172 -f 'Makefile.PL' and mkdir 'inc' and mkdir 'inc/.author';
 173
 174 END {
 175   if( my @finalest_tasks = (
 176
 177     ( !$ENV{DBICTEST_DIRTY_EXIT} ? () : sub {
 178
 179       my $exit = $?;
 180       require POSIX;
 181
 182       # Crucial flushes in case we are piping things out (e.g. prove)
 183       # Otherwise the last lines will never arrive at the receiver
 184       close($_) for \*STDOUT, \*STDERR;
 185
 186       POSIX::_exit($exit);
 187     } ),
 188
 189   )) {
 190
 191     # in the case of an early skip_all B may very well not have loaded
 192     unless( $INC{"B.pm"} ) {
 193       local ( $!, $^E, $?, $@ );
 194       require B;
 195     }
 196
 197     # Make sure we run after any cleanup in other END blocks
 198     # ( push-to-end twice in a row )
 199     push @{ B::end_av()->object_2svref }, sub {
 200       push @{ B::end_av()->object_2svref }, @finalest_tasks;
 201     }
 202   }
 203 }
 204
 205 # make absolutely sure this is last
 206 $anfang_loaded = 1;