File Coverage

File:bin/pod-example-tester
Coverage:73.0%

linestmtbrancondsubtimecode
1#!/usr/bin/env perl
2
3
1
1
1
1
2274
0
18
use strict;
4
1
1
1
1
1
0
24
use warnings;
5
6
1
1
1
1
1
0
29
use File::Path qw(make_path);
7
1
1
1
1
1
1
6
use File::Spec;
8
1
1
1
1
189
492
17
use FindBin;
9
1
1
1
1
371
4504
2
use Getopt::Long;
10
1
1
1
1
339
25997
85
use Pod::Usage;
11
1
1
1
1
239
272
3
use lib "$FindBin::Bin/../lib";
12
13
1
1
1
1
237
2
30621
use App::Test::Generator::PodExampleExtractor;
14
15 - 66
=head1 NAME

pod-example-tester - Generate round-trip tests from POD code examples

=head1 SYNOPSIS

    pod-example-tester [options] <module.pm>

    Options:
      --output FILE   Write test file to FILE (default: t/pod_examples.t)
      --no-annotated  Skip annotated single-line examples; only use verbatim blocks
      --help          Show this help message
      --man           Show full documentation

    Examples:
      pod-example-tester lib/My/Module.pm
      pod-example-tester --output t/synopsis.t lib/My/Module.pm

=head1 DESCRIPTION

Reads a Perl module, extracts code examples from its POD (from
C<=head1 SYNOPSIS>, C<=head2 SYNOPSIS>, C<=for example begin>/C<=for example end>
blocks, and annotated inline examples), and generates a Test::Most-based
C<.t> file that runs every example as a subtest.

Each subtest:

=over 4

=item * Wraps the example code in C<eval { ... }>

=item * Asserts the example does not die

=item * If the example has a C<# returns value> or C<< # => value >> annotation,
additionally asserts the return value with C<is()>

=back

Running this test suite after any code change ensures that all documented
examples still work — the "round-trip" between documentation and code.

=head1 ANNOTATION FORMAT

Append C<# => value> or C<# returns value> to any indented line in the POD
to document the expected return value:

    my $status = $obj->validate_score(75.5);  # returns 'Pass'
    my $x      = add(2, 3);                   # => 5

The generated test will assert C<is($result, 'Pass', ...)> etc.

=cut
67
68
1
36746
my %opts = (
69        output      => 't/pod_examples.t',
70        annotated   => 1,
71        help        => 0,
72        man         => 0,
73);
74
75GetOptions(
76        'output|o=s'   => \$opts{output},
77        'annotated!'   => \$opts{annotated},
78        'help|h'       => \$opts{help},
79        'man|m'        => \$opts{man},
80
1
50
6
) or pod2usage(2);
81
82
1
50
446
pod2usage(-exitval => 0, -verbose => 1) if $opts{help};
83
1
50
1
pod2usage(-exitval => 0, -verbose => 2) if $opts{man};
84
85
1
50
2
my $input_file = shift @ARGV or pod2usage('Error: No input file specified');
86
1
50
17
die "Error: File not found: $input_file\n" unless -f $input_file;
87
88# Derive the package name from the source file
89
1
50
3
my $package = _detect_package($input_file)
90        or die "Error: Could not determine package name from $input_file\n";
91
92
1
7
my $extractor = App::Test::Generator::PodExampleExtractor->new(file => $input_file);
93
1
3
my $examples  = $extractor->extract();
94
95
1
50
1
unless(@$examples) {
96
0
0
        warn "No POD examples found in $input_file\n";
97
0
0
        exit 0;
98}
99
100# Apply --no-annotated filter
101
1
50
2
if(!$opts{annotated}) {
102
0
0
0
0
        $examples = [ grep { !defined $_->{annotated_line} } @$examples ];
103}
104
105
1
50
2
unless(@$examples) {
106
0
0
        warn "No examples remaining after filtering\n";
107
0
0
        exit 0;
108}
109
110# Ensure output directory exists
111
1
15
my $out_dir = (File::Spec->splitpath($opts{output}))[1];
112
1
50
33
6
make_path($out_dir) if $out_dir && !-d $out_dir;
113
114open my $fh, '>', $opts{output}
115
1
50
31
        or die "Error: Cannot write to $opts{output}: $!\n";
