Fix parsing DSN when the driver part includes DBI attributes
[dbsrgits/DBIx-Class.git] / 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
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 qw(max min);
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 # 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
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
95     { $Config{$_}
96       ? ( $_ => fixup_path( $Config{"${_}exp"} || $Config{$_} ) )
97       : ()
98     }
99     @lib_display_order
100   ),
101
102   # synthetic, for display
103   './lib' => 'lib',
104 };
105
106 sub describe_fn {
107   my $fn = shift;
108
109   return '' if !defined $fn;
110
111   $fn = fixup_path( $fn );
112
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 {
173   no strict 'refs';
174   my $pkg = shift;
175
176   # keep going, but nothing to see here
177   return 1 if $pkg eq 'main';
178
179   # private - not interested, including no further descent
180   return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
181
182   # not interested in no-VERSION-containing modules, nor synthetic classes
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. "
197     . "Complete exception text below:\n\n$err"
198     ;
199   }
200   elsif( ! defined $mod_ver or ! length $mod_ver ) {
201     my $ret = defined $mod_ver
202       ? "the empty string ''"
203       : "'undef'"
204     ;
205
206     say_err
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."
210     ;
211
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
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;
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
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
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
272 unless ($show_all) {
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
299   my $tuple = [ $mod ];
300
301   if ( defined $fn && -f $fn && -r $fn ) {
302     push @$tuple, ( $fn = fixup_path($fn) );
303
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
317 my $max_ver_len = max map
318   { length $_ }
319   ( values %$version_list, 'xxx.yyyzzz_bbb' )
320 ;
321 my $max_mod_len = max map { length $_ } keys %$version_list;
322
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
336 for my $seg ( '', @lib_display_order, './lib' ) {
337   next unless $segments->{$seg};
338
339   diag sprintf "=== %s ===\n\n",
340     $seg
341       ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
342       : 'Misc versions'
343   ;
344
345   diag sprintf (
346     "%*s  %*s%s\n",
347     $max_ver_len => $version_list->{$_->[0]},
348     -$max_mod_len => $_->[0],
349     ($_->[1]
350       ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
351       : ''
352     ),
353   ) for @{$segments->{$seg}};
354
355   diag "\n\n"
356 }
357
358 diag "$discl\n";