[dbsrgits/DBIx-Class.git] / t / 00describe_environment.t

###
### 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;
DBICTest->init_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,
};

my $optdeps = {
  map
    { $_ => 1 }
    map
      { keys %{DBIx::Class::Optional::Dependencies->req_list_for($_)} }
      grep
        { $_ !~ /rdbms/ }
        keys %{DBIx::Class::Optional::Dependencies->req_group_list}
};
req_mod $_ for sort
  { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
  keys %$optdeps
;

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";

exit if ($ENV{TRAVIS}||'') eq 'true';

# 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";
Commit	Line	Data
0a70f4be	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
	7	BEGIN {
	8	if ($] < 5.010) {
	9
	10	# Pre-5.10 perls pollute %INC on unsuccesfull module
	11	# require, making it appear as if the module is already
	12	# loaded on subsequent require()s
	13	# Can't seem to find the exact RT/perldelta entry
	14	#
	15	# The reason we can't just use a sane, clean loader, is because
	16	# if a Module require()s another module the %INC will still
	17	# get filled with crap and we are back to square one. A global
	18	# fix is really the only way for this test, as we try to load
	19	# each available module separately, and have no control (nor
	20	# knowledge) over their common dependencies.
	21	#
	22	# we want to do this here, in the very beginning, before even
	23	# warnings/strict are loaded
	24
	25	unshift @INC, 't/lib';
	26	require DBICTest::Util::OverrideRequire;
	27
	28	DBICTest::Util::OverrideRequire::override_global_require( sub {
	29	my $res = eval { $_[0]->() };
	30	if ($@ ne '') {
	31	delete $INC{$_[1]};
	32	die $@;
	33	}
	34	return $res;
	35	} );
	36	}
	37	}
	38
	39	# Explicitly add 'lib' to the front of INC - this way we will
	40	# know without ambiguity what was loaded from the local untar
	41	# and what came from elsewhere
	42	use lib qw(lib t/lib);
	43
	44	use strict;
	45	use warnings;
	46
	47	use Test::More 'no_plan';
	48	use Config;
	49	use File::Find 'find';
	50	use Module::Runtime 'module_notional_filename';
b602aabd	51	use List::Util qw(max min);
0a70f4be	52	use ExtUtils::MakeMaker;
	53	use DBICTest::Util 'visit_namespaces';
	54
	55	# load these two to pull in the t/lib armada
	56	use DBICTest;
	57	use DBICTest::Schema;
	58	DBICTest->init_schema;
	59
	60	# do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
	61	sub req_mod ($) {
	62	# trap deprecation warnings and whatnot
	63	local $SIG{__WARN__} = sub {};
	64	local $@;
	65	eval "require $_[0]";
	66	}
	67
	68	sub say_err {
	69	print STDERR "\n", @_, "\n";
	70	}
	71
b602aabd	72	# needed for WeirdOS
	73	sub fixup_path ($) {
	74	return $_[0] unless ( $^O eq 'MSWin32' and $_[0] );
	75
	76	# sometimes we can get a short/longname mix, normalize everything to longnames
	77	my $fn = Win32::GetLongPathName($_[0]);
	78
	79	# Fixup (native) slashes in Config not matching (unixy) slashes in INC
	80	$fn =~ s\|\\\|/\|g;
	81
	82	$fn;
	83	}
	84
