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

# 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";
Commit	Line	Data
cebc0cc8	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';
4bfba4ee	51	use List::Util qw(max min);
cebc0cc8	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
	59	# do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
	60	sub req_mod ($) {
	61	# trap deprecation warnings and whatnot
	62	local $SIG{__WARN__} = sub {};
	63	local $@;
	64	eval "require $_[0]";
	65	}
	66
	67	sub say_err {
	68	print STDERR "\n", @_, "\n";
	69	}
	70
4bfba4ee	71	# needed for WeirdOS
	72	sub fixup_path ($) {
	73	return $_[0] unless ( $^O eq 'MSWin32' and $_[0] );
	74
	75	# sometimes we can get a short/longname mix, normalize everything to longnames
	76	my $fn = Win32::GetLongPathName($_[0]);
	77
	78	# Fixup (native) slashes in Config not matching (unixy) slashes in INC
	79	$fn =~ s\|\\\|/\|g;
	80
	81	$fn;
	82	}
	83
cebc0cc8	84	my @lib_display_order = qw(
	85	sitearch
	86	sitelib
	87	vendorarch
	88	vendorlib
	89	archlib
	90	privlib
	91	);
	92	my $lib_paths = {
	93	(map
4bfba4ee	94	{ $Config{$_}
	95	? ( $_ => fixup_path( $Config{"${_}exp"} \|\| $Config{$_} ) )
	96	: ()
	97	}
cebc0cc8	98	@lib_display_order
	99	),
	100
	101	# synthetic, for display
	102	'./lib' => 'lib',
	103	};
	104
	105	sub describe_fn {
	106	my $fn = shift;
	107
4bfba4ee	108	return '' if !defined $fn;
	109
	110	$fn = fixup_path( $fn );
	111
cebc0cc8	112	$lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
	113	for @lib_display_order;
	114
	115	$fn;
	116	}
	117
	118	sub md5_of_fn {
	119	# we already checked for -r/-f, just bail if can't open
	120	open my $fh, '<:raw', $_[0] or return '';
	121	require Digest::MD5;
	122	Digest::MD5->new->addfile($fh)->hexdigest;
	123	}
	124
	125	# first run through lib and try to load anything we can find
	126	# within our own project
	127	find({
	128	wanted => sub {
	129	-f $_ or return;
	130
	131	# can't just `require $fn`, as we need %INC to be
	132	# populated properly
	133	my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
	134	or return;
	135
	136	req_mod join ('::', File::Spec->splitdir($mod));
	137	},
	138	no_chdir => 1,
	139	}, 'lib' );
	140
	141	# now run through OptDeps and attempt loading everything else
	142	#
	143	# some things needs to be sorted before other things
	144	# positive - load first
	145	# negative - load last
	146	my $load_weights = {
	147	# Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
	148	# clashes with libssl, and will segfault everything coming after them
	149	"DBD::Oracle" => -999,
	150	};
	151	req_mod $_ for sort
	152	{ ($load_weights->{$b}\|\|0) <=> ($load_weights->{$a}\|\|0) }
	153	keys %{
	154	DBIx::Class::Optional::Dependencies->req_list_for([
250d9e55	155	grep
	156	# some DBDs are notoriously problematic to load
	157	# hence only show stuff based on test_rdbms which will
	158	# take into account necessary ENVs
	159	{ $_ !~ /^rdbms_/ }
	160	keys %{DBIx::Class::Optional::Dependencies->req_group_list}
cebc0cc8	161	])
	162	}
	163	;
	164
	165	my $has_versionpm = eval { require version };
	166
	167	# at this point we've loaded everything we ever could, let's drill through
	168	# the ENTIRE symtable and build a map of versions
	169	my $version_list = { perl => $] };
	170	visit_namespaces( action => sub {
4bfba4ee	171	no strict 'refs';
cebc0cc8	172	my $pkg = shift;
	173
	174	# keep going, but nothing to see here
	175	return 1 if $pkg eq 'main';
	176
4bfba4ee	177	# private - not interested, including no further descent
cebc0cc8	178	return 0 if $pkg =~ / (?: ^ \| :: ) _ /x;
cebc0cc8	179
4bfba4ee	180	# not interested in no-VERSION-containing modules, nor synthetic classes
cebc0cc8	181	return 1 if (
	182	! defined ${"${pkg}::VERSION"}
	183	or
	184	${"${pkg}::VERSION"} =~ /\Qset by base.pm/
	185	);
	186
	187	# make sure a version can be extracted, be noisy when it doesn't work
	188	# do this even if we are throwing away the result below in lieu of EUMM
	189	my $mod_ver = eval { $pkg->VERSION };
	190	if (my $err = $@) {
	191	$err =~ s/^/ /mg;
	192	say_err
	193	"Calling `$pkg->VERSION` resulted in an exception, which should never "
	194	. "happen - please file a bug with the distribution containing $pkg. "
4bfba4ee	195	. "Complete exception text below:\n\n$err"
cebc0cc8	196	;
cebc0cc8	197	}
4bfba4ee	198	elsif( ! defined $mod_ver or ! length $mod_ver ) {
	199	my $ret = defined $mod_ver
	200	? "the empty string ''"
	201	: "'undef'"
cebc0cc8	202	;
cebc0cc8	203
cebc0cc8	204	say_err
4bfba4ee	205	"Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
	206	. "is defined, which should never happen - please file a bug with the "
	207	. "distribution containing $pkg."
cebc0cc8	208	;
4bfba4ee	209
cebc0cc8	210	undef $mod_ver;
	211	}
	212
	213	# if this is a real file - extract the version via EUMM whenever possible
	214	my $fn = $INC{module_notional_filename($pkg)};
	215
4bfba4ee	216	my $eumm_ver = (
	217	$fn
	218	and
	219	-f $fn
	220	and
	221	-r $fn
	222	and
	223	eval { MM->parse_version( $fn ) }
	224	) \|\| undef;
cebc0cc8	225
	226	if (
	227	$has_versionpm
	228	and
	229	defined $eumm_ver
	230	and
	231	defined $mod_ver
	232	and
	233	$eumm_ver ne $mod_ver
	234	and
	235	(
	236	( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } \|\| 0 )
	237	!=
	238	( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } \|\| 0 )
	239	)
	240	) {
	241	say_err
	242	"Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
	243	. "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} "
	244	. "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
	245	. "This should never happen - please check whether this is still present "
	246	. "in the latest version, and then file a bug with the distribution "
	247	. "containing $pkg."
	248	;
	249	}
	250
	251	if( defined $eumm_ver ) {
	252	$version_list->{$pkg} = $eumm_ver;
	253	}
	254	elsif( defined $mod_ver ) {
	255	$version_list->{$pkg} = $mod_ver;
	256	}
	257
	258	1;
	259	});
	260
