Update podlators to version 4.03
[perl.git] / cpan / podlators / t / lib / Test / Podlators.pm
1 # Helper functions to test the podlators distribution.
2 #
3 # This module is an internal implementation detail of the podlators test
4 # suite.  It provides some supporting functions to make it easier to write
5 # tests.
6 #
7 # Copyright 2015 Russ Allbery <rra@cpan.org>
8 #
9 # This program is free software; you may redistribute it and/or modify it
10 # under the same terms as Perl itself.
11
12 package Test::Podlators;
13
14 use 5.006;
15 use strict;
16 use warnings;
17
18 use Encode qw(decode encode);
19 use Exporter;
20 use File::Spec;
21 use Test::More;
22
23 # For Perl 5.006 compatibility.
24 ## no critic (ClassHierarchies::ProhibitExplicitISA)
25
26 # Declare variables that should be set in BEGIN for robustness.
27 our (@EXPORT_OK, @ISA, $VERSION);
28
29 # Set $VERSION and everything export-related in a BEGIN block for robustness
30 # against circular module loading (not that we load any modules, but
31 # consistency is good).
32 BEGIN {
33     @ISA       = qw(Exporter);
34     $VERSION   = '2.00';
35     @EXPORT_OK = qw(
36       read_snippet read_test_data slurp test_snippet test_snippet_with_io
37     );
38 }
39
40 # The file handle used to capture STDERR while we mess with file descriptors.
41 my $OLD_STDERR;
42
43 # The file name used to capture standard error output.
44 my $SAVED_STDERR;
45
46 # Internal function to clean up the standard error output file.  The "1 while"
47 # construct is for VMS, in case there are multiple versions of the file.
48 sub _stderr_cleanup {
49     if ($SAVED_STDERR && -f $SAVED_STDERR) {
50         unlink($SAVED_STDERR);
51     }
52     my $tmpdir = File::Spec->catdir('t', 'tmp');
53     if (-d $tmpdir) {
54         rmdir($tmpdir);
55     }
56     return;
57 }
58
59 # Remove saved standard error on exit, even if we have an abnormal exit.
60 END {
61     _stderr_cleanup();
62 }
63
64 # Internal function to redirect stderr to a file.  Stores the name in
65 # $SAVED_STDERR.
66 sub _stderr_save {
67     my $tmpdir = File::Spec->catdir('t', 'tmp');
68     if (!-d $tmpdir) {
69         mkdir('t/tmp', 0777) or BAIL_OUT("cannot create t/tmp: $!");
70     }
71     my $path = File::Spec->catfile($tmpdir, "out$$.err");
72
73     ## no critic(InputOutput::RequireBriefOpen)
74     open($OLD_STDERR, '>&', STDERR) or BAIL_OUT("cannot dup STDERR: $!");
75     open(STDERR, '>', $path) or BAIL_OUT("cannot redirect STDERR: $!");
76     ## use critic
77
78     $SAVED_STDERR = $path;
79     return;
80 }
81
82 # Internal function to restore stderr.
83 #
84 # Returns: The contents of the stderr file.
85 sub _stderr_restore {
86     return if !$SAVED_STDERR;
87     close(STDERR) or BAIL_OUT("cannot close STDERR: $!");
88     open(STDERR, '>&', $OLD_STDERR) or BAIL_OUT("cannot dup STDERR: $!");
89     close($OLD_STDERR) or BAIL_OUT("cannot close redirected STDERR: $!");
90     my $stderr = slurp($SAVED_STDERR);
91     _stderr_cleanup();
92     return $stderr;
93 }
94
95 # Read one test snippet from the provided relative file name and return it.
96 # For the format, see t/data/snippets/README.
97 #
98 # $path - Relative path to read test data from
99 #
100 # Returns: Reference to hash of test data with the following keys:
101 #            name      - Name of the test for status reporting
102 #            options   - Hash of options
103 #            input     - The input block of the test data
104 #            output    - The output block of the test data
105 #            errors    - Expected errors
106 #            exception - Text of exception (with file and line stripped)
107 sub read_snippet {
108     my ($path) = @_;
109     $path = File::Spec->catfile('t', 'data', 'snippets', $path);
110     my %data;
111
112     # Read the sections and store them in the %data hash.
113     my ($line, $section);
114     open(my $fh, '<', $path) or BAIL_OUT("cannot open $path: $!");
115     while (defined($line = <$fh>)) {
116         $line = decode('UTF-8', $line);
117         if ($line =~ m{ \A \s* \[ (\S+) \] \s* \z }xms) {
118             $section = $1;
119         } elsif ($section) {
120             $data{$section} ||= q{};
121             $data{$section} .= $line;
122         }
123     }
124     close($fh) or BAIL_OUT("cannot close $path: $!");
125
126     # Strip trailing blank lines from all sections.
127     for my $section (keys %data) {
128         $data{$section} =~ s{ \n\s+ \z }{\n}xms;
129     }
130
131     # Clean up the name section by removing newlines and extra space.
132     if ($data{name}) {
133         $data{name} =~ s{ \A \s+ }{}xms;
134         $data{name} =~ s{ \s+ \z }{}xms;
135         $data{name} =~ s{ \s+ }{ }xmsg;
136     }
137
138     # Turn the options section into a hash.
139     if ($data{options}) {
140         my @lines = split(m{ \n }xms, $data{options});
141         delete $data{options};
142         for my $optline (@lines) {
143             next if $optline !~ m{ \S }xms;
144             my ($option, $value) = split(q{ }, $optline, 2);
145             if (defined($value)) {
146                 chomp($value);
147             } else {
148                 $value = q{};
149             }
150             $data{options}{$option} = $value;
151         }
152     }
153
154     # Return the results.
155     return \%data;
156 }
157
158 # Read one set of test data from the provided file handle and return it.
159 # There are several different possible formats, which are specified by the
160 # format option.
161 #
162 # The data read from the file handle will be ignored until a line consisting
163 # solely of "###" is found.  Then, two or more blocks separated by "###" are
164 # read, ending with another line of "###".  There will always be at least an
165 # input and an output block, and may be more blocks based on the format
166 # configuration.
167 #
168 # $fh         - File handle to read the data from
169 # $format_ref - Reference to a hash of options describing the data
170 #   errors  - Set to true to read expected errors after the output section
171 #   options - Set to true to read a hash of options as the first data block
172 #
173 # Returns: Reference to hash of test data with the following keys:
174 #            input   - The input block of the test data
175 #            output  - The output block of the test data
176 #            errors  - Expected errors if errors was set in $format_ref
177 #            options - Hash of options if options was set in $format_ref
178 #          or returns undef if no more test data is found.
179 sub read_test_data {
180     my ($fh, $format_ref) = @_;
181     $format_ref ||= {};
182     my %data;
183
184     # Find the first block of test data.
185     my $line;
186     while (defined($line = <$fh>)) {
187         last if $line eq "###\n";
188     }
189     if (!defined($line)) {
190         return;
191     }
192
193     # If the format contains the options key, read the options into a hash.
194     if ($format_ref->{options}) {
195         while (defined($line = <$fh>)) {
196             last if $line eq "###\n";
197             my ($option, $value) = split(q{ }, $line, 2);
198             if (defined($value)) {
199                 chomp($value);
200             } else {
201                 $value = q{};
202             }
203             $data{options}{$option} = $value;
204         }
205     }
206
207     # Read the input and output sections.
208     my @sections = qw(input output);
209     if ($format_ref->{errors}) {
210         push(@sections, 'errors');
211     }
212     for my $key (@sections) {
213         $data{$key} = q{};
214         while (defined($line = <$fh>)) {
215             last if $line eq "###\n";
216             $data{$key} .= $line;
217         }
218     }
219     return \%data;
220 }
221
222 # Slurp output data back from a file handle.  It would be nice to use
223 # Perl6::Slurp, but this is a core module, so we have to implement our own
224 # wheels.  BAIL_OUT is called on any failure to read the file.
225 #
226 # $file  - File to read
227 # $strip - If set to "man", strip out the Pod::Man header
228 #
229 # Returns: Contents of the file, possibly stripped
230 sub slurp {
231     my ($file, $strip) = @_;
232     open(my $fh, '<', $file) or BAIL_OUT("cannot open $file: $!");
233
234     # If told to strip the man header, do so.
235     if (defined($strip) && $strip eq 'man') {
236         while (defined(my $line = <$fh>)) {
237             last if $line eq ".nh\n";
238         }
239     }
240
241     # Read the rest of the file and return it.
242     my $data = do { local $/ = undef; <$fh> };
243     close($fh) or BAIL_OUT("cannot read from $file: $!");
244     return $data;
245 }
246
247 # Test a formatter on a particular POD snippet.  This does all the work of
248 # loading the snippet, creating the formatter, running it, and checking the
249 # results, and reports those results with Test::More.
250 #
251 # $class   - Class name of the formatter, as a string
252 # $snippet - Path to the snippet file defining the test
253 sub test_snippet {
254     my ($class, $snippet) = @_;
255     my $data_ref = read_snippet($snippet);
256
257     # Create the formatter object.
258     my $parser = $class->new(%{ $data_ref->{options} }, name => 'TEST');
259     isa_ok($parser, $class, 'Parser object');
260
261     # Save stderr to a temporary file and then run the parser, storing the
262     # output into a Perl variable.
263     my $errors = _stderr_save();
264     my $got;
265     $parser->output_string(\$got);
266     eval { $parser->parse_string_document($data_ref->{input}) };
267     my $exception = $@;
268     my $stderr    = _stderr_restore();
269
270     # If we were testing Pod::Man, strip off everything prior to .nh from the
271     # output so that we aren't testing the generated header.
272     if ($class eq 'Pod::Man') {
273         $got =~ s{ \A .* \n [.]nh \n }{}xms;
274     }
275
276     # Check the output, errors, and any exception.
277     is($got, $data_ref->{output}, "$data_ref->{name}: output");
278     if ($data_ref->{errors}) {
279         is($stderr, $data_ref->{errors}, "$data_ref->{name}: errors");
280     }
281     if ($data_ref->{exception} || $exception) {
282         if ($exception) {
283             $exception =~ s{ [ ] at [ ] .* }{}xms;
284         }
285         is($exception, $data_ref->{exception}, "$data_ref->{name}: exception");
286     }
287     return;
288 }
289
290 # Test a formatter with I/O streams on a particular POD snippet.  This does
291 # all the work of loading the snippet, creating the formatter, running it, and
292 # checking the results, and reports those results with Test::More.  It's
293 # similar to test_snippet, but uses input and output temporary files instead
294 # to test encoding layers and also checks the Pod::Man accent output.
295 #
296 # $class       - Class name of the formatter, as a string
297 # $snippet     - Path to the snippet file defining the test
298 # $options_ref - Hash of options with the following keys:
299 #   perlio_utf8 - Set to 1 to set a PerlIO UTF-8 encoding on the output file
300 sub test_snippet_with_io {
301     my ($class, $snippet, $options_ref) = @_;
302     my $data_ref = read_snippet($snippet);
303
304     # Create the formatter object.
305     my $parser = $class->new(%{ $data_ref->{options} }, name => 'TEST');
306     isa_ok($parser, $class, 'Parser object');
307
308     # Write the input POD to a temporary file prefaced by the encoding
309     # directive.
310     my $tmpdir = File::Spec->catdir('t', 'tmp');
311     if (!-d $tmpdir) {
312         mkdir($tmpdir, 0777);
313     }
314     my $input_file = File::Spec->catfile('t', 'tmp', "tmp$$.pod");
315     open(my $input, '>', $input_file)
316       or BAIL_OUT("cannot create $input_file: $!");
317     print {$input} encode('UTF-8', $data_ref->{input})
318       or BAIL_OUT("cannot write to $input_file: $!");
319     close($input) or BAIL_OUT("cannot flush output to $input_file: $!");
320
321     # Create an output file and parse from the input file to the output file.
322     my $output_file = File::Spec->catfile('t', 'tmp', "out$$.tmp");
323     open(my $output, '>', $output_file)
324       or BAIL_OUT("cannot create $output_file: $!");
325     if ($options_ref->{perlio_utf8}) {
326         ## no critic (BuiltinFunctions::ProhibitStringyEval)
327         ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
328         eval 'binmode($output, ":encoding(utf-8)")';
329         ## use critic
330     }
331
332     # Parse the input file into the output file.
333     $parser->parse_from_file($input_file, $output);
334     close($output) or BAIL_OUT("cannot flush output to $output_file: $!");
335
336     # Read back in the results, checking to ensure that we didn't output the
337     # accent definitions if we wrote UTF-8 output.
338     open(my $results, '<', $output_file)
339       or BAIL_OUT("cannot open $output_file: $!");
340     my ($line, $saw_accents);
341     while (defined($line = <$results>)) {
342         $line = decode('UTF-8', $line);
343         if ($line =~ m{ Accent [ ] mark [ ] definitions }xms) {
344             $saw_accents = 1;
345         }
346         last if $line =~ m{ \A [.]nh }xms;
347     }
348     my $saw = do { local $/ = undef; <$results> };
349     $saw = decode('UTF-8', $saw);
350     close($results) or BAIL_OUT("cannot close output file: $!");
351
352     # Clean up.
353     unlink($input_file, $output_file);
354
355     # Check the accent definitions and the output.
356     my $perlio = $options_ref->{perlio_utf8} ? ' (PerlIO)' : q{};
357     is(
358         $saw_accents,
359         $data_ref->{options}{utf8} ? undef : 1,
360         "$data_ref->{name}: accent definitions$perlio"
361     );
362     is($saw, $data_ref->{output}, "$data_ref->{name}: output$perlio");
363     return;
364 }
365
366 1;
367 __END__
368
369 =for stopwords
370 Allbery podlators PerlIO UTF-8 formatter FH whitespace
371
372 =head1 NAME
373
374 Test::Podlators - Helper functions for podlators tests
375
376 =head1 SYNOPSIS
377
378     use Test::Podlators qw(read_test_data);
379
380     # Read the next block of test data, including options.
381     my $data = read_test_data(\*DATA, { options => 1 });
382
383 =head1 DESCRIPTION
384
385 This module collects various utility functions that are useful for writing
386 test cases for the podlators distribution.  It is not intended to be, and
387 probably isn't, useful outside of the test suite for that module.
388
389 =head1 FUNCTIONS
390
391 None of these functions are imported by default.  The ones used by a script
392 should be explicitly imported.
393
394 =over 4
395
396 =item read_snippet(PATH[, OPTIONS])
397
398 Read one test snippet from the provided relative file name and return it.  The
399 path should be relative to F<t/data/snippets>.  For the format, see
400 F<t/data/snippets/README>.
401
402 OPTIONS, if present, is a hash that currently supports only one key: C<utf8>,
403 to set a PerlIO input encoding layer of UTF-8 when reading the snippet.
404
405 The result will be a hash with the following keys:
406
407 =over 4
408
409 =item name
410
411 The name of the test, for reporting purposes.
412
413 =item options
414
415 A hash of any options to values, if any options were specified.
416
417 =item input
418
419 Input POD to try formatting.
420
421 =item output
422
423 The expected output.
424
425 =item errors
426
427 Expected errors from the POD formatter.
428
429 =item exception
430
431 An expected exception from the POD formatter, with the file and line
432 information stripped from the end of the exception.
433
434 =back
435
436 =item read_test_data(FH, FORMAT)
437
438 Reads a block of test data from FH, looking for test information according to
439 the description provided in FORMAT.  All data prior to the first line
440 consisting of only C<###> will be ignored.  Then, the test data must consist
441 of two or more blocks separated by C<###> and ending in a final C<###> line.
442
443 FORMAT is optional, in which case the block of test data should be just input
444 text and output text.  If provided, it should be a reference to a hash with
445 one or more of the following keys:
446
447 =over 4
448
449 =item options
450
451 If set, the first block of data in the test description is a set of options in
452 the form of a key, whitespace, and a value, one per line.  The value may be
453 missing, in which case the value associated with the key is the empty string.
454
455 =back
456
457 The return value is a hash with at least some of the following keys:
458
459 =over 4
460
461 =item input
462
463 The input data for the test.  This is always present.
464
465 =item options
466
467 If C<options> is set in the FORMAT argument, this is the hash of keys and
468 values in the options section of the test data.
469
470 =item output
471
472 The output data for the test.  This is always present.
473
474 =back
475
476 =item slurp(FILE[, STRIP])
477
478 Read the contents of FILE and return it as a string.  If STRIP is set to
479 C<man>, strip off any Pod::Man header from the file before returning it.
480
481 =item test_snippet(CLASS, SNIPPET)
482
483 Test a formatter on a particular POD snippet.  This does all the work of
484 loading the snippet, creating the formatter by instantiating CLASS, running
485 it, and checking the results.  Results are reported with Test::More.
486
487 =item test_snippet_with_io(CLASS, SNIPPET[, OPTIONS])
488
489 The same as test_snippet(), except, rather than parsing the input into a
490 string buffer, this function uses real, temporary input and output files.
491 This can be used to test I/O layer handling and proper encoding.
492
493 OPTIONS, if present, is a reference to a hash of options.  Currently, only
494 one key is supported: C<perlio>, which, if set to true, will set a PerlIO
495 UTF-8 encoding layer on the output file before writing to it.
496
497 =back
498
499 =head1 AUTHOR
500
501 Russ Allbery <rra@cpan.org>
502
503 =head1 COPYRIGHT AND LICENSE
504
505 Copyright 2015 Russ Allbery <rra@cpan.org>
506
507 This program is free software; you may redistribute it and/or modify it
508 under the same terms as Perl itself.
509
510 =cut