path: root/ext/Pod-Html/t/lib/Testing.pm

package Testing;
use 5.10.0;
use warnings;
require Exporter;
our $VERSION = 1.31; # Let's keep this same as lib/Pod/Html.pm
$VERSION = eval $VERSION;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
    setup_testing_dir
    xconvert
    record_state_of_cache
);
use Cwd;
use Pod::Html;
use Config;
use File::Basename;
use File::Copy;
use File::Path ( qw| make_path | );
use File::Spec::Functions ':ALL';
use File::Temp ( qw| tempdir | );
use Data::Dumper;$Data::Dumper::Sortkeys=1;
use Pod::Html::Util qw(
    unixify
);

*ok = \&Test::More::ok;
*is = \&Test::More::is;

our @no_arg_switches = ( qw|
    flush recurse norecurse
    quiet noquiet verbose noverbose
    index noindex backlink nobacklink
    header noheader poderrors nopoderrors
| );

=head1 NAME

Testing - Helper functions for testing Pod-Html

=head1 SYNOPSIS

    use Testing qw( setup_testing_dir xconvert );

    my $tdir = setup_testing_dir( {
        debug       => $debug,
    } );

    $args = {
        podstub => "htmldir1",
        description => "test --htmldir and --htmlroot 1a",
        expect => $expect_raw,
        p2h => {
            podpath => File::Spec::Unix->catdir($relcwd, 't') . ":" .
                       File::Spec::Unix->catdir($relcwd, 'corpus/test.lib'),
            podroot => catpath($v, '/', ''),
            htmldir => 't',
            quiet   => 1,
        },
        debug => $debug,
    };
    xconvert($args);

=head1 DESCRIPTION

