File Coverage: t/01.t

# File Coverage

File: | t/01.t
Coverage: | 80.8%

line | stmt | bran | cond | sub | time | code
--- | --- | --- | --- | --- | --- | ---
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) ----------------------
93 |  |  |  |  |  | dies_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 ----------------------------------------
100 |  |  |  |  |  | dies_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 |
107 |  |  |  |  |  | dies_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.
147 |  |  |  |  |  | subtest '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.
159 |  |  |  |  |  | SKIP: {
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;
183 |  |  |  |  |  | lives_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 -----------------------------------------
198 |  |  |  |  |  | subtest '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 ---------------
206 |  |  |  |  |  | subtest '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 --------------
221 |  |  |  |  |  | subtest '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 ----------------------
237 |  |  |  |  |  | subtest '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) --------
245 |  |  |  |  |  | subtest '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 -------------------------------------------------
253 |  |  |  |  |  | subtest '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();