File Coverage

File:blib/lib/App/Test/Generator/PodExampleExtractor.pm
Coverage:94.9%

linestmtbrancondsubtimecode
1package App::Test::Generator::PodExampleExtractor;
2
3
8
8
90910
26
use 5.036;
4
8
8
8
20
12
306
use Carp qw(croak);
5
8
8
8
1261
20212
229
use File::Slurp qw(read_file);
6
8
8
8
497
3084
5737
use Readonly;
7
8our $VERSION = '0.46';
9
10Readonly my $ANNOTATION_RE => qr/\#\s*(?:=>|returns?)\s*(.+?)\s*$/;
11Readonly my $VERBATIM_RE   => qr/^[ \t]/;
12
13 - 115
=head1 NAME

App::Test::Generator::PodExampleExtractor - Extract runnable code examples from a Perl module's POD

=head1 SYNOPSIS

    use App::Test::Generator::PodExampleExtractor;

    my $ex = App::Test::Generator::PodExampleExtractor->new(
        file => 'lib/My/Module.pm',
    );
    my $examples = $ex->extract();

    for my $e (@$examples) {
        printf "%-30s  %s\n", $e->{label}, $e->{code};
    }

=head1 DESCRIPTION

Parses the POD of a Perl module and returns a structured list of
runnable code examples.  Three sources are collected:

=over 4

=item * Verbatim blocks inside C<=head1 SYNOPSIS> and C<=head2 SYNOPSIS>

=item * C<=for example begin> ... C<=for example end> blocks

