1#!perl 2 3use strict; 4use warnings; 5use Test::More; 6use IPC::Open3; 7use File::Spec; 8use Config; 9use Devel::TraceUse (); 10use lib (); 11 12my $tlib = File::Spec->catdir( 't', 'lib' ); 13my $tlib2 = File::Spec->catdir( 't', 'lib2' ); 14my $vlib = defined $lib::VERSION ? " $lib::VERSION" : ''; 15 16# all command lines prefixed with $^X -I"t/lib" 17my @tests = ( 18 [ << 'OUT', qw(-d:TraceUse -MParent -e1) ], 19Modules used from -e: 20 1. Parent, -e line 0 [main] 21 2. Child, Parent.pm line 3 22 3. Sibling, Child.pm line 3 23OUT 24 [ << 'OUT', qw(-d:TraceUse -MChild -e1) ], 25Modules used from -e: 26 1. Child, -e line 0 [main] 27 2. Sibling, Child.pm line 3 28 3. Parent, Sibling.pm line 4 29OUT 30 [ << 'OUT', qw(-d:TraceUse -MSibling -e1) ], 31Modules used from -e: 32 1. Sibling, -e line 0 [main] 33 2. Child, Sibling.pm line 3 34 3. Parent, Child.pm line 4 35OUT 36 [ << 'OUT', qw(-d:TraceUse -MM1 -e1) ], 37Modules used from -e: 38 1. M1, -e line 0 [main] 39 2. M2, M1.pm line 3 40 3. M3, M2.pm line 3 41OUT 42 [ << 'OUT', qw(-d:TraceUse -MM4 -e1) ], 43Modules used from -e: 44 1. M4, -e line 0 [main] 45 2. M5, M4.pm line 3 46 3. M6, M5.pm line 9 [M5::in] 47OUT 48 [ << 'OUT', qw(-d:TraceUse -MM1 -e), 'require M4' ], 49Modules used from -e: 50 1. M1, -e line 0 [main] 51 2. M2, M1.pm line 3 52 3. M3, M2.pm line 3 53 4. M4, -e line 1 [main] 54 5. M5, M4.pm line 3 55 6. M6, M5.pm line 9 [M5::in] 56OUT 57 [ << 'OUT', qw(-d:TraceUse -e), 'require M4; use M1' ], 58Modules used from -e: 59 1. M1, -e line 1 [main] 60 2. M2, M1.pm line 3 61 3. M3, M2.pm line 3 62 4. M4, -e line 1 [main] 63 5. M5, M4.pm line 3 64 6. M6, M5.pm line 9 [M5::in] 65OUT 66 [ << 'OUT', qw(-d:TraceUse -MM4 -MM1 -e M5->load) ], 67Modules used from -e: 68 1. M4, -e line 0 [main] 69 2. M5, M4.pm line 3 70 3. M6, M5.pm line 9 [M5::in] 71 7. M7 0, M5.pm line 4 72 4. M1, -e line 0 [main] 73 5. M2, M1.pm line 3 74 6. M3, M2.pm line 3 75Possible proxies: 76 2 -e line 0, sub main::BEGIN 77OUT 78 [ << 'OUT', qw(-d:TraceUse -e), 'eval { use M1 }' ], 79Modules used from -e: 80 1. M1, -e line 1 [main] 81 2. M2, M1.pm line 3 82 3. M3, M2.pm line 3 83OUT 84 [ << "OUT", '-d:TraceUse', "-Mlib=$tlib2", '-MM8', '-e1' ], 85Modules used from -e: 86 1. lib$vlib, -e line 0 [main] 87 5. M8, -e line 0 [main] 88Possible proxies: 89 2 -e line 0, sub main::BEGIN 90OUT 91 [ << "OUT", '-d:TraceUse', "-Mlib=$tlib2", '-MM1', '-MM8', '-e1' ], 92Modules used from -e: 93 0. lib$vlib, -e line 0 [main] 94 0. M1, -e line 0 [main] 95 0. M2, M1.pm line 3 96 0. M3, M2.pm line 3 97 0. M8, -e line 0 [main] 98Possible proxies: 99 3 -e line 0, sub main::BEGIN 100OUT 101 [ << "OUT", '-d:TraceUse', "-Mlib=$tlib2", '-MM7', '-MM8', '-e1' ], 102Modules used from -e: 103 0. lib$vlib, -e line 0 [main] 104 0. M7 0, -e line 0 [main] 105 0. M8, -e line 0 [main] 106Possible proxies: 107 3 -e line 0, sub main::BEGIN 108OUT 109 [ << 'OUT', qw(-d:TraceUse -e), 'eval { require M10 }' ], 110Modules used from -e: 111 1. M10, -e line 1 [main] (FAILED) 112OUT 113 [ << 'OUT', qw(-d:TraceUse -e), "eval { require M10 };\npackage M11;\neval { require M10 }" ], 114Modules used from -e: 115 1. M10, -e line 1 [main] (FAILED) 116 2. M10, -e line 3 [M11] (FAILED) 117OUT 118 [ << "OUT", '-d:TraceUse', '-MM7', "-Mlib=$tlib2", '-MM1', '-MM8', '-e1' ], 119Modules used from -e: 120 0. M7 0, -e line 0 [main] 121 0. lib$vlib, -e line 0 [main] 122 0. M1, -e line 0 [main] 123 0. M2, M1.pm line 3 124 0. M3, M2.pm line 3 125 0. M8, -e line 0 [main] 126Possible proxies: 127 4 -e line 0, sub main::BEGIN 128OUT 129 [ << 'OUT', '-d:TraceUse', "-I$tlib2", qw( -MM4 -MM1 -MM8 -MM10 -e M5->load) ], 130Modules used from -e: 131 1. M4, -e line 0 [main] 132 2. M5, M4.pm line 3 133 3. M6, M5.pm line 9 [M5::in] 134 11. M7 0, M5.pm line 4 135 4. M1, -e line 0 [main] 136 5. M2, M1.pm line 3 137 6. M3, M2.pm line 3 138 7. M8, -e line 0 [main] 139 8. M10, -e line 0 [main] 140 9. M11 1.01, M10.pm line 3 [M8] 141 10. M12 1.12, M10.pm line 4 [M8] 142Possible proxies: 143 4 -e line 0, sub main::BEGIN 144OUT 145 [ << 'OUT', qw(-d:TraceUse -c -MM1 -e), 'require M4' ], 146Modules used from -e: 147 1. M1, -e line 0 [main] 148 2. M2, M1.pm line 3 149 3. M3, M2.pm line 3 150-e syntax OK 151OUT 152); 153 154# Module::CoreList-related tests 155if ( eval { require Module::CoreList; 1; } ) { 156 diag "Module::CoreList $Module::CoreList::VERSION installed"; 157 158 # Module::CoreList always knew about those 159 push @tests, 160 [ << 'OUT', '-d:TraceUse=hidecore:5.5.30', '-MConfig', '-e1' ], 161Modules used from -e: 162OUT 163 [ << 'OUT', '-d:TraceUse=hidecore:5.006001', '-MConfig', '-e1' ], 164Modules used from -e: 165OUT 166 if $] < 5.013010; 167 push @tests, [ [ 168 "Module::CoreList $Module::CoreList::VERSION doesn't know about Perl 4" 169 ], << "OUT", '-d:TraceUse=hidecore:4', '-e1' ]; 170Modules used from -e: 171OUT 172 173 # test hiding a well-known core module 174 my $this_perl = Devel::TraceUse::numify($]); 175 push @tests, [ << "OUT", '-d:TraceUse=hidecore', '-Mstrict', '-e1' ]; 176Modules used from -e: 177OUT 178 179 # does Module::CoreList know about this Perl? 180 if ( !exists $Module::CoreList::version{$this_perl} ) { 181 $tests[-1][0] .= << 'OUT'; # update the output 182 1. strict %%%, -e line 0 [main] 183OUT 184 unshift @{ $tests[-1] }, [ # add a warning 185 "Module::CoreList $Module::CoreList::VERSION doesn't know about Perl $this_perl" 186 ]; 187 } 188 189 # convert Module::CoreList devel version numbers to a number 190 my $corelist_version = $Module::CoreList::VERSION; 191 $corelist_version =~ tr/_//d; 192 193 # Module::CoreList didn't know about 5.001 until its version 2.00 194 push @tests, [ << 'OUT', '-d:TraceUse=hidecore:5.1', '-MConfig', '-e1' ], 195Modules used from -e: 196 1. Config, -e line 0 [main] 197OUT 198 if $corelist_version >= 2 && $] < 5.013010; 199} 200else { 201 diag "Module::CoreList not installed"; 202 push @tests, [ [ 203 q"Can't locate Module/CoreList.pm in @INC (@INC contains: <DELETED>)", 204 'END failed--call queue aborted.' 205 ], '', '-d:TraceUse=hidecore', '-e1' ]; 206} 207 208my $warn_d = 'Use -d:TraceUse for more accurate information.'; 209 210# -MDevel::TraceUse usually produces the same output as -d:TraceUse 211for ( 0 .. $#tests ) { 212 unshift @{ $tests[$_] }, [] unless ref $tests[$_][0]; 213 push( @tests, [ @{ $tests[$_] } ] ); 214 $tests[-1][0] = [ @{ $tests[$_][0] } ]; 215 # keep options the same 216 $tests[-1][2] =~ s/^-d:TraceUse/-MDevel::TraceUse/; 217 # also expect the note about -d:TraceUse 218 unshift @{ $tests[-1][0] }, $warn_d; 219} 220 221# but there are some exceptions 222push @tests, ( 223 [ [], << 'OUT', qw(-d:TraceUse -e), 'eval q(use M1)' ], 224Modules used from -e: 225 1. M1, -e line 1 (eval 1) [main] 226 2. M2, M1.pm line 3 227 3. M3, M2.pm line 3 228OUT 229 [ [$warn_d], << 'OUT', qw(-MDevel::TraceUse -e), 'eval q(use M1)' ], 230Modules used from -e: 231 1. M1, (eval 1) [main] 232 2. M2, M1.pm line 3 233 3. M3, M2.pm line 3 234OUT 235 [ [], << 'OUT', qw(-d:TraceUse -MM9 -e1) ], 236Modules used from -e: 237 1. M9, -e line 0 [main] 238 2. M6, M9.pm line 3 (eval 1) 239OUT 240 [ [$warn_d], << 'OUT', qw(-MDevel::TraceUse -MM9 -e1) ], 241Modules used from -e: 242 1. M9, -e line 0 [main] 243 2. M6, (eval 1) [M9] 244OUT 245); 246 247my @outputs = ( 248 undef, 249 'out.txt', 250 File::Spec->rel2abs('out.txt'), 251); 252 253plan tests => (scalar(@outputs) * scalar(@tests)); 254 255my @temp_files; 256 257# Clean-up 258END { 259 unlink for grep { -f $_ } @temp_files; 260} 261 262foreach my $o (@outputs) { 263 run_test($o, @$_) for @tests; 264} 265 266sub run_test { 267 my ( $output_file, $warns, $errput, @cmd ) = @_; 268 269 if ( defined $output_file ) { 270 #diag $output_file"; 271 @cmd = map { 272 s/^(-.*?:TraceUse=..*)$/$1,output:$output_file/; 273 s/^(-.*?:TraceUse)=?$/$1=output:$output_file/; 274 $_ 275 } @cmd; 276 push @temp_files, $output_file; 277 } 278 279 # Test name 280 ( my $mesg = "Trace for: perl @cmd" ) =~ s/\n/\\n/g; 281 282 # run the test subcommand 283 local ( *IN, *OUT, *ERR ); 284 my $pid = open3( \*IN, \*OUT, \*ERR, $^X, '-Iblib/lib', "-I$tlib", @cmd ); 285 my @errput = map { s/[\015\012]*$//; $_ } <ERR>; 286 waitpid( $pid, 0 ); 287 288 my @out; 289 if (defined $output_file && length $errput) { 290 unless (-f $output_file) { 291 fail $mesg; 292 diag qq(Missing expected output file "$output_file"); 293 return; 294 } 295 open my $f, '<', $output_file; 296 @out = map { s/[\015\012]*$//; $_ } <$f>; 297 close $f; 298 unlink $f; 299 } 300 301 # we want to ignore modules loaded by those libraries 302 my $nums = 1; 303 for my $lib (qw( lib sitecustomize.pl )) { 304 for my $arr (\@errput, \@out) { 305 if ( grep /\. +.*\Q$lib\E[^,]*,/, @$arr ) { 306 @$arr = normalize( $lib, @$arr ); 307 $nums = 0; 308 } 309 } 310 } 311 312 # take sitecustomize.pl into account in our expected errput 313 ( $nums, $errput ) = add_sitecustomize( $nums, $errput, @cmd ) 314 if $Config{usesitecustomize}; 315 316 # clean up the "Can't locate" error message 317 s/\(\@INC contains: .*/(\@INC contains: <DELETED>)/ for @errput; 318 319 push @errput, @out; 320 321 # make sure the 'syntax OK' is at the end 322 if ( grep $_ eq '-c', @cmd ) { 323 @errput = sort { $a =~ /syntax OK/ ? 1 : $b =~ /syntax OK/ ? -1 : 0 } 324 @errput; 325 } 326 327 # remove version number of core modules used in testing 328 s/\b(strict )[^,]+,/$1%%%,/g for @errput; 329 330 # compare the results 331 my @expected = map { s/[\015\012]*$//; $_ } split /^/, $errput; 332 @expected = map { s/^(\s*\d+)\./%%%%./; $_ } @expected if !$nums; 333 unshift @expected, @$warns; 334 335 # ignore the eval numbers 336 s/\b(eval )[0-9]+/$1%%%/g for @errput, @expected; 337 338 is_deeply( \@errput, \@expected, $mesg ) 339 or diag map ( {"$_\n"} '--- Got ---', @errput ), 340 "--- Expected ---\n$errput"; 341} 342 343# removes unexpected modules loaded by somewhat expected ones 344# and normalize the errput so we can ignore them 345sub normalize { 346 my ( $lib, @lines ) = @_; 347 my $loaded_by = 0; 348 my $tab; 349 for (@lines) { 350 s/^(\s*\d+)\./%%%%./; 351 if (/\.( +)\Q$lib\E[^,]*,/) { 352 $loaded_by = 1; 353 $tab = $1 . ' '; 354 next; 355 } 356 if ($loaded_by) { 357 if (/^%%%%\.$tab/) { $_ = 'deleted' } 358 else { $loaded_by = 0 } 359 } 360 } 361 return grep { $_ ne 'deleted' } @lines; 362} 363 364my $diag; 365 366sub add_sitecustomize { 367 my ( $nums, $errput, @cmd ) = @_; 368 my $sitecustomize_path 369 = File::Spec->catfile( $Config{sitelib}, 'sitecustomize.pl' ); 370 my ($sitecustomize) = grep { /\bsitecustomize\.pl$/ } keys %INC; 371 372 # provide some info to the tester 373 if ( !$diag++ ) { 374 diag "This perl has sitecustomize.pl enabled, ", 375 -e $sitecustomize_path 376 ? "and the file $sitecustomize_path exists" 377 : "but the file $sitecustomize_path does not exist"; 378 diag "sitecustomize.pl was loaded successfully via $INC{$sitecustomize}" 379 if $sitecustomize; 380 } 381 $sitecustomize_path = $INC{$sitecustomize} if !-e $sitecustomize_path; 382 383 # the output depends on the existence of sitecustomize.pl 384 if ( -e $sitecustomize_path ) { 385 386 # Loaded so first it's not caught by our @INC hook: 387 # Modules used, but not reported: 388 # /home/book/local/5.8.9/site/lib/sitecustomize.pl 389 390 # grab the various postambles, starting from the end 391 my ( @postambles, @unreported ); 392 $errput =~ s/(-e syntax OK.*)//s 393 and unshift @postambles, $1; 394 $errput =~ s/(Possible proxies:.*)//s 395 and unshift @postambles, $1; 396 $errput =~ s/(Modules used, but not reported:.*)//s 397 and ( undef, @unreported ) = split( /^/, $1 ); 398 push @unreported, " $sitecustomize\n"; 399 400 # put the postambles back 401 $errput .= join '', 402 "Modules used, but not reported:\n", ( sort @unreported ), 403 @postambles; 404 } 405 elsif ( grep { $_ eq '-d:TraceUse' } @cmd ) { 406 407 # Loaded first, but FAIL. The debugger will tell us with an older Perl. 408 # Modules used from -e: 409 # 1. C:/perl/site/lib/sitecustomize.pl, -e line 0 [main] (FAILED) 410 if ( $] < 5.011 ) { 411 $errput =~ s{Modules used from.*?^} 412 {$& 0. $sitecustomize, -e line 0 [main] (FAILED)\n}sm; 413 $nums = 0; 414 } 415 } 416 417 # updated values 418 return ( $nums, $errput ); 419} 420 421