116
117
1
2
_emit_test_file($fh, $package, $input_file, $examples);
118
119
1
82
close $fh;
120
121
1
7
printf "Wrote %d example test(s) to %s\n", scalar(@$examples), $opts{output};
122
123# ---------------------------------------------------------------------------
124# _emit_test_file
125# ---------------------------------------------------------------------------
126sub _emit_test_file {
127
1
1
6
        my ($fh, $package, $source, $examples) = @_;
128
129
1
4
        print $fh "#!/usr/bin/env perl\n";
130
1
1
        print $fh "#\n";
131
1
1
        print $fh "# POD round-trip tests for $package\n";
132
1
2
        print $fh "# Generated from $source by pod-example-tester\n";
133
1
1
        print $fh "# DO NOT EDIT — regenerate with: pod-example-tester $source\n";
134
1
2
        print $fh "#\n\n";
135
1
1
        print $fh "use strict;\n";
136
1
1
        print $fh "use warnings;\n";
137
1
1
        print $fh "use Test::Most;\n\n";
138
1
1
        print $fh "use_ok('$package') or BAIL_OUT(\"Cannot load $package\");\n\n";
139
140
1
1
        my $ctor = _detect_constructor($package);
141
142
1
1
        for my $ex (@$examples) {
143
1
1
                _emit_subtest($fh, $ex, $package, $ctor);
144        }
145
146
1
1
        print $fh "\ndone_testing();\n";
147}
148
149# ---------------------------------------------------------------------------
150# _emit_subtest — write one subtest block
151# ---------------------------------------------------------------------------
152sub _emit_subtest {
153
1
1
1
        my ($fh, $ex, $package, $ctor) = @_;
154
155
1
2
        my $label    = $ex->{label};
156
1
1
        my $code     = $ex->{code};
157
1
1
        my $expected = $ex->{expected};
158
1
1
        my $is_annotated = defined $ex->{annotated_line};
159
160        # Escape label for Perl string
161
1
1
        (my $safe_label = $label) =~ s/'/\\'/g;
162
163
1
1
        print $fh "subtest '$safe_label' => sub {\n";
164
165
1
50
1
        if($is_annotated) {
166                # Single annotated call: wrap in eval, capture return value, compare.
167                # Strip 'my $var =' prefix so the eval captures the bare expression
168                # value directly rather than shadowing with an inner variable.
169
0
0
                my $expr = $code;
170
0
0
                $expr =~ s/^\s*my\s+\$\w+\s*=\s*//;
171
0
0
                $expr =~ s/\s*;\s*$//;
172
173
0
0
0
                my $n_tests = defined($expected) ? 2 : 1;
174
0
0
                print $fh "\tplan tests => $n_tests;\n";
175
176
0
0
0
0
                if($ctor && $expr =~ /\$obj\s*->/) {
177
0
0
                        print $fh "\tmy \$obj = $ctor;\n";
178                }
179
180
0
0
                print $fh "\tmy \$result = eval { $expr };\n";
181
0
0
                print $fh "\tok(!\$\@, 'example runs without error') or diag \$\@;\n";
182
183
0
0
0
                if(defined $expected) {
184
0
0
                        print $fh "\tis(\$result, $expected, 'returns expected value from POD annotation');\n";
185                }
186        } else {
187                # Verbatim block: run whole block in eval, check no exception.
188                # Stub any variables the snippet uses but doesn't declare so the
189                # generated file compiles cleanly under "use strict".
190
1
1
                print $fh "\tplan tests => 1;\n";
191
1
2
                print $fh "\tmy \$ok = eval {\n";
192
1
2
                my @stubs = _stub_undeclared_vars($code);
193
1
50
1
                if(@stubs) {
194
0
0
                        print $fh "\t\tmy (", join(', ', @stubs), ");\n";
195                }
196
1
3
                for my $line (split /\n/, $code) {
197
2
100
11
                        if(my $neutralized = _neutralize_exec($line)) {
198
1
1
                                print $fh "\t\t$neutralized\n";
199                        } else {
200
1
1
                                print $fh "\t\t$line\n";
201                        }
202                }
203
1
1
                print $fh "\t\t1;\n";
204
1
1
                print $fh "\t};\n";
205
1
1
                print $fh "\tok(\$ok && !\$\@, 'example runs without error') or diag \$\@;\n";
206        }
207
208
1
1
        print $fh "};\n\n";
209}
210
211# ---------------------------------------------------------------------------
212# _neutralize_exec — if a line from a verbatim SYNOPSIS block would invoke
213# a shell command (system, exec, backticks, qx), return a replacement
214# note() call that describes what would have run instead of executing it.
215# Returns the empty string (false) for safe lines so the caller can pass
216# them through unchanged.
217#
218# Lines that are already comments are left alone — they can't execute.
219# ---------------------------------------------------------------------------
220sub _neutralize_exec {
221
2
2
2
        my ($line) = @_;
222
2
50
3
        return '' if $line =~ /^\s*#/;    # pure comment — harmless
223
2
100
26
        return '' unless $line =~ /\b(?:system|exec)\s*\(|`|\bqx\s*[{(\[\/|]/;
224
225
1
1
        (my $msg = $line) =~ s/^\s+//;    # strip leading whitespace for display
226
1
1
        $msg =~ s/'/\\'/g;                 # escape single quotes for q{}
227
1
2
        $msg =~ s/\s+$//;
228
229
1
2
        return "note('pod-example-tester: skipped shell call: $msg');";
230}
231
232# ---------------------------------------------------------------------------
233# _stub_undeclared_vars — return sorted list of sigil+name variables (e.g.
234# '$dir', '@items') that appear in the code block but are not declared with
235# my/our/local.  Used to inject stub declarations so generated eval blocks
236# compile cleanly under "use strict" even when SYNOPSIS snippets assume
237# surrounding context (e.g. a $dir variable set up by the caller).
238#
239# Well-known Perl builtins (@_, @INC, @ARGV, %ENV, %INC, %SIG, $_) are
240# excluded because they exist without explicit declaration.
241# ---------------------------------------------------------------------------
242{
243
1
7
0
1
59
0
        my %PERL_BUILTINS = map { $_ => 1 } qw(
244                $_ @_ @INC @ARGV %ENV %INC %SIG
245        );
246
247        sub _stub_undeclared_vars {
248
1
1
1
                my ($code) = @_;
249
250
1
1
                my %declared;
251                # Capture every variable following a my/our/local keyword, including
252                # list forms: my ($a, $b) and foreach my $x(...)
253
1
4
                while($code =~ /\b(?:my|our|local)\b[^;{]*?([\$\@\%]\w+)/g) {
254
1
3
                        $declared{$1} = 1;
255                }
256
257
1
0
                my %used;
258
1
3
                while($code =~ /([\$\@\%])([a-zA-Z_]\w*)/g) {
259
1
2
                        $used{"$1$2"} = 1;
260                }
261
262
1
1
33
1
4
                return sort grep { !$declared{$_} && !$PERL_BUILTINS{$_} } keys %used;
263        }
264}
265
266# ---------------------------------------------------------------------------
267# _detect_package — extract 'package Foo::Bar' from source
268# ---------------------------------------------------------------------------
269
1
1
sub _detect_package {
270
1
1
1
        my ($file) = @_;
271
1
50
30
        open my $fh, '<', $file or return;
272
1
19
        while(<$fh>) {
273
1
50
12
                return $1 if /^package\s+([\w:]+)\s*[;{]/;
274        }
275
0
0
        return;
276}
277
278# ---------------------------------------------------------------------------
279# _detect_constructor — return a string like 'Foo::Bar->new()' if the
280# package has a new() method, else undef
281# ---------------------------------------------------------------------------
282sub _detect_constructor {
283
1
1
1
        my ($package) = @_;
284
285        # Try loading and querying can()
286
1
1
1
1
1
139
        eval { (my $mod = $package) =~ s{::}{/}g; require "$mod.pm" };
287
1
50
2
        return unless !$@;
288
0
0
        return "${package}->new()" if $package->can('new');
289
0
        return;
290}
291