[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 'max';
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";
}

my @lib_display_order = qw(
  sitearch
  sitelib
  vendorarch
  vendorlib
  archlib
  privlib
);
my $lib_paths = {
  (map
    { $Config{$_} ? ( $_ => $Config{"${_}exp"} || $Config{$_} ) : () }
    @lib_display_order
  ),

  # synthetic, for display
  './lib' => 'lib',
};

sub describe_fn {
  my $fn = shift;

  $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 {
  my $pkg = shift;

  # keep going, but nothing to see here
  return 1 if $pkg eq 'main';

  # private - not interested
  return 0 if $pkg =~ / (?: ^ | :: ) _ /x;

  no strict 'refs';
  # that would be some synthetic class, or a custom sub VERSION
  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. "
    . "Follows the full text of the exception:\n\n$err\n"
    ;
  }
  elsif( ! defined $mod_ver ) {
    say_err
      "Calling `$pkg->VERSION` returned 'undef', which should never "
    . "happen - please file a bug with the distribution containing $pkg."
    ;

  }
  elsif( ! length $mod_ver ) {
    say_err
      "Calling `$pkg->VERSION` returned the empty string '', 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 = eval { MM->parse_version( $fn ) }
    if $fn and  -f $fn and -r $fn;

  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;
});

# 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 ( $ENV{AUTOMATED_TESTING} ) {
  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,
    ( ( $fn && -f $fn && -r $fn ) ? $fn : undef )
  ];


  if ($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;
my $max_mod_len = max map { length $_ } keys %$version_list;

my $diag = "\n\nVersions of all loadable modules within the configure/build/test/runtime dependency chains present on this system (both core and optional)\n\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'
  ;

  $diag .= sprintf (
    "   %*s  %*s%s\n",
    $max_ver_len => $version_list->{$_->[0]},
    -$max_mod_len => $_->[0],
    ($_->[1]
      ? "  [ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
      : ''
    ),
  ) for @{$segments->{$seg}};

  $diag .= "\n\n"
}

diag $diag;
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';
	51	use List::Util 'max';
	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