0a70f4be	85	my @lib_display_order = qw(
	86	sitearch
	87	sitelib
	88	vendorarch
	89	vendorlib
	90	archlib
	91	privlib
	92	);
	93	my $lib_paths = {
	94	(map
b602aabd	95	{ $Config{$_}
	96	? ( $_ => fixup_path( $Config{"${_}exp"} \|\| $Config{$_} ) )
	97	: ()
	98	}
0a70f4be	99	@lib_display_order
	100	),
	101
	102	# synthetic, for display
	103	'./lib' => 'lib',
	104	};
	105
	106	sub describe_fn {
	107	my $fn = shift;
	108
b602aabd	109	return '' if !defined $fn;
	110
	111	$fn = fixup_path( $fn );
	112
0a70f4be	113	$lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
	114	for @lib_display_order;
	115
	116	$fn;
	117	}
	118
	119	sub md5_of_fn {
	120	# we already checked for -r/-f, just bail if can't open
	121	open my $fh, '<:raw', $_[0] or return '';
	122	require Digest::MD5;
	123	Digest::MD5->new->addfile($fh)->hexdigest;
	124	}
	125
	126	# first run through lib and try to load anything we can find
	127	# within our own project
	128	find({
	129	wanted => sub {
	130	-f $_ or return;
	131
	132	# can't just `require $fn`, as we need %INC to be
	133	# populated properly
	134	my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
	135	or return;
	136
	137	req_mod join ('::', File::Spec->splitdir($mod));
	138	},
	139	no_chdir => 1,
	140	}, 'lib' );
	141
	142	# now run through OptDeps and attempt loading everything else
	143	#
	144	# some things needs to be sorted before other things
	145	# positive - load first
	146	# negative - load last
	147	my $load_weights = {
	148	# Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
	149	# clashes with libssl, and will segfault everything coming after them
	150	"DBD::Oracle" => -999,
	151	};
	152
	153	my $optdeps = {
	154	map
	155	{ $_ => 1 }
	156	map
	157	{ keys %{DBIx::Class::Optional::Dependencies->req_list_for($_)} }
	158	grep
	159	{ $_ !~ /rdbms/ }
	160	keys %{DBIx::Class::Optional::Dependencies->req_group_list}
	161	};
	162	req_mod $_ for sort
	163	{ ($load_weights->{$b}\|\|0) <=> ($load_weights->{$a}\|\|0) }
	164	keys %$optdeps
	165	;
	166
	167	my $has_versionpm = eval { require version };
	168
	169	# at this point we've loaded everything we ever could, let's drill through
	170	# the ENTIRE symtable and build a map of versions
	171	my $version_list = { perl => $] };
	172	visit_namespaces( action => sub {
b602aabd	173	no strict 'refs';
0a70f4be	174	my $pkg = shift;
	175
	176	# keep going, but nothing to see here
	177	return 1 if $pkg eq 'main';
	178
b602aabd	179	# private - not interested, including no further descent
0a70f4be	180	return 0 if $pkg =~ / (?: ^ \| :: ) _ /x;
0a70f4be	181
b602aabd	182	# not interested in no-VERSION-containing modules, nor synthetic classes
0a70f4be	183	return 1 if (
	184	! defined ${"${pkg}::VERSION"}
	185	or
	186	${"${pkg}::VERSION"} =~ /\Qset by base.pm/
	187	);
	188
	189	# make sure a version can be extracted, be noisy when it doesn't work
	190	# do this even if we are throwing away the result below in lieu of EUMM
	191	my $mod_ver = eval { $pkg->VERSION };
	192	if (my $err = $@) {
	193	$err =~ s/^/ /mg;
	194	say_err
	195	"Calling `$pkg->VERSION` resulted in an exception, which should never "
	196	. "happen - please file a bug with the distribution containing $pkg. "
b602aabd	197	. "Complete exception text below:\n\n$err"
0a70f4be	198	;
0a70f4be	199	}
b602aabd	200	elsif( ! defined $mod_ver or ! length $mod_ver ) {
	201	my $ret = defined $mod_ver
	202	? "the empty string ''"
	203	: "'undef'"
0a70f4be	204	;
0a70f4be	205
0a70f4be	206	say_err
b602aabd	207	"Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
	208	. "is defined, which should never happen - please file a bug with the "
	209	. "distribution containing $pkg."
0a70f4be	210	;
b602aabd	211
0a70f4be	212	undef $mod_ver;
	213	}
	214
	215	# if this is a real file - extract the version via EUMM whenever possible
	216	my $fn = $INC{module_notional_filename($pkg)};
	217
b602aabd	218	my $eumm_ver = (
	219	$fn
	220	and
	221	-f $fn
	222	and
	223	-r $fn
	224	and
	225	eval { MM->parse_version( $fn ) }
	226	) \|\| undef;
0a70f4be	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 @{[ describe_fn $fn ]} "
	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	$version_list->{$pkg} = $eumm_ver;
	255	}
	256	elsif( defined $mod_ver ) {
	257	$version_list->{$pkg} = $mod_ver;
	258	}
	259
	260	1;
	261	});
	262
