1use Test2::V0;
2
3use Config qw/%Config/;
4use File::Temp qw/tempfile/;
5use File::Spec;
6
7use App::Yath::Tester qw/yath/;
8use Test2::Harness::Util::File::JSONL;
9
10use Test2::Harness::Util       qw/clean_path/;
11use Test2::Harness::Util::JSON qw/decode_json/;
12
13my $dir = __FILE__;
14$dir =~ s{\.t$}{}g;
15$dir =~ s{^\./}{};
16
17yath(
18    command => 'test',
19    args    => [$dir, '--ext=tx', '--ext=txx'],
20    exit    => T(),
21    test    => sub {
22        my $out = shift;
23
24        like($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the output");
25        like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output");
26    },
27);
28
29yath(
30    command => 'test',
31    args    => [$dir, '--ext=tx'],
32    exit    => 0,
33    test    => sub {
34        my $out = shift;
35        unlike($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the output");
36        like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output");
37    },
38);
39
40yath(
41    command => 'test',
42    args => [$dir, '--ext=txx'],
43    exit => T(),
44    test => sub {
45        my $out = shift;
46
47        like($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was seen as a failure when reading the output");
48        unlike($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output");
49    },
50);
51
52yath(
53    command => 'test',
54    args => [$dir, '-vvv'],
55    exit => T(),
56    test => sub {
57        my $out = shift;
58
59        like($out->{output}, qr/No tests were seen!/, "Got error message");
60    },
61);
62
63
64note q[Checking --exclude-file option when a file is provided on the command line];
65
66yath(
67    command => 'test',
68    args    => [ "--exclude-file=$dir/fail.txx", "$dir/pass.tx", "$dir/fail.txx" ],
69    exit    => 0,
70    test    => sub {
71        my $out = shift;
72
73        unlike($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was excluded using '--exclude-file' option");
74        like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output");
75    },
76);
77
78note q[Checking --exclude-list option when a file is provided on the command line];
79
80my ($fh, $list_name) = tempfile(UNLINK => 1);
81print $fh "# GENERATED YATH TEST EXCLUSION LIST\n#$dir/pass.tx\n$dir/fail.txx";
82close($fh);
83
84yath(
85    command => 'test',
86    args    => ["--exclude-list=$list_name", "$dir/pass.tx", "$dir/fail.txx"],
87    exit    => 0,
88    test    => sub {
89        my $out = shift;
90
91        unlike($out->{output}, qr{FAILED.*fail\.tx}, "'fail.tx' was excluded using '--exclude-list' option with a file");
92        like($out->{output}, qr{PASSED.*pass\.tx}, "'pass.tx' was not seen as a failure when reading the output");
93    },
94);
95
96{
97    note q[Testsuite using symlinks: check that $0 is preserved];
98
99    my $sdir = $dir . '-symlinks';
100    my $base    = "$sdir/_base.xt";
101    my $symlink = "$sdir/symlink_to_base.xt";
102
103    unlink $symlink if -e $symlink;
104    if ( eval{ symlink('_base.xt', $symlink) } ) {
105
106        yath(
107            command => 'test',
108            args => [$sdir, '--ext=xt' ],
109            exit => 0,
110            test => sub {
111                my $out = shift;
112
113                like($out->{output}, qr{SKIPPED.*\Q$base\E}, "'_base.xt' was skipped");
114                like($out->{output}, qr{PASSED.*\Q$symlink\E}, "'symlink_to_base.xt' passed [and is not skipped]");
115            },
116        );
117
118        yath(
119            command => 'test',
120            args => [ $base, $symlink ],
121            exit => 0,
122            test => sub {
123                my $out = shift;
124
125                like($out->{output}, qr{SKIPPED.*\Q$base\E}, "'_base.xt' was skipped");
126                like($out->{output}, qr{PASSED.*\Q$symlink\E}, "'symlink_to_base.xt' passed [and is not skipped]");
127            },
128        );
129
130
131    }
132
133}
134
135{
136    note q[Testsuite checking broken symlinks #103];
137
138    my $sdir = $dir . '-broken-symlinks';
139    my $symlink = "$sdir/broken-symlink.tx";
140
141    unlink $symlink if -e $symlink;
142    if ( eval{ symlink('nothing-there', $symlink) } ) {
143
144        yath(
145            command => 'test',
146            args => [$sdir, '--ext=tx' ],
147            exit => 0,
148            test => sub {
149                my $out = shift;
150
151                unlike($out->{output}, qr{FAILED}, q[no failures]);
152                unlike($out->{output}, qr{\Qbroken-symlink.tx\E}, q[no mention of broken-symlink.tx] );
153                like($out->{output}, qr{PASSED.*\Qt/integration/test-broken-symlinks/pass.tx\E}, q[t/integration/test-broken-symlinks/pass.tx PASSED]);
154            },
155        );
156    }
157}
158
159{
160    note "Testing durations when provided using a json file";
161
162    my $sdir = $dir . '-durations';
163
164    # using a directory
165    yath(
166        command => 'test',
167        args => [ '-v', '-j1', '--durations', "$sdir/../test-durations.json", '--ext=tx', $sdir, ],
168        exit => 0,
169        test => sub {
170            my $out = shift;
171
172            my @lines = sort {
173                my ($aj) = ($a =~ m/job\s+(\d+)/) or return 0;
174                my ($bj) = ($b =~ m/job\s+(\d+)/) or return 0;
175                return $aj <=> $bj;
176            } grep { m/\Q( PASSED )\E/ } split /\n/, $out->{output};
177
178            is \@lines, array {
179
180                item match qr{\Qslow-01.tx\E};
181                item match qr{\Qslow-02.tx\E};
182                item match qr{\Qfast-01.tx\E};
183                item match qr{\Qfast-02.tx\E};
184                item match qr{\Qfast-03.tx\E};
185                item match qr{\Qfast-04.tx\E};
186
187                end;
188            }, "tests are run in order from slow to fast - using a directory";
189        },
190    );
191
192    # using a list of files
193    my @files = (
194            "$sdir/fast-01.tx", "$sdir/fast-02.tx", "$sdir/fast-03.tx", "$sdir/fast-04.tx",
195            "$sdir/slow-01.tx", "$sdir/slow-02.tx"
196    );
197    my %hfiles = map { $_ => 1 } @files;
198    yath(
199        command => 'test',
200        args => [ '-v', '-j1', '--durations', "$sdir/../test-durations.json", '--ext=tx',
201            keys %hfiles, # random order
202        ],
203        exit => 0,
204        test => sub {
205            my $out = shift;
206
207            my @lines = sort {
208                my ($aj) = ($a =~ m/job\s+(\d+)/) or return 0;
209                my ($bj) = ($b =~ m/job\s+(\d+)/) or return 0;
210                return $aj <=> $bj;
211            } grep { m/\Q( PASSED )\E/ } split /\n/, $out->{output};
212
213            is \@lines, array {
214
215                item match qr{\Qslow-01.tx\E};
216                item match qr{\Qslow-02.tx\E};
217                item match qr{\Qfast-01.tx\E};
218                item match qr{\Qfast-02.tx\E};
219                item match qr{\Qfast-03.tx\E};
220                item match qr{\Qfast-04.tx\E};
221
222                end;
223            }, "tests are run in order from slow to fast - using a list of files";
224        },
225    );
226}
227
228if ("$]" >= 5.026) {
229    note q[Checking %INC and @INC setup];
230
231    local @INC =  map { clean_path( $_ ) } grep { $_ ne '.' } @INC;
232    local $ENV{PERL5LIB} = join $Config{path_sep}, map { clean_path( $_ ) } grep { $_ ne '.' } split( $Config{path_sep}, $ENV{PERL5LIB} );
233    local $ENV{PERL_USE_UNSAFE_INC};
234    delete $ENV{PERL_USE_UNSAFE_INC};
235
236    my $sdir = $dir . '-inc';
237
238    yath(
239        command => 'test',
240        args => ['--ext=tx', '--no-unsafe-inc', $sdir],
241        exit => 0,
242        test => sub {
243            my $out = shift;
244
245            unlike($out->{output}, qr{FAILED}, q[no failures]);
246        },
247    );
248}
249
250yath(
251    command => 'test',
252    args    => [$dir, '--ext=txxx', '::', 'foobar', 'baz' ],
253    exit    => 0,
254    test    => sub {
255        my $out = shift;
256        like($out->{output}, qr{PASSED}, 'Args after arisdottle are added to @ARGV');
257    },
258);
259
260done_testing;
261