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 # Very important to grab the snapshot early, as we will be reporting
   7 # the INC indices from the POV of whoever ran the script, *NOT* from
   8 # the POV of the internals
   9 my @initial_INC;
  10 BEGIN {
  11   @initial_INC = @INC;
  12 }
  13
  14 BEGIN {
  15   local @INC = ( 't/lib', @INC );
  16
  17
  18   if ( "$]" < 5.010) {
  19
  20     # Pre-5.10 perls pollute %INC on unsuccesfull module
  21     # require, making it appear as if the module is already
  22     # loaded on subsequent require()s
  23     # Can't seem to find the exact RT/perldelta entry
  24     #
  25     # The reason we can't just use a sane, clean loader, is because
  26     # if a Module require()s another module the %INC will still
  27     # get filled with crap and we are back to square one. A global
  28     # fix is really the only way for this test, as we try to load
  29     # each available module separately, and have no control (nor
  30     # knowledge) over their common dependencies.
  31     #
  32     # we want to do this here, in the very beginning, before even
  33     # warnings/strict are loaded
  34
  35     require DBICTest::Util::OverrideRequire;
  36
  37     DBICTest::Util::OverrideRequire::override_global_require( sub {
  38       my $res = eval { $_[0]->() };
  39       if ($@ ne '') {
  40         delete $INC{$_[1]};
  41         die $@;
  42       }
  43       return $res;
  44     } );
  45
  46   }
  47
  48   require DBICTest::RunMode;
  49   require DBICTest::Util;
  50 }
  51
  52 use strict;
  53 use warnings;
  54
  55 use Test::More 'no_plan';
  56 use Config;
  57 use File::Find 'find';
  58 use Digest::MD5 ();
  59 use Cwd 'abs_path';
  60 use File::Spec;
  61 use List::Util 'max';
  62 use ExtUtils::MakeMaker;
  63
  64 use DBIx::Class::Optional::Dependencies;
  65
  66 my $known_paths = {
  67   SA => {
  68     config_key => 'sitearch',
  69   },
  70   SL => {
  71     config_key => 'sitelib',
  72   },
  73   SS => {
  74     config_key => 'sitelib_stem',
  75     match_order => 1,
  76   },
  77   SP => {
  78     config_key => 'siteprefix',
  79     match_order => 2,
  80   },
  81   VA => {
  82     config_key => 'vendorarch',
  83   },
  84   VL => {
  85     config_key => 'vendorlib',
  86   },
  87   VS => {
  88     config_key => 'vendorlib_stem',
  89     match_order => 3,
  90   },
  91   VP => {
  92     config_key => 'vendorprefix',
  93     match_order => 4,
  94   },
  95   PA => {
  96     config_key => 'archlib',
  97   },
  98   PL => {
  99     config_key => 'privlib',
 100   },
 101   PP => {
 102     config_key => 'prefix',
 103     match_order => 5,
 104   },
 105   BLA => {
 106     rel_path => './blib/arch',
 107     skip_unversioned_modules => 1,
 108   },
 109   BLL => {
 110     rel_path => './blib/lib',
 111     skip_unversioned_modules => 1,
 112   },
 113   INC => {
 114     rel_path => './inc',
 115   },
 116   LIB => {
 117     rel_path => './lib',
 118     skip_unversioned_modules => 1,
 119   },
 120   T => {
 121     rel_path => './t',
 122     skip_unversioned_modules => 1,
 123   },
 124   XT => {
 125     rel_path => './xt',
 126     skip_unversioned_modules => 1,
 127   },
 128   CWD => {
 129     rel_path => '.',
 130   },
 131   HOME => {
 132     rel_path => '~',
 133     abs_unix_path => abs_unix_path (
 134       eval { require File::HomeDir and File::HomeDir->my_home }
 135         ||
 136       $ENV{USERPROFILE}
 137         ||
 138       $ENV{HOME}
 139         ||
 140       glob('~')
 141     ),
 142   },
 143 };
 144
 145 for my $k (keys %$known_paths) {
 146   my $v = $known_paths->{$k};
 147
 148   # never use home as a found-in-dir marker - it is too broad
 149   # HOME is only used by the shortener
 150   $v->{marker} = $k unless $k eq 'HOME';
 151
 152   unless ( $v->{abs_unix_path} ) {
 153     if ( $v->{rel_path} ) {
 154       $v->{abs_unix_path} = abs_unix_path( $v->{rel_path} );
 155     }
 156     elsif ( $Config{ $v->{config_key} || '' } ) {
 157       $v->{abs_unix_path} = abs_unix_path (
 158         $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}}
 159       );
 160     }
 161   }
 162
 163   delete $known_paths->{$k} unless $v->{abs_unix_path} and -d $v->{abs_unix_path};
 164 }
 165 my $seen_markers = {};
 166
 167 # first run through lib/ and *try* to load anything we can find
 168 # within our own project
 169 find({
 170   wanted => sub {
 171     -f $_ or return;
 172
 173     $_ =~ m|lib/DBIx/Class/_TempExtlib| and return;
 174
 175     # can't just `require $fn`, as we need %INC to be
 176     # populated properly
 177     my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
 178       or return;
 179
 180     try_module_require(join ('::', File::Spec->splitdir($mod)) )
 181   },
 182   no_chdir => 1,
 183 }, 'lib' );
 184
 185
 186
 187 # now run through OptDeps and attempt loading everything else
 188 #
 189 # some things needs to be sorted before other things
 190 # positive - load first
 191 # negative - load last
 192 my $load_weights = {
 193   # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
 194   # clashes with libssl, and will segfault everything coming after them
 195   "DBD::Oracle" => -999,
 196 };
 197
 198 my @known_modules = sort
 199   { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
 200   qw( Data::Dumper ),
 201   map
 202     { $_ => 1 }
 203     map
 204       { keys %{ DBIx::Class::Optional::Dependencies->req_list_for($_) } }
 205       grep
 206         # some DBDs are notoriously problematic to load
 207         # hence only show stuff based on test_rdbms which will
 208         # take into account necessary ENVs
 209         { $_ !~ /^ (?: rdbms | dist )_ /x }
 210         keys %{DBIx::Class::Optional::Dependencies->req_group_list}
 211 ;
 212
 213 try_module_require($_) for @known_modules;
 214
 215 my $has_versionpm = eval { require version };
 216
 217
 218 # At this point we've loaded everything we ever could, but some modules
 219 # (understandably) crapped out. For an even more thorough report, note
 220 # everthing present in @INC we excplicitly know about (via OptDeps)
 221 # *even though* it didn't load
 222 my $known_failed_loads;
 223
 224 for my $mod (@known_modules) {
 225   my $inc_key = module_notional_filename($mod);
 226   next if defined $INC{$inc_key};
 227
 228   if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) {
 229     $known_failed_loads->{$mod} = abs_unix_path( "$INC[$idx]/$inc_key" );
 230   }
 231
 232 }
 233
 234 my $perl = 'perl';
 235
 236 # This is a cool idea, but the line is too long even with shortening :(
 237 #
 238 #for my $i ( 1 .. $Config{config_argc} ) {
 239 #  my $conf_arg = $Config{"config_arg$i"};
 240 #  $conf_arg =~ s!
 241 #    \= (.+)
 242 #  !
 243 #    '=' . shorten_fn($1)
 244 #  !ex;
 245 #
 246 #  $perl .= " $conf_arg";
 247 #}
 248
 249 my $interesting_modules = {
 250   # pseudo module
 251   $perl => {
 252     version => $],
 253     abs_unix_path => abs_unix_path($^X),
 254   }
 255 };
 256
 257
 258 # drill through the *ENTIRE* symtable and build a map of interesting modules
 259 DBICTest::Util::visit_namespaces( action => sub {
 260   no strict 'refs';
 261   my $pkg = shift;
 262
 263   # keep going, but nothing to see here
 264   return 1 if $pkg eq 'main';
 265
 266   # private - not interested, including no further descent
 267   return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
 268
 269   my $inc_key = module_notional_filename($pkg);
 270
 271   my $abs_unix_path = (
 272     $INC{$inc_key}
 273       and
 274     -f $INC{$inc_key}
 275       and
 276     -r $INC{$inc_key}
 277       and
 278     abs_unix_path($INC{$inc_key})
 279   );
 280
 281   # handle versions first (not interested in synthetic classes)
 282   if (
 283     defined ${"${pkg}::VERSION"}
 284       and
 285     ${"${pkg}::VERSION"} !~ /\Qset by base.pm/
 286   ) {
 287
 288     # make sure a version can be extracted, be noisy when it doesn't work
 289     # do this even if we are throwing away the result below in lieu of EUMM
 290     my $mod_ver = eval { $pkg->VERSION };
 291
 292     if (my $err = $@) {
 293       $err =~ s/^/  /mg;
 294       say_err (
 295         "Calling `$pkg->VERSION` resulted in an exception, which should never "
 296       . "happen - please file a bug with the distribution containing $pkg. "
 297       . "Complete exception text below:\n\n$err"
 298       );
 299     }
 300     elsif( ! defined $mod_ver or ! length $mod_ver ) {
 301       my $ret = defined $mod_ver
 302         ? "the empty string ''"
 303         : "'undef'"
 304       ;
 305
 306       say_err (
 307         "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
 308       . "is defined, which should never happen - please file a bug with the "
 309       . "distribution containing $pkg."
 310       );
 311
 312       undef $mod_ver;
 313     }
 314
 315     if (
 316       $abs_unix_path
 317         and
 318       defined ( my $eumm_ver = eval { MM->parse_version( $abs_unix_path ) } )
 319     ) {
 320
 321       # can only run the check reliably if v.pm is there
 322       if (
 323         $has_versionpm
 324           and
 325         defined $mod_ver
 326           and
 327         $eumm_ver ne $mod_ver
 328           and
 329         (
 330           ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
 331             !=
 332           ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
 333         )
 334       ) {
 335         say_err (
 336           "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
 337         . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $abs_unix_path ) ]} "
 338         . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
 339         . "This should never happen - please check whether this is still present "
 340         . "in the latest version, and then file a bug with the distribution "
 341         . "containing $pkg."
 342         );
 343       }
 344
 345       $interesting_modules->{$pkg}{version} = $eumm_ver;
 346     }
 347     elsif( defined $mod_ver ) {
 348
 349       $interesting_modules->{$pkg}{version} = $mod_ver;
 350     }
 351   }
 352   elsif ( $known_failed_loads->{$pkg} ) {
 353     $abs_unix_path = $known_failed_loads->{$pkg};
 354     $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!';
 355   }
 356
 357   if ($abs_unix_path) {
 358     my ($marker, $initial_inc_idx);
 359
 360     my $current_inc_idx = module_found_at_inc_index($pkg, \@INC);
 361     my $p = subpath_of_known_path( $abs_unix_path );
 362
 363     if (
 364       defined $current_inc_idx
 365         and
 366       $p->{marker}
 367         and
 368       abs_unix_path($INC[$current_inc_idx]) eq $p->{abs_unix_path}
 369     ) {
 370       $marker = $p->{marker};
 371     }
 372     elsif (defined ( $initial_inc_idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) {
 373       $marker = "\$INC[$initial_inc_idx]";
 374     }
 375
 376     # we are only interested if there was a declared version already above
 377     # OR if the module came from somewhere other than skip_unversioned_modules
 378     if (
 379       $marker
 380         and
 381       (
 382         $interesting_modules->{$pkg}
 383           or
 384         !$p->{skip_unversioned_modules}
 385       )
 386     ) {
 387       $interesting_modules->{$pkg}{source_marker} = $marker;
 388       $seen_markers->{$marker} = 1;
 389     }
 390
 391     # at this point only fill in the path (md5 calc) IFF it is interesting
 392     # in any respect
 393     $interesting_modules->{$pkg}{abs_unix_path} = $abs_unix_path
 394       if $interesting_modules->{$pkg};
 395   }
 396
 397   1;
 398 });
 399
 400 # compress identical versions sourced from ./blib, ./lib, ./t and ./xt
 401 # as close to the root of a namespace as we can
 402 purge_identically_versioned_submodules_with_markers([ map {
 403   ( $_->{skip_unversioned_modules} && $_->{marker} ) || ()
 404 } values %$known_paths ]);
 405
 406 ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found";
 407
 408 # do not announce anything under ci - we are watching for STDERR silence
 409 exit 0 if DBICTest::RunMode->is_ci;
 410
 411
 412 # diag the result out
 413 my $max_ver_len = max map
 414   { length "$_" }
 415   ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules )
 416 ;
 417 my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers );
 418
 419 my $discl = <<'EOD';
 420
 421 List of loadable modules within both the core and *OPTIONAL* dependency chains
 422 present on this system (modules sourced from ./blib, ./lib, ./t, and ./xt
 423 with versions identical to their parent namespace were omitted for brevity)
 424
 425     *** Note that *MANY* of these modules will *NEVER* be loaded ***
 426             *** during normal operation of DBIx::Class ***
 427 EOD
 428
 429 # pre-assemble everything and print it in one shot
 430 # makes it less likely for parallel test execution to insert bogus lines
 431 my $final_out = "\n$discl\n";
 432
 433 $final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n";
 434
 435 my $in_inc_skip;
 436 for (0.. $#initial_INC) {
 437
 438   my $shortname = shorten_fn( $initial_INC[$_] );
 439
 440   # when *to* print a line of INC
 441   if (
 442     ! $ENV{AUTOMATED_TESTING}
 443       or
 444     @initial_INC < 11
 445       or
 446     $seen_markers->{"\$INC[$_]"}
 447       or
 448     ! -e $shortname
 449       or
 450     ! File::Spec->file_name_is_absolute($shortname)
 451   ) {
 452     $in_inc_skip = 0;
 453     $final_out .= sprintf ( "% 3s: %s\n",
 454       $_,
 455       $shortname
 456     );
 457   }
 458   elsif(! $in_inc_skip++) {
 459     $final_out .= "  ...\n";
 460   }
 461 }
 462
 463 $final_out .= "\n";
 464
 465 if (my @seen_known_paths = grep { $known_paths->{$_} } keys %$seen_markers) {
 466
 467   $final_out .= join "\n", 'Sourcing markers:', (map
 468     {
 469       sprintf "%*s: %s",
 470         $max_marker_len => $_->{marker},
 471         ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{rel_path}/" )
 472     }
 473     sort
 474       {
 475         !!$b->{config_key} cmp !!$a->{config_key}
 476           or
 477         ( $a->{marker}||'') cmp ($b->{marker}||'')
 478       }
 479       @{$known_paths}{@seen_known_paths}
 480   ), '', '';
 481
 482 }
 483
 484 $final_out .= "=============================\n";
 485
 486 $final_out .= join "\n", (map
 487   { sprintf (
 488     "%*s  %*s  %*s%s",
 489     $max_marker_len => $interesting_modules->{$_}{source_marker} || '',
 490     $max_ver_len => ( defined $interesting_modules->{$_}{version}
 491       ? $interesting_modules->{$_}{version}
 492       : ''
 493     ),
 494     -78 => $_,
 495     ($interesting_modules->{$_}{abs_unix_path}
 496       ? "  [ MD5: @{[ get_md5( $interesting_modules->{$_}{abs_unix_path} ) ]} ]"
 497       : "! -f \$INC{'@{[ module_notional_filename($_) ]}'}"
 498     ),
 499   ) }
 500   sort { lc($a) cmp lc($b) } keys %$interesting_modules
 501 ), '';
 502
 503 $final_out .= "=============================\n$discl\n\n";
 504
 505 diag $final_out;
 506
 507 exit 0;
 508
 509
 510
 511 sub say_err { print STDERR "\n", @_, "\n\n" };
 512
 513 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
 514 sub try_module_require {
 515   # trap deprecation warnings and whatnot
 516   local $SIG{__WARN__} = sub {};
 517   local $@;
 518   eval "require $_[0]";
 519 }
 520
 521 sub abs_unix_path {
 522   return '' unless (
 523     defined $_[0]
 524       and
 525     ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) )
 526   );
 527
 528   # File::Spec's rel2abs does not resolve symlinks
 529   # we *need* to look at the filesystem to be sure
 530   my $abs_fn = abs_path($_[0]);
 531
 532   if ( $^O eq 'MSWin32' and $abs_fn ) {
 533
 534     # sometimes we can get a short/longname mix, normalize everything to longnames
 535     $abs_fn = Win32::GetLongPathName($abs_fn);
 536
 537     # Fixup (native) slashes in Config not matching (unixy) slashes in INC
 538     $abs_fn =~ s|\\|/|g;
 539   }
 540
 541   $abs_fn;
 542 }
 543
 544 sub shorten_fn {
 545   my $fn = shift;
 546
 547   my $abs_fn = abs_unix_path($fn);
 548
 549   if (my $p = subpath_of_known_path( $fn ) ) {
 550     $abs_fn =~ s| (?<! / ) $|/|x
 551       if -d $abs_fn;
 552
 553     if ($p->{rel_path}) {
 554       $abs_fn =~ s!\Q$p->{abs_unix_path}!$p->{rel_path}!
 555         and return $abs_fn;
 556     }
 557     elsif ($p->{config_key}) {
 558       $abs_fn =~ s!\Q$p->{abs_unix_path}!<<$p->{marker}>>!
 559         and
 560       $seen_markers->{$p->{marker}} = 1
 561         and
 562       return $abs_fn;
 563     }
 564   }
 565
 566   # we got so far - not a known path
 567   # return the unixified version it if was absolute, leave as-is otherwise
 568   my $rv = ( $abs_fn and File::Spec->file_name_is_absolute( $fn ) )
 569     ? $abs_fn
 570     : $fn
 571   ;
 572
 573   $rv = "( ! -e ) $rv" unless -e $rv;
 574
 575   return $rv;
 576 }
 577
 578 sub subpath_of_known_path {
 579   my $abs_fn = abs_unix_path( $_[0] )
 580     or return '';
 581
 582   for my $p (
 583     sort {
 584       length( $b->{abs_unix_path} ) <=> length( $a->{abs_unix_path} )
 585         or
 586       ( $a->{match_order} || 0 ) <=> ( $b->{match_order} || 0 )
 587     }
 588     values %$known_paths
 589   ) {
 590     # run through the matcher twice - first always append a /
 591     # then try without
 592     # important to avoid false positives
 593     for my $suff ( '/', '' ) {
 594       return { %$p } if 0 == index( $abs_fn, "$p->{abs_unix_path}$suff" );
 595     }
 596   }
 597 }
 598
 599 sub module_found_at_inc_index {
 600   my ($mod, $inc_dirs) = @_;
 601
 602   return undef unless @$inc_dirs;
 603
 604   my $fn = module_notional_filename($mod);
 605
 606   # trust INC if it specifies an existing path
 607   if( -f ( my $existing_path = abs_unix_path( $INC{$fn} ) ) ) {
 608     for my $i ( 0 .. $#$inc_dirs ) {
 609
 610       # searching from here on out won't mean anything
 611       # FIXME - there is actually a way to interrogate this safely, but
 612       # that's a fight for another day
 613       return undef if length ref $inc_dirs->[$i];
 614
 615       return $i
 616         if 0 == index( $existing_path, abs_unix_path( $inc_dirs->[$i] ) . '/' );
 617     }
 618   }
 619
 620   for my $i ( 0 .. $#$inc_dirs ) {
 621
 622     if (
 623       -d $inc_dirs->[$i]
 624         and
 625       -f "$inc_dirs->[$i]/$fn"
 626         and
 627       -r "$inc_dirs->[$i]/$fn"
 628     ) {
 629       return $i;
 630     }
 631   }
 632
 633   return undef;
 634 }
 635
 636 sub purge_identically_versioned_submodules_with_markers {
 637   my $markers = shift;
 638
 639   return unless @$markers;
 640
 641   for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) {
 642
 643     next unless defined $interesting_modules->{$mod}{version};
 644
 645     my $marker = $interesting_modules->{$mod}{source_marker}
 646       or next;
 647
 648     next unless grep { $marker eq $_ } @$markers;
 649
 650     my $parent = $mod;
 651
 652     while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
 653       $interesting_modules->{$parent}
 654         and
 655       ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version}
 656         and
 657       ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker}
 658         and
 659     delete $interesting_modules->{$mod}
 660         and
 661       last
 662     }
 663   }
 664 }
 665
 666 sub module_notional_filename {
 667   (my $fn = $_[0] . '.pm') =~ s|::|/|g;
 668   $fn;
 669 }
 670
 671 sub get_md5 {
 672   # we already checked for -r/-f, just bail if can't open
 673   open my $fh, '<:raw', $_[0] or return '';
 674   Digest::MD5->new->addfile($fh)->hexdigest;
 675 }