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