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