=item * Annotated single-line call examples inside per-method docstrings
(lines matching C<$obj-E<gt>method(...)  # returns value> or
C<method(...)  # => value>)

=back

Return-value annotations of the form C<# returns value> or C<< # => value >>
are parsed and exposed as C<expected> in the result hashref, enabling
downstream test generators to emit C<is()> assertions.

=head2 new

Construct a new extractor for the given source file.

    my $ex = App::Test::Generator::PodExampleExtractor->new(
        file => 'lib/My/Module.pm',
    );

=head3 Arguments

=over 4

=item * C<file>

Path to the Perl module to extract examples from.  Required.
The file must exist on disk.

=back

=head3 Returns

A blessed C<App::Test::Generator::PodExampleExtractor> object.
Croaks if C<file> is missing or does not exist.

=head3 EXAMPLE

    use App::Test::Generator::PodExampleExtractor;

    my $ex = App::Test::Generator::PodExampleExtractor->new(
        file => 'lib/Acme/Widget.pm',
    );
    printf "Extracting examples from %s\n", 'lib/Acme/Widget.pm';

=head3 MESSAGES

=over 4

=item C<file is required>

C<file> was not supplied.

=item C<File not found: $path>

C<file> was supplied but the path does not exist on disk.

=back

=head3 API specification

=head4 input

    { file => { type => SCALAR } }

=head4 output

    { type => OBJECT, isa => 'App::Test::Generator::PodExampleExtractor' }

=head3 FORMAL SPECIFICATION

Pre:  C<defined file ∧ -f file>

Post: C<ref(result) eq 'App::Test::Generator::PodExampleExtractor'>
      âˆ§ C<result-E<gt>{file} eq file>

=cut
116
117sub new {
118
72
495314
        my ($class, %args) = @_;
119
72
170
        croak 'file is required'          unless defined $args{file};
120
67
562
        croak "File not found: $args{file}" unless -f $args{file};
121
61
136
        return bless { file => $args{file} }, $class;
122}
123
124 - 196
=head2 extract

Extract all runnable examples from the module's POD.

    my $examples = $ex->extract();

=head3 Arguments

None beyond C<$self>.

=head3 Returns

An arrayref of example hashrefs, deduplicated by C<code> text.  Each hashref
has the following keys:

=over 4

=item * C<label> — human-readable name for use as a test label (e.g. C<"SYNOPSIS example 1">)

=item * C<section> — the POD section heading (C<=head1>/C<=head2> text) where the example was found

=item * C<code> — the raw code text, dedented.  May be multi-line for verbatim blocks.

=item * C<expected> — the expected return value string from a C<# returns value> or C<< # => value >> annotation; C<undef> if not annotated.

=item * C<annotated_line> — for annotated single-line examples, the bare expression with the annotation stripped; C<undef> for verbatim blocks.

=back

=head3 EXAMPLE

    my $examples = $ex->extract();
    for my $e (@{$examples}) {
        printf "[%s] %s\n", $e->{label}, $e->{code};
        if(defined $e->{expected}) {
            printf "  expects: %s\n", $e->{expected};
        }
    }

    # Count examples without a declared return value
    my @unannotated = grep { !defined $_->{expected} } @{$examples};
    printf "%d unannotated examples\n", scalar @unannotated;

=head3 MESSAGES

=over 4

=item C<File not found: $path> (raised by C<File::Slurp::read_file>)

The source file disappeared between construction and the C<extract> call.

=back

=head3 API specification

=head4 input

    { self => { type => OBJECT, isa => 'App::Test::Generator::PodExampleExtractor' } }

=head4 output

    { type => ARRAYREF }

=head3 FORMAL SPECIFICATION

Post: C<result> is an arrayref where:
      âˆ€ e ∈ result:
        C<defined e-E<gt>{label}>
        âˆ§ C<defined e-E<gt>{section}>
        âˆ§ C<defined e-E<gt>{code}>
        âˆ§ no two entries share the same C<code> value (deduplication)

=cut
197
198sub extract {
199
59
659
        my $self = $_[0];
200
201
59
140
        my $text = read_file($self->{file}, err_mode => 'croak');
202
203
59
3272
        my @raw;
204
59
107
        push @raw, _extract_synopsis_blocks($text);
205
59
81
        push @raw, _extract_for_example_blocks($text);
206
59
76
        push @raw, _extract_annotated_lines($text);
207
208        # deduplicate by code text
209
59
57
        my %seen;
210
59
76
64
213
        my @unique = grep { !$seen{ $_->{code} }++ } @raw;
211
212        # assign numbered labels within each section
213
59
96
        my %section_count;
214
59
64
        for my $e (@unique) {
215
74
88
                my $n = ++$section_count{ $e->{section} };
216
74
112
                $e->{label} = "$e->{section} example $n";
217        }
218
219
59
158
        return \@unique;
220}
221
222# --------------------------------------------------
223# _extract_synopsis_blocks
224#
225# Purpose:    Extract verbatim (indented) paragraphs from
226#             =head1 SYNOPSIS and =head2 SYNOPSIS sections.
227#
228# Entry:      $text - full module source including POD
229#
230# Exit:       Returns a list of example hashrefs.
231# --------------------------------------------------
232sub _extract_synopsis_blocks {
233
59
53
        my $text = $_[0];
234
235
59
45
        my @examples;
236
59
1539
        while($text =~ /=head[12]\s+SYNOPSIS\s*\n(.*?)(?=\n=head|\n=cut|\z)/sg) {
237
29
58
                my $block = $1;
238
29
51
                push @examples, _verbatim_paragraphs($block, 'SYNOPSIS');
239        }
240
59
66
        return @examples;
241}
242
243# --------------------------------------------------
244# _extract_for_example_blocks
245#
246# Purpose:    Extract code inside =for example begin / =for example end pairs.
247#
248# Entry:      $text - full module source including POD
249#
250# Exit:       Returns a list of example hashrefs.
251# --------------------------------------------------
252sub _extract_for_example_blocks {
253
59
60
        my $text = $_[0];
254
255
59
46
        my @examples;
256
59
48
        my $n = 0;
257
59
873
        while($text =~ /=for\s+example\s+begin\s*\n(.*?)=for\s+example\s+end/sg) {
258
4
7
                my $block = $1;
259
4
11
                push @examples, _verbatim_paragraphs($block, '=for example ' . ++$n);
260        }
261
59
57
        return @examples;
262}
263
264# --------------------------------------------------
265# _extract_annotated_lines
266#
267# Purpose:    Find individual lines inside per-method docstrings that
268#             carry a # returns / # => annotation.  These are single-
269#             call examples where the expected value is documented inline.
270#
271# Entry:      $text - full module source including POD
272#
273# Exit:       Returns a list of example hashrefs (each wrapping the
274#             annotated line plus the leading context, if any).
275# --------------------------------------------------
276sub _extract_annotated_lines {
277
59
53
        my $text = $_[0];
278
279
59
46
        my @examples;
280
59
54
        my $section = 'UNKNOWN';
281
282
59
2933
        for my $line (split /\n/, $text) {
283                # Track current POD section heading
284
29840
64362
                if($line =~ /^=head\d+\s+(.+)/) {
285
1077
809
                        $section = $1;
286
1077
867
                        $section =~ s/\s+$//;
287
1077
729
                        next;
288                }
289
290                # Annotated verbatim line inside POD
291
28763
23378
                next unless $line =~ $VERBATIM_RE;
292
14439
32262
                next unless $line =~ $ANNOTATION_RE;
293
294
36
156
                my $expected = $1;
295
36
44
                $expected    =~ s/\s+$//;
296
297                # Strip leading whitespace from code text
298
36
58
                (my $code = $line) =~ s/^[ \t]+//;
299
300                # Strip the annotation comment from the code
301
36
95
                (my $code_only = $code) =~ s/\s*\#\s*(?:=>|returns?)\s*.+$//;
302
36
91
                $code_only =~ s/\s+$//;
303
304
36
52
                next unless length $code_only;
305
306
24
51
                push @examples, {
307                        section        => $section,
308                        code           => $code_only,
309                        expected       => $expected,
310                        annotated_line => $code_only,
311                };
312        }
313
314
59
1117
        return @examples;
315}
316
317# --------------------------------------------------
318# _verbatim_paragraphs
319#
320# Purpose:    Split a POD text block into its indented
321#             (verbatim) paragraphs and return example hashrefs.
322#             Paragraphs that contain no Perl-looking syntax
323#             (e.g. shell commands like "prove -l t/foo.t") are
324#             silently dropped — they would cause compile errors
325#             under "use strict" in the generated test file.
326#
327# Entry:      $block   - text block to scan
328#             $section - label string for the containing section
329#
330# Exit:       Returns a list of example hashrefs with no expected value.
331# --------------------------------------------------
332sub _verbatim_paragraphs {
333
33
51
        my ($block, $section) = @_;
334
335
33
38
        my @examples;
336        my @current;
337
338
33
197
        for my $line (split /\n/, $block) {
339
1188
1030
                if($line =~ $VERBATIM_RE || ($line =~ /\S/ && @current)) {
340
1129
2743
                        push @current, $line;
341                } else {
342
59
227
                        if(@current) {
343
32
53
                                my $code = _dedent(join("\n", @current));
344
32
61
                                push @examples, {
345                                        section        => $section,
346                                        code           => $code,
347                                        expected       => undef,
348                                        annotated_line => undef,
349                                } if length($code) && _looks_like_perl($code);
350
32
53
                                @current = ();
351                        }
352                }
353        }
354
355
33
79
        if(@current) {
356
31
108
                my $code = _dedent(join("\n", @current));
357
31
144
                push @examples, {
358                        section        => $section,
359                        code           => $code,
360                        expected       => undef,
361                        annotated_line => undef,
362                } if length($code) && _looks_like_perl($code);
363        }
364
365
33
295
        return @examples;
366}
367
368# --------------------------------------------------
369# _dedent
370#
371# Purpose:    Remove the common leading whitespace from every line
372#             of a verbatim block so relative indentation is kept
373#             (like Python's textwrap.dedent).
374#
375# Entry:      $text - multi-line string
376#
377# Exit:       Returns the dedented string with trailing whitespace removed.
378# --------------------------------------------------
379sub _dedent {
380
63
59
        my $text = $_[0];
381
63
154
        my @lines = split /\n/, $text;
382
63
1129
65
956
        my @non_empty = grep { /\S/ } @lines;
383
63
79
        return '' unless @non_empty;
384
1122
648
        my ($min) = sort { $a <=> $b }
385
63
1129
62
1132
                    map  { /^([ \t]*)/ ? length($1) : 0 } @non_empty;
386
63
883
        s/^[ \t]{0,$min}// for @lines;
387
63
104
        my $out = join("\n", @lines);
388
63
295
        $out =~ s/\s+$//;
389
63
145
        return $out;
390}
391
392# --------------------------------------------------
393# _looks_like_perl
394#
395# Purpose:    Return true when a verbatim block contains at least one
396#             line that is recognisably Perl syntax.  Used to skip
397#             blocks of shell commands (e.g. "prove -l t/foo.t") that
398#             would cause compile errors under "use strict".
399#
400# Entry:      $code - dedented block text
401#
402# Exit:       Returns 1 (Perl) or '' (not Perl).
403# --------------------------------------------------
404sub _looks_like_perl {
405
63
58
        my $code = $_[0];
406
63
125
        for my $line (split /\n/, $code) {
407
76
104
                next unless $line =~ /\S/;    # skip blank lines
408
76
85
                next if $line =~ /^\s*#/;     # skip comment-only lines
409                # Perl sigils
410
64
236
                return 1 if $line =~ /[\$\@\%]/;
411                # Perl keywords at start of statement
412
29
108
                return 1 if $line =~ /^\s*(?:my|our|local|use|require|no|package|sub|for(?:each)?|if|unless|while|until|return|die|croak|warn|print|say|eval|BEGIN|END|push|pop|shift|unshift|keys|values|grep|map|sort)\b/;
413                # Method call or package separator
414
15
42
                return 1 if $line =~ /(?:->|::)/;
415                # Fat comma — a hash or argument list
416
12
17
                return 1 if $line =~ /=>/;
417        }
418
11
19
        return '';
419}
420
421 - 495
=head1 COMMON PITFALLS

=over 4

=item Shell-command blocks are silently dropped

Verbatim paragraphs that contain only shell commands (e.g. C<prove -l t/> or
C<extract-schemas lib/My/Module.pm>) are filtered out by C<_looks_like_perl>.
They would cause compile errors under C<use strict> in a generated test file.
If you want a shell command to appear as an example, put it in a POD comment
block, not a verbatim paragraph.

=item Annotations must be on the B<same line> as the call expression

The C<# returns> / C<< # => >> annotation is parsed as a line-level suffix.
Multi-line calls spread across multiple lines will not pick up an annotation on
the last line — only the last line is examined, and the call expression on
earlier lines is lost.

=item C<expected> is always a raw string

The C<expected> field is the literal text captured after C<# returns> or
C<< # => >>.  It is not evaluated or type-converted.  Downstream code that
emits C<is($result, $expected)> must handle quoting appropriately.

=item SYNOPSIS blocks from C<=head3> and deeper are not collected

Only C<=head1 SYNOPSIS> and C<=head2 SYNOPSIS> sections are scanned for
verbatim blocks.  Deeper heading levels are ignored.

=back

=head1 LIMITATIONS

=over 4

=item No evaluation of verbatim blocks

Verbatim blocks are returned as raw code strings.  The module does not evaluate
them or check that they are syntactically valid Perl.  Blocks that are
syntactically broken will cause the downstream test file to fail to compile.

=item Deduplication is by exact C<code> text

Two examples with identical C<code> strings are deduplicated even if they come
from different sections.  If the same one-liner appears in both SYNOPSIS and a
method docstring, only the first occurrence is kept.

=back

=head1 SEE ALSO

=over 4

=item C<bin/pod-example-tester>

=item L<App::Test::Generator>

=item L<Pod::Simple>

=back

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 LICENCE AND COPYRIGHT

Copyright 2026 Nigel Horne.

Usage is subject to the terms of GPL2.
If you use it,
please let me know.

=cut
496
4971;