Podlators.pm revision 1.2
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 12package Test::Podlators; 13 14use 5.006; 15use strict; 16use warnings; 17 18use Encode qw(decode encode); 19use Exporter; 20use File::Spec; 21use 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. 27our (@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). 32BEGIN { 33 @ISA = qw(Exporter); 34 $VERSION = '2.01'; 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. 41my $OLD_STDERR; 42 43# The file name used to capture standard error output. 44my $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. 50sub _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. 58END { 59 _stderr_cleanup(); 60} 61 62# Internal function to redirect stderr to a file. Stores the name in 63# $SAVED_STDERR. 64sub _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. 83sub _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# $encoding - Encoding of snippet (UTF-8 if not specified) 98# 99# Returns: Reference to hash of test data with the following keys: 100# name - Name of the test for status reporting 101# options - Hash of options 102# input - The input block of the test data 103# output - The output block of the test data 104# errors - Expected errors 105# exception - Text of exception (with file and line stripped) 106sub read_snippet { 107 my ($path, $encoding) = @_; 108 $path = File::Spec->catfile('t', 'data', 'snippets', $path); 109 $encoding ||= 'UTF-8'; 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($encoding, $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. 179sub 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 230sub 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# $options_ref - Hash of options with the following keys: 254# encoding - Set to use a non-standard encoding 255sub test_snippet { 256 my ($class, $snippet, $options_ref) = @_; 257 my $encoding = defined($options_ref) ? $options_ref->{encoding} : undef; 258 my $data_ref = read_snippet($snippet, $encoding); 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 # 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 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