| File: | blib/lib/App/Test/Generator/PodExampleExtractor.pm |
| Coverage: | 94.9% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package 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 | ||||||
| 8 | our $VERSION = '0.46'; | |||||
| 9 | ||||||
| 10 | Readonly my $ANNOTATION_RE => qr/\#\s*(?:=>|returns?)\s*(.+?)\s*$/; | |||||
| 11 | Readonly 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 | ||||||
| 117 | sub 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 | ||||||
| 198 | sub 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 | # -------------------------------------------------- | |||||
| 232 | sub _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 | # -------------------------------------------------- | |||||
| 252 | sub _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 | # -------------------------------------------------- | |||||
| 276 | sub _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 | # -------------------------------------------------- | |||||
| 332 | sub _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 | # -------------------------------------------------- | |||||
| 379 | sub _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 | # -------------------------------------------------- | |||||
| 404 | sub _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 | ||||||
| 497 | 1; | |||||