b602aabd	263	# In retrospect it makes little sense to omit this information - just
	264	# show everything at all times.
	265	# Nevertheless leave the dead code, in case it turns out to be a bad idea...
	266	my $show_all = 1;
	267	#my $show_all = $ENV{PERL_DESCRIBE_ALL_DEPS} \|\| !DBICTest::RunMode->is_plain;
	268
0a70f4be	269	# compress identical versions as close to the root as we can
	270	# unless we are dealing with a smoker - in which case we want
	271	# to see every MD5 there is
b602aabd	272	unless ($show_all) {
0a70f4be	273	for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
	274	my $parent = $mod;
	275
	276	while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
	277	$version_list->{$parent}
	278	and
	279	$version_list->{$parent} eq $version_list->{$mod}
	280	and
	281	( ( delete $version_list->{$mod} ) or 1 )
	282	and
	283	last
	284	}
	285	}
	286	}
	287
	288	ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
	289
	290	exit if ($ENV{TRAVIS}\|\|'') eq 'true';
	291
	292	# sort stuff into @INC segments
	293	my $segments;
	294
	295	MODULE:
	296	for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
	297	my $fn = $INC{module_notional_filename($mod)};
	298
b602aabd	299	my $tuple = [ $mod ];
0a70f4be	300
b602aabd	301	if ( defined $fn && -f $fn && -r $fn ) {
b602aabd	302	push @$tuple, ( $fn = fixup_path($fn) );
0a70f4be	303
0a70f4be	304	for my $lib (@lib_display_order, './lib') {
	305	if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) {
	306	push @{$segments->{$lib}}, $tuple;
	307	next MODULE;
	308	}
	309	}
	310	}
	311
	312	# fallthrough for anything without a physical filename, or unknown lib
	313	push @{$segments->{''}}, $tuple;
	314	}
	315
	316	# diag the result out
b602aabd	317	my $max_ver_len = max map
	318	{ length $_ }
	319	( values %$version_list, 'xxx.yyyzzz_bbb' )
	320	;
0a70f4be	321	my $max_mod_len = max map { length $_ } keys %$version_list;
0a70f4be	322
b602aabd	323	my $discl = <<'EOD';
	324
	325	Versions of all loadable modules within both the core and OPTIONAL dependency chains present on this system
	326	Note that MANY of these modules will NEVER be loaded during normal operation of DBIx::Class
	327	EOD
	328
	329	$discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n"
	330	unless $show_all;
	331
	332	diag $discl;
	333
	334	diag "\n";
	335
0a70f4be	336	for my $seg ( '', @lib_display_order, './lib' ) {
	337	next unless $segments->{$seg};
	338
b602aabd	339	diag sprintf "=== %s ===\n\n",
0a70f4be	340	$seg
0a70f4be	341	? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
b602aabd	342	: 'Misc versions'
0a70f4be	343	;
0a70f4be	344
b602aabd	345	diag sprintf (
b602aabd	346	"%s %s%s\n",
0a70f4be	347	$max_ver_len => $version_list->{$_->[0]},
	348	-$max_mod_len => $_->[0],
	349	($_->[1]
b602aabd	350	? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
0a70f4be	351	: ''
	352	),
	353	) for @{$segments->{$seg}};
	354
b602aabd	355	diag "\n\n"
0a70f4be	356	}
0a70f4be	357
b602aabd	358	diag "$discl\n";