t/00describe_environment.t

   1 ###
   2 ### This version is rather 5.8-centric, because DBIC itself is 5.8
   3 ### It certainly can be rewritten to degrade well on 5.6
   4 ###
   5
   6 BEGIN {
   7   if ($] < 5.010) {
   8
   9     # Pre-5.10 perls pollute %INC on unsuccesfull module
  10     # require, making it appear as if the module is already
  11     # loaded on subsequent require()s
  12     # Can't seem to find the exact RT/perldelta entry
  13     #
  14     # The reason we can't just use a sane, clean loader, is because
  15     # if a Module require()s another module the %INC will still
  16     # get filled with crap and we are back to square one. A global
  17     # fix is really the only way for this test, as we try to load
  18     # each available module separately, and have no control (nor
  19     # knowledge) over their common dependencies.
  20     #
  21     # we want to do this here, in the very beginning, before even
  22     # warnings/strict are loaded
  23
  24     unshift @INC, 't/lib';
  25     require DBICTest::Util::OverrideRequire;
  26
  27     DBICTest::Util::OverrideRequire::override_global_require( sub {
  28       my $res = eval { $_[0]->() };
  29       if ($@ ne '') {
  30         delete $INC{$_[1]};
  31         die $@;
  32       }
  33       return $res;
  34     } );
  35   }
  36 }
  37
  38 # Explicitly add 'lib' to the front of INC - this way we will
  39 # know without ambiguity what was loaded from the local untar
  40 # and what came from elsewhere
  41 use lib qw(lib t/lib);
  42
  43 use strict;
  44 use warnings;
  45
  46 use Test::More 'no_plan';
  47 use Config;
  48 use File::Find 'find';
  49 use Module::Runtime 'module_notional_filename';
  50 use List::Util qw(max min);
  51 use ExtUtils::MakeMaker;
  52 use DBICTest::Util 'visit_namespaces';
  53
  54 # load these two to pull in the t/lib armada
  55 use DBICTest;
  56 use DBICTest::Schema;
  57
  58
  59 my $known_libpaths = {
  60   SA => {
  61     config_key => 'sitearch',
  62   },
  63   SL => {
  64     config_key => 'sitelib',
  65   },
  66   VA => {
  67     config_key => 'vendorarch',
  68   },
  69   VL => {
  70     config_key => 'vendorlib',
  71   },
  72   PA => {
  73     config_key => 'archlib',
  74   },
  75   PL => {
  76     config_key => 'privlib',
  77   },
  78   INC => {
  79     relpath => './inc',
  80   },
  81   LIB => {
  82     relpath => './lib',
  83   },
  84   HOME => {
  85     relpath => '~',
  86     full_path => full_path (
  87       eval { require File::HomeDir and File::HomeDir->my_home }
  88         ||
  89       $ENV{HOME}
  90         ||
  91       glob('~')
  92     ),
  93   },
  94 };
  95
  96 for my $k (keys %$known_libpaths) {
  97   my $v = $known_libpaths->{$k};
  98
  99   # never use home as a found-in-dir marker - it is too broad
 100   # HOME is only used by the shortener
 101   $v->{abbrev} = $k unless $k eq 'HOME';
 102
 103   unless ( $v->{full_path} ) {
 104     if ( $v->{relpath} ) {
 105       $v->{full_path} = full_path( $v->{relpath} );
 106     }
 107     elsif ( $Config{ $v->{config_key} || '' } ) {
 108       $v->{full_path} = full_path (
 109         $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}}
 110       );
 111     }
 112   }
 113
 114   delete $known_libpaths->{$k} unless $v->{full_path} and -d $v->{full_path};
 115 }
 116
 117
 118 # first run through lib/ and *try* to load anything we can find
 119 # within our own project
 120 find({
 121   wanted => sub {
 122     -f $_ or return;
 123
 124     # can't just `require $fn`, as we need %INC to be
 125     # populated properly
 126     my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
 127       or return;
 128
 129     try_module_require(join ('::', File::Spec->splitdir($mod)) )
 130   },
 131   no_chdir => 1,
 132 }, 'lib' );
 133
 134
 135
 136 # now run through OptDeps and attempt loading everything else
 137 #
 138 # some things needs to be sorted before other things
 139 # positive - load first
 140 # negative - load last
 141 my $load_weights = {
 142   # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
 143   # clashes with libssl, and will segfault everything coming after them
 144   "DBD::Oracle" => -999,
 145 };
 146 try_module_require($_) for sort
 147   { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
 148   keys %{
 149     DBIx::Class::Optional::Dependencies->req_list_for([
 150       grep
 151         # some DBDs are notoriously problematic to load
 152         # hence only show stuff based on test_rdbms which will
 153         # take into account necessary ENVs
 154         { $_ !~ /^ (?: rdbms | dist )_ /x }
 155         keys %{DBIx::Class::Optional::Dependencies->req_group_list}
 156     ])
 157   }
 158 ;
 159
 160
 161 # at this point we've loaded everything we ever could, let's drill through
 162 # the *ENTIRE* symtable and build a map of versions
 163 my $has_versionpm = eval { require version };
 164 my $versioned_modules = {
 165   perl => { version => $], full_path => $^X }
 166 };
 167 my $seen_known_libs;
 168 visit_namespaces( action => sub {
 169   no strict 'refs';
 170   my $pkg = shift;
 171
 172   # keep going, but nothing to see here
 173   return 1 if $pkg eq 'main';
 174
 175   # private - not interested, including no further descent
 176   return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
 177
 178   # not interested in no-VERSION-containing modules, nor synthetic classes
 179   return 1 if (
 180     ! defined ${"${pkg}::VERSION"}
 181       or
 182     ${"${pkg}::VERSION"} =~ /\Qset by base.pm/
 183   );
 184
 185   # make sure a version can be extracted, be noisy when it doesn't work
 186   # do this even if we are throwing away the result below in lieu of EUMM
 187   my $mod_ver = eval { $pkg->VERSION };
 188   if (my $err = $@) {
 189     $err =~ s/^/  /mg;
 190     say_err (
 191       "Calling `$pkg->VERSION` resulted in an exception, which should never "
 192     . "happen - please file a bug with the distribution containing $pkg. "
 193     . "Complete exception text below:\n\n$err"
 194     );
 195   }
 196   elsif( ! defined $mod_ver or ! length $mod_ver ) {
 197     my $ret = defined $mod_ver
 198       ? "the empty string ''"
 199       : "'undef'"
 200     ;
 201
 202     say_err (
 203       "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
 204     . "is defined, which should never happen - please file a bug with the "
 205     . "distribution containing $pkg."
 206     );
 207
 208     undef $mod_ver;
 209   }
 210
 211   # if this is a real file - extract the version via EUMM whenever possible
 212   my $fn = $INC{module_notional_filename($pkg)};
 213
 214   my $full_path;
 215
 216   my $eumm_ver = (
 217     $fn
 218       and
 219     -f $fn
 220       and
 221     -r $fn
 222       and
 223     $full_path = full_path($fn)
 224       and
 225     eval { MM->parse_version( $fn ) }
 226   ) || undef;
 227
 228   if (
 229     $has_versionpm
 230       and
 231     defined $eumm_ver
 232       and
 233     defined $mod_ver
 234       and
 235     $eumm_ver ne $mod_ver
 236       and
 237     (
 238       ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
 239         !=
 240       ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
 241     )
 242   ) {
 243     say_err (
 244       "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
 245     . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $full_path ) ]} "
 246     . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
 247     . "This should never happen - please check whether this is still present "
 248     . "in the latest version, and then file a bug with the distribution "
 249     . "containing $pkg."
 250     );
 251   }
 252
 253   if( defined $eumm_ver ) {
 254     $versioned_modules->{$pkg} = { version => $eumm_ver };
 255   }
 256   elsif( defined $mod_ver ) {
 257     $versioned_modules->{$pkg} = { version => $mod_ver };
 258   }
 259
 260   # add the path and a "where-from" marker if any
 261   if ( $full_path and my $slot = $versioned_modules->{$pkg} ) {
 262     $slot->{full_path} = $full_path;
 263
 264     if ( my $abbr = ( matching_known_lib( $full_path ) || {} )->{abbrev} ) {
 265       $slot->{from_known_lib} = $abbr;
 266       $seen_known_libs->{$abbr} = 1;
 267     }
 268   }
 269
 270   1;
 271 });
 272
 273 # compress identical versions sourced from ./lib as close to the root as we can
 274 for my $mod ( sort { length($b) <=> length($a) } keys %$versioned_modules ) {
 275   ($versioned_modules->{$mod}{from_known_lib}||'') eq 'LIB'
 276     or next;
 277
 278   my $parent = $mod;
 279
 280   while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
 281     $versioned_modules->{$parent}
 282       and
 283     $versioned_modules->{$parent}{version} eq $versioned_modules->{$mod}{version}
 284       and
 285     ($versioned_modules->{$parent}{from_known_lib}||'') eq 'LIB'
 286       and
 287     delete $versioned_modules->{$mod}
 288       and
 289     last
 290   }
 291 }
 292
 293 ok 1, (scalar keys %$versioned_modules) . " distinctly versioned modules found";
 294
 295 # do not announce anything under ci - we are watching for STDERR silence
 296 exit if DBICTest::RunMode->is_ci;
 297
 298
 299 # diag the result out
 300 my $max_ver_len = max map
 301   { length "$_" }
 302   ( 'xxx.yyyzzz_bbb', map { $_->{version} } values %$versioned_modules )
 303 ;
 304 my $max_mod_len = max map { length $_ } keys %$versioned_modules;
 305 my $max_marker_len = max map { length $_ } keys %{ $seen_known_libs || {} };
 306
 307 my $discl = <<'EOD';
 308
 309 List of loadable modules specifying a version within both the core and *OPTIONAL* dependency chains present on this system
 310 Note that *MANY* of these modules will *NEVER* be loaded during normal operation of DBIx::Class
 311 (modules sourced from ./lib with versions identical to their parent namespace were omitted for brevity)
 312 EOD
 313
 314 diag "\n$discl\n";
 315
 316 if ($seen_known_libs) {
 317   diag "Sourcing markers:\n";
 318
 319   diag $_ for
 320     map
 321       {
 322         sprintf "  %*s: %s",
 323           $max_marker_len => $_->{abbrev},
 324           ($_->{config_key} ? "\$Config{$_->{config_key}}" : $_->{relpath} )
 325       }
 326       @{$known_libpaths}{ sort keys %$seen_known_libs }
 327   ;
 328
 329   diag "\n";
 330 }
 331
 332 diag "=============================\n";
 333
 334 diag sprintf (
 335   "%*s  %*s  %*s%s\n",
 336   $max_marker_len+2 => $versioned_modules->{$_}{from_known_lib} || '',
 337   $max_ver_len => $versioned_modules->{$_}{version},
 338   -$max_mod_len => $_,
 339   ($versioned_modules->{$_}{full_path}
 340     ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ get_md5( $versioned_modules->{$_}{full_path} ) ]} ]"
 341     : ''
 342   ),
 343 ) for sort { lc($a) cmp lc($b) } keys %$versioned_modules;
 344
 345 diag "=============================\n$discl\n";
 346
 347 exit 0;
 348
 349
 350
 351 sub say_err { print STDERR "\n", @_, "\n" };
 352
 353 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
 354 sub try_module_require {
 355   # trap deprecation warnings and whatnot
 356   local $SIG{__WARN__} = sub {};
 357   local $@;
 358   eval "require $_[0]";
 359 }
 360
 361 sub full_path {
 362   return '' unless ( defined $_[0] and -e $_[0] );
 363
 364   my $fn = Cwd::abs_path($_[0]);
 365
 366   if ( $^O eq 'MSWin32' and $fn ) {
 367
 368     # sometimes we can get a short/longname mix, normalize everything to longnames
 369     $fn = Win32::GetLongPathName($fn);
 370
 371     # Fixup (native) slashes in Config not matching (unixy) slashes in INC
 372     $fn =~ s|\\|/|g;
 373   }
 374
 375   $fn;
 376 }
 377
 378 sub shorten_fn {
 379   my $fn = shift;
 380
 381   my $l = matching_known_lib( $fn )
 382     or return $fn;
 383
 384   if ($l->{relpath}) {
 385     $fn =~ s/\Q$l->{full_path}\E/$l->{relpath}/;
 386   }
 387   elsif ($l->{config_key}) {
 388     $fn =~ s/\Q$l->{full_path}\E/<<$l->{config_key}>>/;
 389   }
 390
 391   $fn;
 392 }
 393
 394 sub matching_known_lib {
 395   my $fn = full_path( $_[0] )
 396     or return '';
 397
 398   for my $l (
 399     sort { length( $b->{full_path} ) <=> length( $a->{full_path} ) }
 400     values %$known_libpaths
 401   ) {
 402     return { %$l } if 0 == index( $fn, $l->{full_path} );
 403   }
 404 }
 405
 406 sub get_md5 {
 407   # we already checked for -r/-f, just bail if can't open
 408   open my $fh, '<:raw', $_[0] or return '';
 409   require Digest::MD5;
 410   Digest::MD5->new->addfile($fh)->hexdigest;
 411 }