72	my @lib_display_order = qw(
73	sitearch
74	sitelib
75	vendorarch
76	vendorlib
77	archlib
78	privlib
79	);
80	my $lib_paths = {
81	(map
82	{ $Config{$_} ? ( $_ => $Config{"${_}exp"} \|\| $Config{$_} ) : () }
83	@lib_display_order
84	),
85
86	# synthetic, for display
87	'./lib' => 'lib',
88	};
89
90	sub describe_fn {
91	my $fn = shift;
92
93	$lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
94	for @lib_display_order;
95
96	$fn;
97	}
98
99	sub md5_of_fn {
100	# we already checked for -r/-f, just bail if can't open
101	open my $fh, '<:raw', $_[0] or return '';
102	require Digest::MD5;
103	Digest::MD5->new->addfile($fh)->hexdigest;
104	}
105
106	# first run through lib and try to load anything we can find
107	# within our own project
108	find({
109	wanted => sub {
110	-f $_ or return;
111
112	# can't just `require $fn`, as we need %INC to be
113	# populated properly
114	my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
115	or return;
116
117	req_mod join ('::', File::Spec->splitdir($mod));
118	},
119	no_chdir => 1,
120	}, 'lib' );
121
122	# now run through OptDeps and attempt loading everything else
123	#
124	# some things needs to be sorted before other things
125	# positive - load first
126	# negative - load last
127	my $load_weights = {
128	# Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
129	# clashes with libssl, and will segfault everything coming after them
130	"DBD::Oracle" => -999,
131	};
132
133	my $optdeps = {
134	map
135	{ $_ => 1 }
136	map
137	{ keys %{DBIx::Class::Optional::Dependencies->req_list_for($_)} }
138	grep
139	{ $_ !~ /rdbms/ }
140	keys %{DBIx::Class::Optional::Dependencies->req_group_list}
141	};
142	req_mod $_ for sort
143	{ ($load_weights->{$b}\|\|0) <=> ($load_weights->{$a}\|\|0) }
144	keys %$optdeps
145	;
146
147	my $has_versionpm = eval { require version };
148
149	# at this point we've loaded everything we ever could, let's drill through
150	# the ENTIRE symtable and build a map of versions
151	my $version_list = { perl => $] };
152	visit_namespaces( action => sub {
153	my $pkg = shift;
154
155	# keep going, but nothing to see here
156	return 1 if $pkg eq 'main';
157
158	# private - not interested
159	return 0 if $pkg =~ / (?: ^ \| :: ) _ /x;
160
161	no strict 'refs';
162	# that would be some synthetic class, or a custom sub VERSION
163	return 1 if (
164	! defined ${"${pkg}::VERSION"}
165	or
166	${"${pkg}::VERSION"} =~ /\Qset by base.pm/
167	);
168
169	# make sure a version can be extracted, be noisy when it doesn't work
170	# do this even if we are throwing away the result below in lieu of EUMM
171	my $mod_ver = eval { $pkg->VERSION };
172	if (my $err = $@) {
173	$err =~ s/^/ /mg;
174	say_err
175	"Calling `$pkg->VERSION` resulted in an exception, which should never "
176	. "happen - please file a bug with the distribution containing $pkg. "
177	. "Follows the full text of the exception:\n\n$err\n"
178	;
179	}
180	elsif( ! defined $mod_ver ) {
181	say_err
182	"Calling `$pkg->VERSION` returned 'undef', which should never "
183	. "happen - please file a bug with the distribution containing $pkg."
184	;
185
186	}
187	elsif( ! length $mod_ver ) {
188	say_err
189	"Calling `$pkg->VERSION` returned the empty string '', which should never "
190	. "happen - please file a bug with the distribution containing $pkg."
191	;
192	undef $mod_ver;
193	}
194
195	# if this is a real file - extract the version via EUMM whenever possible
196	my $fn = $INC{module_notional_filename($pkg)};
197
198	my $eumm_ver = eval { MM->parse_version( $fn ) }
199	if $fn and -f $fn and -r $fn;
200
201	if (
202	$has_versionpm
203	and
204	defined $eumm_ver
205	and
206	defined $mod_ver
207	and
208	$eumm_ver ne $mod_ver
209	and
210	(
211	( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } \|\| 0 )
212	!=
213	( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } \|\| 0 )
214	)
215	) {
216	say_err
217	"Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
218	. "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} "
219	. "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
220	. "This should never happen - please check whether this is still present "
221	. "in the latest version, and then file a bug with the distribution "
222	. "containing $pkg."
223	;
224	}
225
226	if( defined $eumm_ver ) {
227	$version_list->{$pkg} = $eumm_ver;
228	}
229	elsif( defined $mod_ver ) {
230	$version_list->{$pkg} = $mod_ver;
231	}
232
233	1;
234	});
235
236	# compress identical versions as close to the root as we can
237	# unless we are dealing with a smoker - in which case we want
238	# to see every MD5 there is
239	unless ( $ENV{AUTOMATED_TESTING} ) {
240	for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
241	my $parent = $mod;
242
243	while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
244	$version_list->{$parent}
245	and
246	$version_list->{$parent} eq $version_list->{$mod}
247	and
248	( ( delete $version_list->{$mod} ) or 1 )
249	and
250	last
251	}
252	}
253	}
254
255	ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
256
257	exit if ($ENV{TRAVIS}\|\|'') eq 'true';
258
259	# sort stuff into @INC segments
260	my $segments;
261
262	MODULE:
263	for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
264	my $fn = $INC{module_notional_filename($mod)};
265
266	my $tuple = [
267	$mod,
268	( ( $fn && -f $fn && -r $fn ) ? $fn : undef )
269	];
270
271
272	if ($fn) {
273	for my $lib (@lib_display_order, './lib') {
274	if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) {
275	push @{$segments->{$lib}}, $tuple;
276	next MODULE;
277	}
278	}
279	}
280
281	# fallthrough for anything without a physical filename, or unknown lib
282	push @{$segments->{''}}, $tuple;
283	}
284
285	# diag the result out
286	my $max_ver_len = max map { length $_ } values %$version_list;
287	my $max_mod_len = max map { length $_ } keys %$version_list;
288
289	my $diag = "\n\nVersions of all loadable modules within the configure/build/test/runtime dependency chains present on this system (both core and optional)\n\n";
290	for my $seg ( '', @lib_display_order, './lib' ) {
291	next unless $segments->{$seg};
292
293	$diag .= sprintf "=== %s ===\n\n",
294	$seg
295	? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
296	: 'Misc'
297	;
298
299	$diag .= sprintf (
300	" %s %s%s\n",
301	$max_ver_len => $version_list->{$_->[0]},
302	-$max_mod_len => $_->[0],
303	($_->[1]
304	? " [ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
305	: ''
306	),
307	) for @{$segments->{$seg}};
308
309	$diag .= "\n\n"
310	}
311
312	diag $diag;