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