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