This module exports, upon request only, 2 subroutines which are used in most
of the files in the core distribution test suite for Pod-HTML
(F<ext/Pod-Html/t/*.t>).  In the future we may add additional subroutines,
particularly to better diagnose problems with Pod-Html.

=head2 Pod-Html's Testing Structure

As of version 1.26 of this module (early 2021), the testing structure consists
of 16 F<.pod> files and 18 F<.t> files located in two subdirectories,
F<corpus/> and F<t/>.  Let's analyze these by directory.

=head3 Files in F<corpus/>

There are currently 2 F<.pod> files in F<corpus/> both of which are old
versions of F<pod/*.pod> files selected to give some complexity to the test
suite.  Since we don't actually attempt to make HTML out of their POD, we
don't need to discuss them further.

=head3 Files in F<t/>

There are currently 14 F<.pod> files and 18 F<.t> files in F<t/>.  Both of
these numbers may change in the future.

Currently there are 2 F<t/.t> files (F<t/anchorify.t> and F<t/eol.t>) which
exercise certain functionality of F<Pod::Html> but which do not require
F<t/*.pod> files as data input.  These files do not make use of the
subroutines exported by this module.  We may add more test files like this in
the future to ensure high test coverage, but don't need to discuss them
further here.

The remaining 16 F<t/*.t> test programs make use of the testing subroutines
exported by this module.  Most, but not all, of these test programs make use
of the F<t/*.pod> files.  Each such test program makes use of only 1
F<t/*.pod> file at a time, though there are several cases where several,
similarly named, test programs make use of the same F<t/*.pod> file for data
input.  For example,

    t/crossref.t
    t/crossref2.t
    t/crossref3.t

all make use of

    t/crossref.pod

Each F<t/*.pod> file consists solely of simple documentation in POD format.

=head3 High-level description of programs which use F<.pod> files as input

Each of the F<t/*.t> programs which makes use of a given F<t/*.pod> file
slurps the text of a single such F<t/*.pod> file into memory.  The test
program holds text in a C<DATA> handle which serves as a B<template> for the
HTML expected to be generated by running the F<t/*.pod> file through
C<Pod::Html::pod2html()>.  The HTML output by C<Pod::Html::pod2html()> can
vary greatly, particularly with respect to links, depending on the arguments
passed to that function.  The HTML output will also be affected by the
underlying operating system, I<e.g.,> with respect to path separators.  Hence,
we cannot hard-code the expected HTML output into the C<DATA> template or any
place else.  We have to allow C<Pod::Html::pod2html()> to massage the template
data to get an "expected output" against which we match the "actual output"
which come from running C<Pod::Html::pod2html()> over the text originally
slurped into memory from the F<t/*.pod> file.

Granted, there is a certain amount of circularity in this testing regimen.  On
a given operating system, with a given F<t/*.pod> file as raw input, a given
POD parser invoked within C<Pod::Html::pod2html()> and a given set of
arguments passed to C<pod2html()>, there can and should be only one possible
HTML string generated as output.  What we currently have in a given test
program's C<DATA> handle is merely that HTML string retrofitted with certain
template elements as needed to make the "got" and the "expected" identical.
We're not testing whether we're generating "good" HTML.  We're simply testing
that we get consistent results out of C<pod2html()> year after year.

=head3 How a test program works step-by-step

Here we continue to focus on those test programs which make use of the testing
functions exported by F<Testing> and which take a F<t/*.pod> file as input.

We assume that we begin our tests from the top level of the Perl 5 core distribution and are using F<t/harness>.  Hence, to run the test files we say:

    cd t; ./perl harness ../ext/Pod-Html/t/*.t; cd -

The program then slurps contents of the C<DATA> handle into memory.

The program then calls C<setup_testing_dir()> from this module to create a
temporary directory and populate it as needed.  C<setup_testing_dir()> returns
the absolute path to that directory, but at the point of return you are
actually located two levels beneath the temporary directory in a directory whose relative path is
F<ext/Pod-Html/>.  (This is equivalent to being in F<toplevel/ext/Pod-Html/>
for tests in versions of Pod-Html distributed with earlier versions of
F<perl>.)

Note that this means that at the end of the program you will have to
switch back to your starting directory so that the tempdir can automatically
be cleaned up.  We automate this via an C<END> block.

You then prepare arguments for our principal testing function, C<xconvert()>
(which supersedes the former C<convert_n_test()>.  These arguments take the
form of a single hash reference.  One customary but optional element in that
hashref, C<p2h>, is itself a hashref of key-value pairs corresponding to
switches passed to the F<pod2html> command-line utility or to
C<Pod::Html::pod2html()>.  The other elements in the hashref passed to
C<xconvert()> include the stub of the basename of the F<t/*.pod> file being
used, the text of that file (which we've already slurped into memory), the
test description, and whether we want extra debugging output or not.  The
program then adds a key-value pair to indicate whether we're running via core
distribution test harness or not.

The hashref is then passed to C<xconvert()> which internally generates an
expected HTML output string by massaging the text read in from the C<DATA>
handle.   C<xconvert()> reads in the relevant F<t/*.pod> file and passes it to
C<Pod::Html::pod2html()>, which parses the POD and generates the actual HTML
output.  If "got" matches "expected", a PASS is recorded for this instance of
C<xconvert()>.

As the example of F<t/htmldir1.t> illustrates:

=over 4

=item *

The user can define a variety of arguments to be passed through to C<Pod::Html::pod2html()>.

    my ($v, $d) = splitpath(cwd(), 1);
    my @dirs = splitdir($d);
    shift @dirs if $dirs[0] eq '';
    my $relcwd = join '/', @dirs;

    $args = {
        ...
        p2h => {
            podpath => File::Spec::Unix->catdir($relcwd, 't') . ":" .
                       File::Spec::Unix->catdir($relcwd, 'corpus/test.lib'),
            podroot => catpath($v, '/', ''),
            htmldir => 't',
            quiet   => 1,
        },
        ...
    };

=item *

The user can try out a variety of different arguments in the C<p2h> element
and end up with the same HTML output as predicted by the C<DATA> template by
calling C<xconvert()> more than once per file.

    $args = {
        podstub => "htmldir1",
        description => "test --htmldir and --htmlroot 1a",
        expect => $expect_raw,
        p2h => {
            podpath => File::Spec::Unix->catdir($relcwd, 't') . ":" .
                       File::Spec::Unix->catdir($relcwd, 'corpus/test.lib'),
            podroot => catpath($v, '/', ''),
            htmldir => 't',
            quiet   => 1,
        },
    };
    xconvert($args);

    $args = {
        podstub => "htmldir1",
        description => "test --htmldir and --htmlroot 1b",
        expect => $expect_raw,
        p2h => {
            podpath     => $relcwd,
            podroot     => catpath($v, '/', ''),
            htmldir     => catdir($relcwd, 't'),
            htmlroot    => '/',
            quiet       => 1,
        },
    };
    xconvert($args);

Note that in the two "runs" above, the values for C<podstub> are the
same, but the arguments to C<p2h> differ; we've distinguished the two runs
by different values for C<description>.

=back

Note that all runs within an individual F<t/*.t> program share the same
temporary directory.  Since C<Pod::Html::pod2html()> typically caches its
understanding of where F<.pod> files are located, there is a possibility that
the contents of the cache may affect the generated HTML output in an adverse
way.  This possibility will be addressed in an upcoming version of this
program.

When all runs have been completed (as noted above), the C<END> block brings us
back to the directory we started from to permit the temporary directory and
its contents to be cleanly deleted.

=head1 SUBROUTINES

=head2 C<setup_testing_dir()>

=over 4

=item * Purpose

Create and populate a temporary directory to hold all activity for a single F<t/*.t> program.

=item * Arguments

    $tdir = setup_testing_dir( {
        startdir    => $startdir,
        debug       => $debug,
    } );

Single hash reference with two possible elements.

=over 4

=item * C<debug>

A Boolean which you will typically set at the start of your program.  A
Perl-true value prints out your location and creates a temporary directory
which is B<not> cleaned up at the program's completion, thereby permitting you
to examine the intermediate files created by the program.

=back

=item * Return Value

String holding the absolute path of the temporary directory.

=item * Comments

The function C<chdir>s internally and leaves you in a directory called
F<ext/Pod-Html> beneath the temporary directory found in the return value.

The function is somewhat equivalent to testing helper function
C<make_test_dir> in F<t/pod2html-lib.pl> in versions of Pod-Html shipped with
versions of F<perl> up through 5.32.

=back

=cut

sub setup_testing_dir {
    my $args = shift;
    my $cwd = cwd();
    my $toptempdir = $args->{debug} ? tempdir() : tempdir( CLEANUP => 1 );
    if ($args->{debug}) {
        print STDERR "toptempdir: $toptempdir\n";
    }
    chdir $toptempdir or die "Unable to change to $toptempdir: $!";

    my $ephdir = catdir($toptempdir, 'ext', 'Pod-Html');
    my ($fromdir, $targetdir, $pod_glob, @testfiles);

    # Copy ext/Pod-Html/t/*.pod files into position under tempdir
    $fromdir = catdir($cwd, 't');
    # Per Craig Berry: Avoid hard-coded '/' to keep VMS happy
    $pod_glob = catfile($fromdir, '*.pod');
    @testfiles = glob($pod_glob);

    $targetdir = catdir($ephdir, 't');
    make_path($targetdir) or die("Cannot mkdir $targetdir for testing: $!");
    for my $f (@testfiles) {
        copy $f => $targetdir or die "Unable to copy: $!";
    }

    # Copy ext/Pod-Html/corpus/*.pod files into position under tempdir
    $fromdir = catdir($cwd, 'corpus');
    # Per Craig Berry: Avoid hard-coded '/' to keep VMS happy
    $pod_glob = catfile($fromdir, '*.pod');
    @testfiles = glob($pod_glob);

    $targetdir = catdir($ephdir, 'corpus', 'test.lib');
    make_path($targetdir) or die "Could not make $targetdir for testing: $!";

    my %copying = ();
    for my $g (@testfiles) {
        my $basename = basename($g);
        my ($stub) = $basename =~ m{^(.*)\.pod};
        $stub =~ s{^perl(.*)}{$1};
        $copying{$stub} = {
            source => $g,
            target => catfile($targetdir, "${stub}.pod")
        };
    }

    for my $k (keys %copying) {
        copy $copying{$k}{source} => $copying{$k}{target}
            or die "Unable to copy: $!";
    }

    # Move into tempdir/ext/Pod-Html
    chdir $ephdir or die "Unable to change to $ephdir: $!";
    return $toptempdir;
}

=head2 C<xconvert()>

=over 4

=item * Purpose

Compare whether the HTML generated by C<Pod::Html::pod2html()>'s parsing of a
F<.pod> file matches the expectation generated by parsing the C<DATA> block
within the test file.

=item * Arguments

Single hash reference.

    $args = {
        podstub => "htmldir5",
        description => "test --htmldir and --htmlroot 5",
        expect => $expect_raw,
        p2h => {
            podpath     => 't:corpus/test.lib',
            podroot     => $cwd,
            htmldir     => $cwd,
            htmlroot    => '/',
            quiet       => 1,
        },
        debug => $debug,
    };
    $args->{core} = 1 if $ENV{PERL_CORE};

Elements are as follows:

=over 4

=item * C<podstub>

String holding the stub (or stem) of the F<.pod> file being used as input.
The stub is the basename of the file less the file extension or suffix.
(Equivalent to the first argument passed to the former C<convert_and_test>
test helper routine.)  Required.

=item * C<description>

String holding the description (or name or label) in typical TAP syntax.
(Equivalent to the second argument passed to the former C<convert_and_test>
helper routine.)  Required.

=item * C<expect>

String holding the "raw" expectations read in from the C<DATA> handle.  Each
run of C<xconvert()> within a given test file should have the same value for
this key.  Required.

=item * C<p2h>

Hash reference holding arguments passed to C<Pod::Html::pod2html()> (though
without the leading double hyphens (C<-->).  See documentation for
F<Pod::Html>.  Optional, but mostly necessary.  In particular, if a F<.pod>
file contains any C<LE<lt>E<gt>> tags, a C<podpath> element almost always
needs to be supplied with a colon-delimited list of directories from which to
begin a search for files containing POD.

=item * C<debug>

Boolean, generally set once at the program's top.  When Perl-true, displays
extra debugging output, including turning on C<Pod::Html::pod2html()>'s
C<verbose> option.  Optional.

=item * C<core>

Boolean. This should be set to a Perl-true value when the file is to be run
from the test harness rather than from the top-level of the repository.

=back

=item * Return Value

Not explicitly defined, but should return a Perl-true value upon completion.

=item * Comment

This function essentially asks, "Are we getting the same HTML output the last time we tinkered with the code in this distribution?"  Hence, it is dependent on the particular parsing and HTML composition functionality found within C<Pod::Html::pod2html()>, which is a somewhat customized subclass of F<Pod::Simple::XHTML>.  If, in the future, we offer functionality based on other parsing classes, then the C<DATA> sections of the F<t/*.t> files will have to be revised and perhaps the guts of C<xconvert()> as well.

This function is roughly equivalent to test helper function C<convert_n_test()> in earlier
versions of Pod-Html.

=back

=cut

sub xconvert {
    my $args = shift;
    for my $k ('podstub', 'description', 'expect') {
        die("convert_n_test() must have $k element")
            unless length($args->{$k});
    }
    my $podstub = $args->{podstub};
    my $description = $args->{description};
    my $debug = $args->{debug} // 0;
    $args->{expect_fail} //= 0;
    if (defined $args->{p2h}) {
        die "Value for 'p2h' must be hashref"
            unless ref($args->{p2h}) eq 'HASH'; # TEST ME
    }
    my $cwd = unixify( Cwd::cwd() );
    my ($vol, $dir) = splitpath($cwd, 1);
    my @dirs = splitdir($dir);
    shift @dirs if $dirs[0] eq '';
    my $relcwd = join '/', @dirs;

    my $new_dir  = catdir $dir, "t";
    my $infile   = catpath $vol, $new_dir, "$podstub.pod";
    my $outfile  = catpath $vol, $new_dir, "$podstub.html";

    my $args_table = _prepare_argstable( {
        infile      => $infile,
        outfile     => $outfile,
        cwd         => $cwd,
        p2h         => $args->{p2h},
    } );
    my @args_list = _prepare_argslist($args_table);
    Pod::Html::pod2html( @args_list );

    $cwd =~ s|\/$||;

    my $expect = _set_expected_html($args->{expect}, $relcwd, $cwd);
    my $result = _get_html($outfile);

    _process_diff( {
        expect      => $expect,
        result      => $result,
        description => $description,
        podstub     => $podstub,
        outfile     => $outfile,
        debug       => $debug,
        expect_fail => $args->{expect_fail},
    } );

    # pod2html creates these
    unless ($debug) {
        1 while unlink $outfile;
        1 while unlink "pod2htmd.tmp";
    }
}

sub _prepare_argstable {
    my $args = shift;
    my %args_table = (
        infile      =>    $args->{infile},
        outfile     =>    $args->{outfile},
    );
    my %no_arg_switches = map { $_ => 1 } @no_arg_switches;
    if (defined $args->{p2h}) {
        for my $sw (keys %{$args->{p2h}}) {
            if ($no_arg_switches{$sw}) {
                $args_table{$sw} = undef;
            }
            else {
                $args_table{$sw} = $args->{p2h}->{$sw};
            }
        }
    }
    return \%args_table;
}

sub _prepare_argslist {
    my $args_table = shift;
    my @args_list = ();
    for my $k (keys %{$args_table}) {
        if (defined $args_table->{$k}) {
            push @args_list, "--" . $k . "=" . $args_table->{$k};
        }
        else {
            push @args_list, "--" . $k;
        }
    }
    return @args_list;
}

sub _set_expected_html {
    my ($expect, $relcwd, $cwd) = @_;
    $expect =~ s/\[PERLADMIN\]/$Config::Config{perladmin}/;
    $expect =~ s/\[RELCURRENTWORKINGDIRECTORY\]/$relcwd/g;
    $expect =~ s/\[ABSCURRENTWORKINGDIRECTORY\]/$cwd/g;
    if (ord("A") == 193) { # EBCDIC.
        $expect =~ s/item_mat_3c_21_3e/item_mat_4c_5a_6e/;
    }
    $expect =~ s/\n\n(some html)/$1/m;
    $expect =~ s{(TESTING FOR AND BEGIN</h1>)\n\n}{$1}m;
    return $expect;
}

sub _get_html {
    my $outfile = shift;
    local $/;

    open my $in, '<', $outfile or die "cannot open $outfile: $!";
    my $result = <$in>;
    close $in;
    return $result;
}

sub _process_diff {
    my $args = shift;
    die("process_diff() takes hash ref") unless ref($args) eq 'HASH';
    my %keys_needed = map { $_ => 1 } (qw| expect result description podstub outfile |);
    my %keys_seen   = map { $_ => 1 } ( keys %{$args} );
    my @keys_missing = ();
    for my $kn (keys %keys_needed) {
        push @keys_missing, $kn unless exists $keys_seen{$kn};
    }
    die("process_diff() arguments missing: @keys_missing") if @keys_missing;

    my $diff = '/bin/diff';
    -x $diff or $diff = '/usr/bin/diff';
    -x $diff or $diff = undef;
    my $diffopt = $diff ? $^O =~ m/(linux|darwin)/ ? '-u' : '-c'
                        : '';
    $diff = 'fc/n' if $^O =~ /^MSWin/;
    $diff = 'differences' if $^O eq 'VMS';
    if ($diff) {
        my $outcome = $args->{expect} eq $args->{result};
        if ($outcome) {
            ok($outcome, $args->{description});
        }
        else {
            if ($args->{expect_fail}) {
                ok(! $outcome, $args->{description});
            }
            else {
                ok($outcome, $args->{description}) or do {
                    my $expectfile = $args->{podstub} . "_expected.tmp";
                    open my $tmpfile, ">", $expectfile or die $!;
                    print $tmpfile $args->{expect}, "\n";
                    close $tmpfile;
                    open my $diff_fh, "-|", "$diff $diffopt $expectfile $args->{outfile}"
                        or die("problem diffing: $!");
                    print STDERR "# $_" while <$diff_fh>;
                    close $diff_fh;
                    unlink $expectfile unless $args->{debug};
                };
            }
        }
    }
    else {
        # This is fairly evil, but lets us get detailed failure modes
        # anywhere that we've failed to identify a diff program.
        is($args->{expect}, $args->{result}, $args->{description});
    }
    return 1;
}

=head2 C<record_state_of_cache()>

=over 4

=item * Purpose

During debugging, enable developer to examine the state of the Pod-Html cache
after each call to C<xconvert()>.

=item * Arguments

Single hash reference.

    record_state_of_cache( {
        outdir => "$ENV{P5P_DIR}/pod-html",
        stub => $args->{podstub},
        run => 1,
    } );

Hash reference has the following key-value pairs:

=over 4

=item * C<outdir>

Any directory of your system to which you want a sorted copy of the cache to
be printed.

=item * C<stub>

The same value you passed in C<$args> to C<xconvert()>.

=item * C<run>

Integer which you set manually to distinguish among multiple runs of this
function within the same test file (presumably corresponding to multiple
invocations of C<xconvert()>).

=back

=item * Return Value

Implicitly returns Perl-true value.

=item * Comment

Function will print out location of cache files and other information.

=back

=cut

sub record_state_of_cache {
    my $args = shift;
    die("record_state_of_cache() takes hash reference")
        unless ref($args) eq 'HASH';
    for my $k ( qw| outdir stub run | ) {
        die("Argument to record_state_of_cache() lacks defined $k element")
            unless defined $args->{$k};
    }
    my $cwd = cwd();
    my $cache = catfile($cwd, 'pod2htmd.tmp');
    die("Could not locate file $cache") unless -f $cache;
    die("Could not locate directory $args->{outdir}") unless -d $args->{outdir};
    die("'run' element takes integer") unless $args->{run} =~ m/^\d+$/;

    my @cachelines = ();
    open my $in, '<', $cache or die "Unable to open $cache for reading";
    while (my $l = <$in>) {
        chomp $l;
        push @cachelines, $l;
    }
    close $in  or die "Unable to close $cache after reading";

    my $outfile = catfile($args->{outdir}, "$args->{run}.cache.$args->{stub}.$$.txt");
    die("$outfile already exists; did you remember to increment the 'run' argument?")
        if -f $outfile;
    open my $out, '>', $outfile or die "Unable to open $outfile for writing";
    print $out "$_\n" for (sort @cachelines);
    close $out or die "Unable to close after writing";
    print STDERR "XXX: cache (sorted): $outfile\n";
}

=head1 AUTHORS

The testing code reworked into its present form has many authors and dates
back to the dawn of Perl 5, perhaps beyond.  The documentation was written by
James E Keenan in March 2021.

=cut

1;