4bfba4ee	261	# In retrospect it makes little sense to omit this information - just
	262	# show everything at all times.
	263	# Nevertheless leave the dead code, in case it turns out to be a bad idea...
	264	my $show_all = 1;
	265	#my $show_all = $ENV{PERL_DESCRIBE_ALL_DEPS} \|\| !DBICTest::RunMode->is_plain;
	266
cebc0cc8	267	# compress identical versions as close to the root as we can
	268	# unless we are dealing with a smoker - in which case we want
	269	# to see every MD5 there is
4bfba4ee	270	unless ($show_all) {
cebc0cc8	271	for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
	272	my $parent = $mod;
	273
	274	while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
	275	$version_list->{$parent}
	276	and
	277	$version_list->{$parent} eq $version_list->{$mod}
	278	and
	279	( ( delete $version_list->{$mod} ) or 1 )
	280	and
	281	last
	282	}
	283	}
	284	}
	285
	286	ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
	287
	288	# do not announce anything under ci - we are watching for STDERR silence
	289	exit if DBICTest::RunMode->is_ci;
	290
	291	# sort stuff into @INC segments
	292	my $segments;
	293
	294	MODULE:
	295	for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
	296	my $fn = $INC{module_notional_filename($mod)};
	297
4bfba4ee	298	my $tuple = [ $mod ];
cebc0cc8	299
4bfba4ee	300	if ( defined $fn && -f $fn && -r $fn ) {
4bfba4ee	301	push @$tuple, ( $fn = fixup_path($fn) );
cebc0cc8	302
cebc0cc8	303	for my $lib (@lib_display_order, './lib') {
	304	if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) {
	305	push @{$segments->{$lib}}, $tuple;
	306	next MODULE;
	307	}
	308	}
	309	}
	310
	311	# fallthrough for anything without a physical filename, or unknown lib
	312	push @{$segments->{''}}, $tuple;
	313	}
	314
	315	# diag the result out
4bfba4ee	316	my $max_ver_len = max map
	317	{ length $_ }
	318	( values %$version_list, 'xxx.yyyzzz_bbb' )
	319	;
cebc0cc8	320	my $max_mod_len = max map { length $_ } keys %$version_list;
cebc0cc8	321
4bfba4ee	322	my $discl = <<'EOD';
	323
	324	Versions of all loadable modules within both the core and OPTIONAL dependency chains present on this system
	325	Note that MANY of these modules will NEVER be loaded during normal operation of DBIx::Class
	326	EOD
	327
	328	$discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n"
	329	unless $show_all;
	330
	331	diag $discl;
	332
	333	diag "\n";
	334
cebc0cc8	335	for my $seg ( '', @lib_display_order, './lib' ) {
	336	next unless $segments->{$seg};
	337
4bfba4ee	338	diag sprintf "=== %s ===\n\n",
cebc0cc8	339	$seg
cebc0cc8	340	? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
4bfba4ee	341	: 'Misc versions'
cebc0cc8	342	;
cebc0cc8	343
4bfba4ee	344	diag sprintf (
4bfba4ee	345	"%s %s%s\n",
cebc0cc8	346	$max_ver_len => $version_list->{$_->[0]},
	347	-$max_mod_len => $_->[0],
	348	($_->[1]
4bfba4ee	349	? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
cebc0cc8	350	: ''
	351	),
	352	) for @{$segments->{$seg}};
	353
4bfba4ee	354	diag "\n\n"
cebc0cc8	355	}
cebc0cc8	356
4bfba4ee	357	diag "$discl\n";