File Coverage

File:t/01.t
Coverage:80.8%

linestmtbrancondsubtimecode
1#!/usr/bin/env perl
2
3
1
1
1
1
1108
1
8
use strict;
4
1
1
1
1
1
0
18
use warnings FATAL => 'all';
5
1
411
require 5.010;
6
1
1
1
1
1
0
30
use feature 'say';
7
1
1
1
1
162
21671
2
use Test::More;
8
1
1
1
1
174
805
0
use Test::Exception; # die_ok / lives_ok
9
1
1
1
1
310
4813
19
use File::Temp 'tempfile';
10
1
1
1
1
2
0
9
use Cwd 'getcwd';
11
1
1
1
1
61
8740
2
use DDP;
12
1
1
1
1
123
1
22115
use SimpleFlow qw(task say2);
13
14#
15# Portability: the original tests called Unix-only tools (which/ls/ln/cp) and
16# hard-coded /tmp, which fails on Windows CPAN testers. Use the running Perl
17# interpreter instead -- it is always present -- and let File::Temp pick the
18# system temp dir. $^X is quoted in case its path contains spaces (Windows).
19# NB: the $code passed to perl_cmd() must not itself contain double quotes.
20#
21
1
2
my $PERL = qq{"$^X"};
22
22
22
22
27
78
sub perl_cmd { my $code = shift; return qq{$PERL -e "$code"} }
23
24
1
1
my ($simple_task, $log_write, $stopping, $dry_run, $overwrite) = (0,0,0,0,0);
25
26# --- a simple, successful task
27
1
1
my $r = task({
28        cmd => perl_cmd('exit 0')
29});
30
1
50
14
12
if (
31                ($r->{'die'}) &&
32                ($r->{done} eq 'now') &&
33                (!$r->{'exit'}) &&
34                ($r->{overwrite} == 0) &&
35                (ref $r->{'output.files'} eq 'ARRAY') &&
36
1
3
                (scalar @{ $r->{'output.files'} } == 0)
37        ) {
38
1
1
        $simple_task = 1;
39} else {
40
0
0
        p $r;
41
0
0
        die 'test failed';
42}
43
44# --- writing to a log file + say2
45
1
3
my ($fh, $fname) = tempfile( UNLINK => 0, SUFFIX => '.log' );
46
1
203
$r = task({
47        cmd            => perl_cmd('exit 0'),
48        'log.fh'       => $fh,
49        'output.files' => $fname,
50        overwrite      => 1
51});
52
1
12
say2('Testing say2', $fh);
53
1
12
close $fh;
54
1
50
33
8
$log_write = 1 if ((-f $fname) && (-s $fname > 0));
55
56# --- re-run: task must notice the output already exists
57
1
3
$r = task({
58        cmd            => perl_cmd('exit 0'),
59        'output.files' => $fname,
60        overwrite      => 0
61});
62
1
2
p $r;
63
1
50
25
2925
if (
64                ($r->{done} eq 'before')
65                &&
66                ($r->{duration} == 0)
67                &&
68                ($r->{'will.do'} eq 'no')
69        ) {
70
1
1
        $stopping = 1;
71} else {
72
0
0
        p $r;
73
0
0
        die 'Could not stop because output files were already done';
74}
75
76# --- dry run --------------------------------------------------------------
77
1
1
$r = task({
78        cmd       => perl_cmd('exit 0'),
79        'dry.run' => 1
80});
81
1
50
33
25
9
if (
82        ($r->{'dry.run'})            &&
83        ($r->{duration} == 0)          &&
84        ((defined $r->{'will.do'}) && ($r->{'will.do'} eq 'no: dry run'))
85        ) {
86
1
1
        $dry_run = 1;
87} else {
88
0
0
        p $r;
89
0
0
        die 'dry run failed';
90}
91
92# --- task dies on a non-zero exit (default die => 1) ----------------------
93dies_ok {
94
1
1
24
        task({
95                cmd => perl_cmd('exit 2'), # non-zero exit, like the old "ls <missing>"
96        });
97
1
5
} '"task" dies when the command exits non-zero';
98
99# --- task dies on empty filenames ----------------------------------------
100dies_ok {
101
1
1
16
        task({
102                'input.files' => '',
103                cmd           => perl_cmd('exit 0')
104        });
105
1
741
} '"task" dies when given an empty filename in "input.files"';
106
107dies_ok {
108
1
1
14
        task({
109                'output.files' => '',
110                cmd           => perl_cmd('exit 0')
111        });
112
1
456
} '"task" dies when given an empty filename in "output.files"';
113
114# --- overwrite => true actually re-runs and rewrites the file ------------
115
1
1000655
sleep 1;
116
1
47
my $mod0 = -M $fname;
117
1
28
say "\$mod0 = $mod0";
118
1
8
say "\$fname = $fname";
119
1
32
$r = task({
120        cmd            => qq{$PERL -e "print 1" > "$fname"}, # portable redirect
121        overwrite      => 'true',
122        'output.files' => $fname
123});
124
1
20
printf("$mod0 vs %lf\n", -M $fname);
125
1
50
33
14
if (
126                ($mod0 > -M $fname) # the file has been modified (mtime newer)
127                &&
128                (-s $fname > 0)
129        ) {
130
1
4
        $overwrite = 1;
131} else {
132
0
0
        p $r;
133
0
0
        die 'output files are not overwritten when "overwrite" is true"';
134}
135
136#
137# Regression tests for bugs fixed in SimpleFlow.pm
138#
139
140# --- BUG 1: exit/signal decoding -----------------------------------------
141# The old code did $exit = $status >> 8 and THEN $signal = $exit & 127, so the
142# low bits of the exit code leaked into the "signal" field (e.g. exit 137 was
143# reported as signal 9) and a genuine kill-by-signal could never be seen.
144# task() runs commands through a shell, so a child's signal shows up as the
145# shell's exit code 128+N; the portable, decisive check is that the signal
146# field is NEVER contaminated by the exit code.
147subtest 'exit code and signal are decoded independently (regression)' => sub {
148
1
1
1185
        my %expect = (0 => 0, 2 => 2, 42 => 42, 137 => 137);
149
1
5
8
7
        for my $code (sort { $a <=> $b } keys %expect) {
150
4
694
                my $t = task({ cmd => perl_cmd("exit $code"), die => 0 });
151
4
51
                is($t->{'exit'}, $expect{$code}, "exit code $code reported correctly");
152
4
1657
                is($t->{signal}, 0, "signal is 0 for normal exit $code (old code leaked the exit bits)");
153        }
154
1
11
};
155
156# A real kill-by-signal of *task's own command process* (Unix only). When the
157# shell itself is signalled, $? carries signal bits; signal must be that
158# number and exit must be 0.
159SKIP: {
160
1
1
50
1884
6
        skip 'POSIX signal semantics differ on Windows', 2 if $^O eq 'MSWin32';
161        # single-quote the inner code so the outer shell does not expand $$ itself
162
1
2
        my $cmd = qq{$PERL -e 'kill 15 => \$\$'};
163
1
6
        my $t = task({ cmd => $cmd, die => 0 });
164        # Note: routed through a shell this usually surfaces as exit 128+15; the
165        # point of the assertion is simply that signal is decoded from the RAW
166        # status and is not just (exit & 127) of a shifted value.
167
1
16
        ok(defined $t->{signal}, 'signal field is defined after a signalled command');
168
1
33
433
        ok($t->{signal} == 0 || $t->{signal} == 15,
169                'signal field holds a sane value (0 or the actual signal), not leaked exit bits');
170}
171
172# --- BUG 2: missing output file with die => 0 must not crash --------------
173# The old zero-size check did ( -s $missing == 0 ), i.e. ( undef == 0 ), which
174# is a fatal "uninitialized value" under 'use warnings FATAL => all' whenever a
175# declared output file is absent and die => 0. It must now warn, not die.
176
1
201
my $missing;
177{
178
1
1
1
5
        my $tmp = File::Temp->new(SUFFIX => '.gone'); # auto-unlinked on destroy
179
1
348
        $missing = $tmp->filename;
180}
181
1
154
ok(! -e $missing, 'precondition: declared output file is absent');
182
1
228
my $r2;
183lives_ok {
184
1
1
43
        $r2 = task({
185                cmd            => perl_cmd('exit 0'),
186                'output.files' => $missing,
187                die            => 0,
188        });
189
1
10
} 'task survives a missing output file when die => 0 (regression: undef == 0 was fatal)';
190
1
33
199
ok(defined $r2 && ref $r2 eq 'HASH', 'task still returned its result hash');
191
192#
193# Additional coverage: note, *.file.size hashes, normalisation, metadata,
194# captured I/O and argument validation.
195#
196
197# --- note passthrough + default -----------------------------------------
198subtest 'note field' => sub {
199
1
1
407
        my $t = task({ cmd => perl_cmd('exit 0'), note => 'hello note' });
200
1
6
        is($t->{note}, 'hello note', 'note is passed through to the result');
201
1
193
        my $d = task({ cmd => perl_cmd('exit 0') });
202
1
9
        is($d->{note}, '', 'note defaults to the empty string');
203
1
88
};
204
205# --- output.files: scalar normalisation + output.file.size ---------------
206subtest 'output.files normalisation and output.file.size' => sub {
207
1
1
455
        my (undef, $o1) = tempfile(UNLINK => 0, SUFFIX => '.dat');
208
1
194
        my $t = task({
209                cmd            => qq{$PERL -e "print 12345" > "$o1"}, # writes exactly 5 bytes
210                'output.files' => $o1,                                # scalar form
211                overwrite      => 'true',
212        });
213
1
7
        is(ref $t->{'output.files'}, 'ARRAY', 'scalar output.files is normalised to an arrayref');
214
1
200
        is_deeply($t->{'output.files'}, [$o1], 'output.files arrayref holds the filename');
215
1
206
        is($t->{'output.file.size'}{$o1}, 5,      'output.file.size reports the byte count');
216
1
109
        is($t->{'output.file.size'}{$o1}, -s $o1, 'output.file.size matches -s on disk');
217
1
131
        unlink $o1;
218
1
1094
};
219
220# --- input.files: scalar + array forms, and input.file.size --------------
221subtest 'input.files and input.file.size' => sub {
222
1
1
1
1
1
340
133
4
13
        my ($fh1, $i1) = tempfile(UNLINK => 0); print {$fh1} 'abc';  close $fh1; # 3 bytes
223
1
1
1
1
1
72
2
6
        my ($fh2, $i2) = tempfile(UNLINK => 0); print {$fh2} 'wxyz'; close $fh2; # 4 bytes
224
225
1
3
        my $scalar = task({ cmd => perl_cmd('exit 0'), 'input.files' => $i1 });
226
1
6
        is($scalar->{'input.file.size'}{$i1}, 3,   'input.file.size (scalar form) reports size');
227
1
211
        is($scalar->{'input.files'},          $i1, 'input.files (scalar) is preserved on the result');
228
229
1
114
        my $array = task({ cmd => perl_cmd('exit 0'), 'input.files' => [$i1, $i2] });
230
1
8
        is($array->{'input.file.size'}{$i1}, 3, 'input.file.size (array form) reports first size');
231
1
219
        is($array->{'input.file.size'}{$i2}, 4, 'input.file.size (array form) reports second size');
232
233
1
172
        unlink $i1, $i2;
234
1
614
};
235
236# --- metadata fields: dir, source.file, source.line ----------------------
237subtest 'task metadata' => sub {
238
1
1
354
        my $t = task({ cmd => perl_cmd('exit 0') });
239
1
13
        is($t->{dir}, getcwd(),               'dir records the working directory');
240
1
228
        like($t->{'source.file'}, qr/01\.t$/, 'source.file points at the calling script');
241
1
109
        like($t->{'source.line'}, qr/^\d+$/,  'source.line is a line number');
242
1
652
};
243
244# --- captured stdout / stderr (and trailing-whitespace stripping) --------
245subtest 'captured output' => sub {
246
1
1
406
        my $out = task({ cmd => perl_cmd('print q{coverage}'),        die => 0 });
247
1
7
        is($out->{stdout}, 'coverage', 'stdout is captured into the result');
248
1
203
        my $err = task({ cmd => perl_cmd('print STDERR q{oops}'),     die => 0 });
249
1
8
        is($err->{stderr}, 'oops',     'stderr is captured into the result');
250
1
732
};
251
252# --- argument validation -------------------------------------------------
253subtest 'argument validation' => sub {
254
1
21
        dies_ok { task({ note => 'no cmd here' }) }
255
1
1
423
                'dies when the required "cmd" key is missing';
256
1
14
        dies_ok { task({ cmd => perl_cmd('exit 0'), bogus_key => 1 }) }
257
1
662
                'dies on an unrecognised argument key';
258
1
12
        dies_ok { task({ cmd => perl_cmd('exit 0'), 'log.fh' => 'not a filehandle' }) }
259
1
533
                'dies when log.fh is not a real filehandle';
260
1
11
        dies_ok { task({ cmd => perl_cmd('exit 0'), 'input.files' => 'this_file_should_not_exist_42' }) }
261
1
537
                'dies when a declared input file is missing';
262
1
950
};
263
264# --- summary of the original behavioural tests ---------------------------
265
1
1293
ok($simple_task, 'Verified: Simple task works');
266
1
83
ok($log_write,   'Verified: Can write to log files with subroutine "say2"');
267
1
71
ok($stopping,    'Verified: tasks do not run when output files exist');
268
1
67
ok($dry_run,     'Verified: dry run works');
269
1
66
ok($overwrite,   'Verified: "overwrite" option overwrites files in "output.files"');
270
271
1
50
127
unlink $fname if -f $fname;
272
1
3
done_testing();