1package Test2::Harness::TestFile;
2use strict;
3use warnings;
4
5our $VERSION = '1.000082';
6
7use Carp qw/croak/;
8
9use Time::HiRes qw/time/;
10
11use List::Util 1.45 qw/uniq/;
12
13use Test2::Harness::Util qw/open_file clean_path/;
14
15use Test2::Harness::Util::UUID qw/gen_uuid/;
16
17use File::Spec;
18
19use Test2::Harness::Util::HashBase qw{
20    <file +relative <_scanned <_headers +_shbang <is_binary <non_perl
21    input env_vars test_args
22    queue_args
23    job_class
24    comment
25    _category _stage _duration
26};
27
28sub set_duration { $_[0]->set__duration(lc($_[1])) }
29sub set_category { $_[0]->set__category(lc($_[1])) }
30
31sub set_stage { $_[0]->set__stage($_[1]) }
32
33sub retry { $_[0]->headers->{retry} }
34sub set_retry {
35    my $self = shift;
36    my $val = @_ ? $_[0] : 1;
37
38    $self->scan;
39
40    $self->{+_HEADERS}->{retry} = $val;
41}
42
43sub retry_isolated { $_[0]->headers->{retry_isolated} }
44sub set_retry_isolated {
45    my $self = shift;
46    my $val = @_ ? $_[0] : 1;
47
48    $self->scan;
49
50    $self->{+_HEADERS}->{retry_isolated} = $val;
51}
52
53sub set_smoke {
54    my $self = shift;
55    my $val = @_ ? $_[0] : 1;
56
57    $self->scan;
58
59    $self->{+_HEADERS}->{features}->{smoke} = $val;
60}
61
62sub init {
63    my $self = shift;
64
65    my $file = $self->file;
66
67    # We want absolute path
68    $file = clean_path($file, 0);
69    $self->{+FILE} = $file;
70
71    $self->{+QUEUE_ARGS} ||= [];
72
73    croak "Invalid test file '$file'" unless -f $file;
74
75    if($self->{+IS_BINARY} = -B $file && !-z $file) {
76        $self->{+NON_PERL} = 1;
77        die "Cannot run binary test file '$file': file is not executable.\n"
78            unless $self->is_executable;
79    }
80}
81
82sub relative {
83    my $self = shift;
84    return $self->{+RELATIVE} //= File::Spec->abs2rel($self->{+FILE});
85}
86
87my %DEFAULTS = (
88    timeout   => 1,
89    fork      => 1,
90    preload   => 1,
91    stream    => 1,
92    run       => 1,
93    isolation => 0,
94    smoke     => 0,
95    io_events => 1,
96);
97
98sub check_feature {
99    my $self = shift;
100    my ($feature, $default) = @_;
101
102    $default = $DEFAULTS{$feature} unless defined $default;
103
104    return $default unless defined $self->headers->{features}->{$feature};
105    return 1 if $self->headers->{features}->{$feature};
106    return 0;
107}
108
109sub check_stage {
110    my $self = shift;
111
112    return $self->{+_STAGE} if $self->{+_STAGE};
113
114    $self->_scan unless $self->{+_SCANNED};
115    return $self->{+_HEADERS}->{stage} || undef;
116}
117
118sub meta {
119    my $self = shift;
120    my ($key) = @_;
121
122    $self->_scan unless $self->{+_SCANNED};
123    my $meta = $self->{+_HEADERS}->{meta} or return ();
124
125    return () unless $key && $meta->{$key};
126
127    return @{$meta->{$key}};
128}
129
130sub check_duration {
131    my $self = shift;
132
133    return $self->{+_DURATION} if $self->{+_DURATION};
134
135    $self->_scan unless $self->{+_SCANNED};
136    my $duration = $self->{+_HEADERS}->{duration};
137    return $duration if $duration;
138
139    my $timeout = $self->check_feature(timeout => 1);
140
141    # 'long' for anything with no timeout
142    return 'long' unless $timeout;
143
144    return 'medium';
145}
146
147sub check_category {
148    my $self = shift;
149
150    return $self->{+_CATEGORY} if $self->{+_CATEGORY};
151
152    $self->_scan unless $self->{+_SCANNED};
153    my $category = $self->{+_HEADERS}->{category};
154
155    return $category if $category;
156
157    my $isolate = $self->check_feature(isolation => 0);
158
159    # 'isolation' queue if isolation requested
160    return 'isolation' if $isolate;
161
162    return 'general';
163}
164
165sub event_timeout    { $_[0]->headers->{timeout}->{event} }
166sub post_exit_timeout { $_[0]->headers->{timeout}->{postexit} }
167
168sub conflicts_list {
169    return $_[0]->headers->{conflicts} || [];    # Assure conflicts is always an array ref.
170}
171
172sub headers {
173    my $self = shift;
174    $self->_scan unless $self->{+_SCANNED};
175    return {} unless $self->{+_HEADERS};
176    return {%{$self->{+_HEADERS}}};
177}
178
179sub shbang {
180    my $self = shift;
181    $self->_scan unless $self->{+_SCANNED};
182    return {} unless $self->{+_SHBANG};
183    return {%{$self->{+_SHBANG}}};
184}
185
186sub switches {
187    my $self = shift;
188
189    my $shbang   = $self->shbang       or return [];
190    my $switches = $shbang->{switches} or return [];
191
192    return $switches;
193}
194
195sub is_executable {
196    my $self = shift;
197    my ($file) = @_;
198    $file //= $self->{+FILE};
199    return -x $file;
200}
201
202sub scan {
203    my $self = shift;
204    $self->_scan();
205    return;
206}
207
208sub _scan {
209    my $self = shift;
210
211    return if $self->{+_SCANNED}++;
212    return if $self->{+IS_BINARY};
213
214    my $fh = open_file($self->{+FILE});
215    my $comment = $self->{+COMMENT} // '#';
216
217    my %headers;
218    for (my $ln = 1; my $line = <$fh>; $ln++) {
219        chomp($line);
220        next if $line =~ m/^\s*$/;
221
222        if ($ln == 1 && $line =~ m/^#!/) {
223            my $shbang = $self->_parse_shbang($line);
224            if ($shbang) {
225                $self->{+_SHBANG} = $shbang;
226
227                if ($shbang->{non_perl}) {
228                    $self->{+NON_PERL} = 1;
229
230                    die "Cannot run non-perl test file '" . $self->{+FILE} . "': file is not executable.\n"
231                        unless $self->is_executable;
232                }
233
234                next;
235            }
236        }
237
238        # Uhg, breaking encapsulation between yath and the harness
239        if ($line =~ m/^\s*#\s*THIS IS A GENERATED YATH RUNNER TEST/) {
240            $headers{features}->{run} = 0;
241            next;
242        }
243
244        next if $line =~ m/^\s*#/ && $line !~ m/^\s*#\s*HARNESS-.+/;    # Ignore commented lines which aren't HARNESS-?
245        next if $line =~ m/^\s*(use|require|BEGIN|package)\b/;          # Only supports single line BEGINs
246        last unless $line =~ m/^\s*\Q$comment\E\s*HARNESS-(.+)$/;
247
248        my ($dir, $rest) = split /[-\s]+/, $1, 2;
249        $dir = lc($dir);
250        my @args;
251        if ($dir eq 'meta') {
252            @args = split /\s+/, $rest, 2;                              # Check for white space delimited
253            @args = split(/[-]+/, $rest, 2) if scalar @args == 1;       # Check for dash delimited
254            $args[1] =~ s/\s+(?:#.*)?$//;                               # Strip trailing white space and comment if present
255        }
256        elsif ($rest) {
257            $rest =~ s/\s+(?:#.*)?$//;                                  # Strip trailing white space and comment if present
258            @args = split /[-\s]+/, $rest;
259        }
260
261        if ($dir eq 'no') {
262            my $feature = lc(join '_' => @args);
263            if ($feature eq 'retry') {
264                $headers{retry} = 0
265            } else {
266                $headers{features}->{$feature} = 0;
267            }
268        }
269        elsif ($dir eq 'smoke') {
270            $headers{features}->{smoke} = 1;
271        }
272        elsif ($dir eq 'retry') {
273            $headers{retry} = 1 unless @args || defined $headers{retry};
274            for my $arg (@args) {
275                if ($arg =~ m/^\d+$/) {
276                    $headers{retry} = int $arg;
277                }
278                elsif ($arg =~ m/^iso/i) {
279                    $headers{retry} //= 1;
280                    $headers{retry_isolated} = 1;
281                }
282                else {
283                    warn "Unknown 'HARNESS-RETRY' argument '$arg' at $self->{+FILE} line $ln.\n";
284                }
285            }
286        }
287        elsif ($dir eq 'yes' || $dir eq 'use') {
288            my $feature = lc(join '_' => @args);
289            $headers{features}->{$feature} = 1;
290        }
291        elsif ($dir eq 'stage') {
292            my ($name) = @args;
293            $headers{stage} = $name;
294        }
295        elsif ($dir eq 'meta') {
296            my ($key, $val) = @args;
297            $key = lc($key);
298            push @{$headers{meta}->{$key}} => $val;
299        }
300        elsif ($dir eq 'duration' || $dir eq 'dur') {
301            my ($name) = @args;
302            $name = lc($name);
303            $headers{duration} = $name;
304        }
305        elsif ($dir eq 'category' || $dir eq 'cat') {
306            my ($name) = @args;
307            $name = lc($name);
308            if ($name =~ m/^(long|medium|short)$/i) {
309                $headers{duration} = $name;
310            }
311            else {
312                $headers{category} = $name;
313            }
314        }
315        elsif ($dir eq 'conflicts') {
316            my @conflicts_array;
317
318            foreach my $arg (@args) {
319                push @conflicts_array, lc($arg);
320            }
321
322            # Allow multiple lines with # HARNESS-CONFLICTS FOO
323            $headers{conflicts} ||= [];
324            push @{$headers{conflicts}}, @conflicts_array;
325
326            # Make sure no more than 1 conflict is ever present.
327            @{$headers{conflicts}} = uniq @{$headers{conflicts}};
328        }
329        elsif ($dir eq 'timeout') {
330            my ($type, $num, $extra) = @args;
331            $type = lc($type);
332            $num = lc($num);
333
334            ($type, $num) = ('postexit', $extra) if $type eq 'post' && $num eq 'exit';
335
336            warn "'" . uc($type) . "' is not a valid timeout type, use 'EVENT' or 'POSTEXIT' at $self->{+FILE} line $ln.\n"
337                unless $type =~ m/^(event|postexit)$/;
338
339            $headers{timeout}->{$type} = $num;
340        }
341        else {
342            warn "Unknown harness directive '$dir' at $self->{+FILE} line $ln.\n";
343        }
344    }
345
346    $self->{+_HEADERS} = \%headers;
347}
348
349sub _parse_shbang {
350    my $self = shift;
351    my $line = shift;
352
353    return {} if !defined $line;
354
355    my %shbang;
356
357    # NOTE: Test this, the dashes should be included with the switches
358    my $shbang_re = qr{
359        ^
360          \#!.*perl.*?        # the perl path
361          (?: \s (-.+) )?       # the switches, maybe
362          \s*
363        $
364    }xi;
365
366    if ($line =~ $shbang_re) {
367        my @switches = grep { m/\S/ } split /\s+/, $1 if defined $1;
368        $shbang{switches} = \@switches;
369        $shbang{line}     = $line;
370    }
371    elsif ($line =~ m/^#!/ && $line !~ m/perl/i) {
372        $shbang{line} = $line;
373        $shbang{non_perl} = 1;
374    }
375
376    return \%shbang;
377}
378
379sub queue_item {
380    my $self = shift;
381    my ($job_name, $run_id, %inject) = @_;
382
383    die "The '$self->{+FILE}' test specifies that it should not be run by Test2::Harness.\n"
384        unless $self->check_feature(run => 1);
385
386    my $category = $self->check_category;
387    my $duration = $self->check_duration;
388    my $stage    = $self->check_stage;
389
390    my $smoke     = $self->check_feature(smoke     => 0);
391    my $fork      = $self->check_feature(fork      => 1);
392    my $preload   = $self->check_feature(preload   => 1);
393    my $timeout   = $self->check_feature(timeout   => 1);
394    my $stream    = $self->check_feature(stream    => 1);
395    my $io_events = $self->check_feature(io_events => 1);
396
397    my $retry          = $self->retry;
398    my $retry_isolated = $self->retry_isolated;
399
400    my $binary   = $self->{+IS_BINARY} ? 1 : 0;
401    my $non_perl = $self->{+NON_PERL}  ? 1 : 0;
402
403    my $et  = $self->event_timeout;
404    my $pet = $self->post_exit_timeout;
405
406    my $job_class = $self->job_class;
407
408    my $input     = $self->input;
409    my $test_args = $self->test_args;
410
411    my $env_vars = $self->env_vars;
412    if ($env_vars) {
413        my $mix = delete $inject{env_vars};
414        $env_vars = {%$mix, %$env_vars} if $mix;
415    }
416
417    return {
418        binary      => $binary,
419        category    => $category,
420        conflicts   => $self->conflicts_list,
421        duration    => $duration,
422        file        => $self->file,
423        rel_file    => $self->relative,
424        job_id      => gen_uuid(),
425        job_name    => $job_name,
426        run_id      => $run_id,
427        non_perl    => $non_perl,
428        stage       => $stage,
429        stamp       => time,
430        switches    => $self->switches,
431        use_fork    => $fork,
432        use_preload => $preload,
433        use_stream  => $stream,
434        use_timeout => $timeout,
435        smoke       => $smoke,
436        io_events   => $io_events,
437        rank        => $self->rank,
438
439        defined($input)          ? (input             => $input)                   : (),
440        defined($env_vars)       ? (env_vars          => $env_vars)                : (),
441        defined($test_args)      ? (test_args         => $test_args)               : (),
442        defined($job_class)      ? (job_class         => $job_class)               : (),
443        defined($retry)          ? (retry             => $retry)                   : (),
444        defined($retry_isolated) ? (retry_isolated    => $retry_isolated)          : (),
445        defined($et)             ? (event_timeout     => $et)                      : (),
446        defined($pet)            ? (post_exit_timeout => $self->post_exit_timeout) : (),
447
448        @{$self->{+QUEUE_ARGS}},
449
450        %inject,
451    };
452}
453
454my %RANK = (
455    smoke      => 1,
456    immiscible => 10,
457    long       => 20,
458    medium     => 50,
459    short      => 80,
460    isolation  => 100,
461);
462
463sub rank {
464    my $self = shift;
465
466    return $RANK{smoke} if $self->check_feature('smoke');
467
468    my $rank = $RANK{$self->check_category};
469    $rank ||= $RANK{$self->check_duration};
470    $rank ||= 1;
471
472    return $rank;
473}
474
4751;
476
477__END__
478
479=pod
480
481=encoding UTF-8
482
483=head1 NAME
484
485Test2::Harness::TestFile - Abstraction of a test file and its meta-data.
486
487=head1 DESCRIPTION
488
489When Test2::Harness finds test files to run each one gets an instance of this
490class to represent it. This class will scan test files to find important meta
491data (binary vs script, inline harness directives, etc). The meta-data this
492class can find helps yath decide when and how to run the test.
493
494If you write a custom L<Test2::Harness::Finder> or use some
495L<Test2::Harness::Plugin> callbacks you may have to use, or even construct
496instances of this class.
497
498=head1 SYNOPSIS
499
500    use Test2::Harness::TestFile;
501
502    my $tf = Test2::Harness::TestFile->new(file => "path/to/file.t");
503
504    # For an example 1, 1 works, but normally they are job_name and run_id.
505    my $meta_data = $tf->queue_item(1, 1);
506
507
508=head1 ATTRIBUTES
509
510=over 4
511
512=item $filename = $tf->file
513
514Set during object construction, and cannot be changed.
515
516=item $bool = $tf->is_binary
517
518Automatically set during construction, cannot be changed or set manually.
519
520=item $bool = $tf->non_perl
521
522Automatically set during construction, cannot be changed or set manually.
523
524=item $string = $tf->comment
525
526=item $tf->set_comment($string)
527
528Defaults to '#' can be set during construction, or changed if needed.
529
530This is used to tell yath what character(s) are used to denote a comment. This
531is necessary for finding harness directives. In perl the '#' character is used,
532and that is the default value. This is here to support non-perl tests.
533
534=item $class = $tf->job_class
535
536=item $tf->set_job_class($class)
537
538Default it undef (let the runner pick). You can change this if you want the
539test to run with a custom job subclass.
540
541=item $arrayref = $tf->queue_args
542
543=item $tf->set_queue_args(\@ARGS)
544
545Key/Value pairs to append to the queue_item() data.
546
547=back
548
549=head1 METHODS
550
551=over 4
552
553=item $cat = $tf->check_category()
554
555=item $tf->set_category($cat)
556
557This is how you find the category for a file. You can use C<set_category()> to
558assign/override a category.
559
560=item $dur = $tf->check_duration()
561
562=item $tf->set_duration($dur)
563
564Get the duration of the test file ('LONG', 'MEDIUM', 'SHORT'). You can override
565with C<set_duration()>.
566
567=item $stage = $tf->check_stage()
568
569=item $tf->set_stage($stage)
570
571Get the preload stage the test file thinks it should be run in. You can
572override with C<set_stage()>.
573
574=item $bool = $tf->check_feature($name)
575
576This checks for the C<# HARNESS-NO-NAME> or C<# HARNESS-USE-NAME> or
577C<# HARNESS-YES-NAME> directives. C<NO> will result in a false boolean. C<YES>
578and C<USE> will result in a ture boolean. If no directive is found then
579C<undef> will be returned.
580
581=item $arrayref = $tf->conflicts_list()
582
583Get a list of conflict markers.
584
585=item $seconds = $tf->event_timeout()
586
587If they test specifies an event timeout this will return it.
588
589=item %headers = $tf->headers()
590
591This returns the header data from the test file.
592
593=item $bool = $tf->is_executable()
594
595Check if the test file is executable or not.
596
597=item $data = $tf->meta($key)
598
599Get the meta-data for the specific key.
600
601=item $seconds = $tf->post_exit_timeout()
602
603If the test file has a custom post-exit timeout, this will return it.
604
605=item $hashref = $tf->queue_item($job_name, $run_id)
606
607This returns the data used to add the test file to the runner queue.
608
609=item $int = $tf->rank()
610
611Returns an integer value used to sort tests into an efficient run order.
612
613=item $path = $tf->relative()
614
615Relative path to the test file.
616
617=item $tf->scan()
618
619Scan the file and populate the header data. Return nothing, takes no arguments.
620Automatically run by things that require the scan data. Results are cached.
621
622=item $tf->set_smoke($bool)
623
624Set smoke status. Smoke tests go to the front of the line when tests are
625sorted.
626
627=item $hashref = $tf->shbang()
628
629Get data gathered from parsing the tests shbang line.
630
631=item $arrayref = $tf->switches()
632
633A list of switches passed to perl, usually from the shbang line.
634
635=back
636
637=head1 SOURCE
638
639The source code repository for Test2-Harness can be found at
640F<http://github.com/Test-More/Test2-Harness/>.
641
642=head1 MAINTAINERS
643
644=over 4
645
646=item Chad Granum E<lt>exodist@cpan.orgE<gt>
647
648=back
649
650=head1 AUTHORS
651
652=over 4
653
654=item Chad Granum E<lt>exodist@cpan.orgE<gt>
655
656=back
657
658=head1 COPYRIGHT
659
660Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>.
661
662This program is free software; you can redistribute it and/or
663modify it under the same terms as Perl itself.
664
665See F<http://dev.perl.org/licenses/>
666
667=cut
668