1package Test2::Harness::Runner::Preloader; 2use strict; 3use warnings; 4 5our $VERSION = '1.000082'; 6 7use B(); 8use Carp qw/confess croak/; 9use Fcntl qw/LOCK_EX LOCK_UN/; 10use Time::HiRes qw/time/; 11use Test2::Harness::Util qw/open_file file2mod mod2file lock_file unlock_file clean_path/; 12 13use Test2::Harness::Runner::Preloader::Stage; 14 15use File::Spec(); 16use List::Util qw/pairgrep/; 17 18BEGIN { 19 local $@; 20 my $inotify = eval { require Linux::Inotify2; 1 }; 21 if ($inotify) { 22 my $MASK = Linux::Inotify2::IN_MODIFY(); 23 $MASK |= Linux::Inotify2::IN_ATTRIB(); 24 $MASK |= Linux::Inotify2::IN_DELETE_SELF(); 25 $MASK |= Linux::Inotify2::IN_MOVE_SELF(); 26 27 *USE_INOTIFY = sub() { 1 }; 28 require constant; 29 constant->import(INOTIFY_MASK => $MASK); 30 } 31 else { 32 *USE_INOTIFY = sub() { 0 }; 33 *INOTIFY_MASK = sub() { 0 }; 34 } 35} 36 37use Test2::Harness::Util::HashBase( 38 qw{ 39 <dir 40 <preloads 41 <done 42 <below_threshold 43 44 <inotify <stats <last_checked 45 <dtrace 46 47 <staged <started_stages <stage 48 49 <dump_depmap 50 <monitor 51 <monitored 52 <changed 53 <reload 54 <restrict_reload 55 56 <blacklist_file 57 <blacklist_lock 58 <blacklist 59 } 60); 61 62sub init { 63 my $self = shift; 64 65 $self->{+PRELOADS} //= []; 66 67 $self->{+BELOW_THRESHOLD} //= 0; 68 69 return if $self->{+BELOW_THRESHOLD}; 70 71 if ($self->{+MONITOR} || $self->{+DUMP_DEPMAP}) { 72 require Test2::Harness::Runner::DepTracer; 73 $self->{+DTRACE} //= Test2::Harness::Runner::DepTracer->new(); 74 75 $self->{+BLACKLIST} //= {}; 76 $self->{+BLACKLIST_FILE} //= File::Spec->catfile($self->{+DIR}, 'BLACKLIST'); 77 } 78} 79 80sub stage_check { 81 my $self = shift; 82 my ($stage) = @_; 83 84 return 0 if $self->{+BELOW_THRESHOLD}; 85 86 my $p = $self->{+STAGED} or return 0; 87 return 1 if $stage eq 'NOPRELOAD'; 88 return 1 if $p->stage_lookup->{$stage}; 89 return 0; 90} 91 92sub task_stage { 93 my $self = shift; 94 my ($file, $wants) = @_; 95 96 return 'default' if $self->{+BELOW_THRESHOLD}; 97 return 'default' unless $self->{+STAGED}; 98 99 return $wants if $wants && $self->stage_check($wants); 100 101 my $stage = $self->{+STAGED}->file_stage($file) // $self->{+STAGED}->default_stage; 102 103 return $stage; 104} 105 106sub preload { 107 my $self = shift; 108 109 croak "Already preloaded" if $self->{+DONE}; 110 111 return 'default' if $self->{+BELOW_THRESHOLD}; 112 113 my $preloads = $self->{+PRELOADS} or return 'default'; 114 return 'default' unless @$preloads; 115 116 require Test2::API; 117 Test2::API::test2_start_preload(); 118 119 # Not loading blacklist yet because any preloads in this list need to 120 # happen regardless of the blacklist. 121 if ($self->{+MONITOR} || $self->{+DTRACE}) { 122 $self->_monitor_preload($preloads); 123 } 124 else { 125 $self->_preload($preloads); 126 } 127 128 $self->{+DONE} = 1; 129 130 return 'default' unless $self->{+STAGED}; 131 132 return $self->preload_stages('NOPRELOAD', @{$self->{+STAGED}->stage_list}); 133} 134 135sub preload_stages { 136 my $self = shift; 137 my @stages = @_; 138 139 my $name = 'base'; 140 my @procs; 141 142 while (my $stage = shift @stages) { 143 $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; 144 145 my $proc = $self->launch_stage($stage); 146 147 if ($proc) { 148 push @procs => $proc; 149 next; 150 } 151 152 # We are in the stage now, reset these 153 if (ref $stage) { 154 $name = $stage->name; 155 @procs = (); 156 @stages = @{$stage->children}; 157 } 158 else { # NOPRELOAD 159 $name = $stage; 160 @procs = (); 161 @stages = (); 162 } 163 164 $self->start_stage($stage); 165 } 166 167 return($name, @procs); 168} 169 170sub launch_stage { 171 my $self = shift; 172 my ($stage) = @_; 173 174 $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; 175 176 my $name = ref($stage) ? $stage->name : $stage; 177 178 my $pid = fork(); 179 180 return Test2::Harness::Runner::Preloader::Stage->new( 181 pid => $pid, 182 name => $name, 183 ) if $pid; 184 185 $0 .= "-$name"; 186 $ENV{T2_HARNESS_STAGE} = $name; 187 188 return; 189} 190 191sub start_stage { 192 my $self = shift; 193 my ($stage) = @_; 194 195 if ($self->{+STAGED}) { 196 if ($stage && !ref($stage)) { 197 $stage = $self->{+STAGED}->stage_lookup->{$stage}; 198 } 199 } 200 else { 201 $stage = undef; 202 } 203 204 $self->{+STAGE} = $stage; 205 206 $self->load_blacklist if $self->{+MONITOR}; 207 208 # Localize these in case something we preload tries to modify them. 209 local $SIG{INT} = $SIG{INT}; 210 local $SIG{HUP} = $SIG{HUP}; 211 local $SIG{TERM} = $SIG{TERM}; 212 213 my $preloads = $stage ? $stage->load_sequence : []; 214 215 my $meth = $self->{+MONITOR} || $self->{+DTRACE} ? '_monitor_preload' : '_preload'; 216 217 $self->$meth($preloads) if $preloads && @$preloads; 218 219 $self->_monitor() if $self->{+MONITOR}; 220} 221 222sub can_reload { 223 my $self = shift; 224 my ($mod, $file) = @_; 225 226 return 0 if $mod->can('TEST2_HARNESS_PRELOAD'); 227 228 if (my $cb = $self->get_stage_callback('reload_inplace_check')) { 229 my $res = $cb->(module => $mod, file => $file); 230 return $res if defined $res; 231 } 232 233 return 1 unless $mod->can('import'); 234 235 return 0 if $mod->can('IMPORTER_MENU'); 236 237 { 238 no strict 'refs'; 239 return 0 if @{"$mod\::EXPORT"}; 240 return 0 if @{"$mod\::EXPORT_OK"}; 241 } 242 243 return 1; 244} 245 246sub check { 247 my $self = shift; 248 249 return 1 if $self->{+CHANGED}; 250 251 return 0 unless $self->{+MONITOR}; 252 253 my $changed = USE_INOTIFY ? $self->_check_monitored_inotify : $self->_check_monitored_hardway; 254 return 0 unless $changed; 255 256 print "$$ $0 - Runner detected a change in one or more preloaded modules...\n"; 257 258 my %CNI = reverse pairgrep { $b } %INC; 259 my @todo; 260 261 my $dtrace = $self->dtrace; 262 $dtrace->start if $self->{+RELOAD}; 263 264 for my $file (keys %$changed) { 265 my $rel = $CNI{$file}; 266 my $mod = file2mod($rel); 267 268 unless ($self->{+RELOAD}) { 269 push @todo => [$mod, $file]; 270 next; 271 } 272 273 unless ($self->can_reload($mod, $file)) { 274 print "$$ $0 - Changed file '$file' cannot be reloaded in place...\n"; 275 push @todo => [$mod, $file]; 276 next; 277 } 278 279 print "$$ $0 - Attempting to reload '$file' in place...\n"; 280 281 my @warnings; 282 my $ok = eval { 283 local $SIG{__WARN__} = sub { push @warnings => @_ }; 284 285 my $stash = do { no strict 'refs'; \%{"${mod}\::"} }; 286 for my $sym (keys %$stash) { 287 next if $sym =~ m/::$/; 288 289 # Make sure the changed file and the file that defined the sub are the same. 290 if (my $cb = $self->get_stage_callback('reload_remove_check')) { 291 if (my $sub = $mod->can($sym)) { 292 if (my $cobj = B::svref_2object($sub)) { 293 if (my $subfile = $cobj->FILE) { 294 next unless $cb->( 295 mod => $mod, 296 sym => $sym, 297 sub => $sub, 298 from_file => -f $subfile ? clean_path($subfile) : $subfile, 299 reload_file => -f $file ? clean_path($file) : $file, 300 ); 301 } 302 } 303 } 304 } 305 306 delete $stash->{$sym}; 307 } 308 309 delete $INC{$rel}; 310 local $.; 311 require $rel; 312 die "Reloading '$rel' loaded $INC{$rel} instead, \@INC must have been altered" if $INC{$rel} ne $file; 313 314 1; 315 }; 316 my $err = $@; 317 318 next if $ok && !@warnings; 319 print "$$ $0 - Failed to reload '$file' in place...\n", map { " $$ $0 - $_\n" } map { split /\n/, $_ } grep { $_ } @warnings, $ok ? () : ($err); 320 push @todo => [$mod, $file]; 321 } 322 323 if ($self->{+RELOAD}) { 324 $dtrace->stop; 325 326 unless (@todo) { 327 delete $self->{+MONITORED}; 328 $self->_monitor(); 329 return 0; 330 } 331 } 332 333 $self->{+CHANGED} = 1; 334 print "$$ $0 - blacklisting changed files and reloading stage...\n"; 335 336 my $bl = $self->_lock_blacklist(); 337 338 my $dep_map = $self->dtrace->dep_map; 339 340 my %seen; 341 while (@todo) { 342 my $set = shift @todo; 343 my ($pkg, $full) = @$set; 344 my $file = $CNI{$full} || $full; 345 next if $seen{$file}++; 346 next if $pkg->can('TEST2_HARNESS_PRELOAD'); 347 print $bl "$pkg\n"; 348 my $next = $dep_map->{$file} or next; 349 push @todo => @$next; 350 } 351 352 $self->_unlock_blacklist(); 353 354 return 1; 355} 356 357sub get_stage_callback { 358 my $self = shift; 359 my ($name) = @_; 360 361 my $stage = $self->{+STAGE} or return undef; 362 return undef unless ref $stage; 363 return $stage->$name; 364} 365 366sub _monitor_preload { 367 my $self = shift; 368 my ($preloads) = @_; 369 370 my $block = {%{$self->blacklist}}; 371 my $dtrace = $self->dtrace; 372 373 $dtrace->start; 374 $self->_preload($preloads, $block, $dtrace->my_require); 375 $dtrace->stop; 376 377 return; 378} 379 380sub _preload { 381 my $self = shift; 382 my ($preloads, $block, $require_sub) = @_; 383 384 $block //= {}; 385 386 my %seen; 387 for my $mod (@$preloads) { 388 next if $seen{$mod}++; 389 390 if (ref($mod) eq 'CODE') { 391 next if eval { $mod->($block, $require_sub); 1 }; 392 $self->{+MONITOR} ? warn $@ : die $@; 393 next; 394 } 395 396 next if $block && $block->{$mod}; 397 398 next if eval { $self->_preload_module($mod, $block, $require_sub); 1 }; 399 $self->{+MONITOR} ? warn $@ : die $@; 400 } 401 402 return; 403} 404 405sub _preload_module { 406 my $self = shift; 407 my ($mod, $block, $require_sub) = @_; 408 409 my $file = mod2file($mod); 410 411 $require_sub ? $require_sub->($file) : require $file; 412 413 return unless $mod->can('TEST2_HARNESS_PRELOAD'); 414 415 die "You cannot load a Test2::Harness::Runner::Preload module from within another" if $self->{+DONE}; 416 417 $self->{+STAGED} //= do { 418 require Test2::Harness::Runner::Preload; 419 Test2::Harness::Runner::Preload->new(); 420 }; 421 422 $self->{+STAGED}->merge($mod->TEST2_HARNESS_PRELOAD); 423 424 return; 425} 426 427sub eager_stages { 428 my $self = shift; 429 430 return unless $self->{+STAGED}; 431 return $self->{+STAGED}->eager_stages; 432} 433 434sub load_blacklist { 435 my $self = shift; 436 437 my $bfile = $self->{+BLACKLIST_FILE}; 438 my $blacklist = $self->{+BLACKLIST}; 439 440 return unless -f $bfile; 441 442 my $fh = open_file($bfile, '<'); 443 while(my $pkg = <$fh>) { 444 chomp($pkg); 445 $blacklist->{$pkg} = 1; 446 } 447} 448 449sub _monitor { 450 my $self = shift; 451 452 if ($self->{+MONITORED} && $self->{+MONITORED}->[0] == $$) { 453 die "Monitor already starated\n" . "\n=======\n$0\n" . Carp::longmess() . "\n=====\n" . $self->{+MONITORED}->[1] . "\n" . $self->{+MONITORED}->[2] . "\n=======\n"; 454 } 455 456 delete $self->{+INOTIFY}; 457 $self->{+MONITORED} = [$$, $0, Carp::longmess()]; 458 459 my $dtrace = $self->dtrace; 460 $self->{+STATS} //= {}; 461 462 return $self->_monitor_inotify() if USE_INOTIFY(); 463 return $self->_monitor_hardway(); 464} 465 466sub _should_watch { 467 my $self = shift; 468 my ($file) = @_; 469 470 my $dirs = $self->{+RESTRICT_RELOAD}; 471 return 1 unless $dirs && @$dirs; 472 473 for my $dir (@$dirs) { 474 return 1 if 0 == index($file, $dir); 475 } 476 477 return 0; 478} 479 480sub _monitor_inotify { 481 my $self = shift; 482 483 my $dtrace = $self->dtrace; 484 485 my $inotify = $self->{+INOTIFY} = Linux::Inotify2->new; 486 $inotify->blocking(0); 487 488 for my $file (keys %{$dtrace->loaded}) { 489 $file = $INC{$file} || $file; 490 next unless $self->_should_watch($file); 491 next unless -e $file; 492 $inotify->watch($file, INOTIFY_MASK()); 493 } 494 495 return; 496} 497 498sub _monitor_hardway { 499 my $self = shift; 500 501 my $dtrace = $self->dtrace; 502 my $stats = $self->{+STATS} ||= {}; 503 504 for my $file (keys %{$dtrace->loaded}) { 505 $file = $INC{$file} || $file; 506 next unless $self->_should_watch($file); 507 next if $stats->{$file}; 508 next unless -e $file; 509 my (undef, undef, undef, undef, undef, undef, undef, undef, undef, $mtime, $ctime) = stat($file); 510 $stats->{$file} = [$mtime, $ctime]; 511 } 512 513 return; 514} 515 516 517sub _check_monitored_inotify { 518 my $self = shift; 519 my $inotify = $self->{+INOTIFY} or return; 520 521 my @todo = $inotify->read or return; 522 523 return {map { ($_->fullname() => 1) } @todo}; 524} 525 526sub _check_monitored_hardway { 527 my $self = shift; 528 529 # Only check once every 2 seconds 530 return if $self->{+LAST_CHECKED} && 2 > (time - $self->{+LAST_CHECKED}); 531 532 my (%changed, $found); 533 for my $file (keys %{$self->{+STATS}}) { 534 my (undef, undef, undef, undef, undef, undef, undef, undef, undef, $mtime, $ctime) = stat($file); 535 my $times = $self->{+STATS}->{$file}; 536 next if $mtime == $times->[0] && $ctime == $times->[1]; 537 $self->{+STATS}->{$file} = [$mtime, $ctime]; 538 $found++; 539 $changed{$file}++; 540 } 541 542 $self->{+LAST_CHECKED} = time; 543 544 return unless $found; 545 return \%changed; 546} 547 548sub _lock_blacklist { 549 my $self = shift; 550 551 return $self->{+BLACKLIST_LOCK} if $self->{+BLACKLIST_LOCK}; 552 553 my $bl = lock_file($self->{+BLACKLIST_FILE}, '>>'); 554 seek($bl,2,0); 555 556 return $self->{+BLACKLIST_LOCK} = $bl; 557} 558 559sub _unlock_blacklist { 560 my $self = shift; 561 562 my $bl = delete $self->{+BLACKLIST_LOCK} or return; 563 564 $bl->flush; 565 unlock_file($bl); 566 close($bl); 567 568 return; 569} 570 5711; 572 573 574__END__ 575 576=pod 577 578=encoding UTF-8 579 580=head1 NAME 581 582Test2::Harness::Runner::Preloader - Preload logic. 583 584=head1 DESCRIPTION 585 586This module is responsible for preloading libraries before running tests. This 587entire module is considered an "Implementation Detail". Please do not rely on 588it always staying the same, or even existing in the future. Do not use this 589directly. 590 591=head1 SOURCE 592 593The source code repository for Test2-Harness can be found at 594F<http://github.com/Test-More/Test2-Harness/>. 595 596=head1 MAINTAINERS 597 598=over 4 599 600=item Chad Granum E<lt>exodist@cpan.orgE<gt> 601 602=back 603 604=head1 AUTHORS 605 606=over 4 607 608=item Chad Granum E<lt>exodist@cpan.orgE<gt> 609 610=back 611 612=head1 COPYRIGHT 613 614Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>. 615 616This program is free software; you can redistribute it and/or 617modify it under the same terms as Perl itself. 618 619See F<http://dev.perl.org/licenses/> 620 621=cut 622 623