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