view release on metacpan or  search on metacpan

lib/App/Test/Generator/PodExampleExtractor.pm  view on Meta::CPAN

		# Annotated verbatim line inside POD
		next unless $line =~ $VERBATIM_RE;
		next unless $line =~ $ANNOTATION_RE;

		my $expected = $1;
		$expected    =~ s/\s+$//;

		# Strip leading whitespace from code text
		(my $code = $line) =~ s/^[ \t]+//;

		# Strip the annotation comment from the code
		(my $code_only = $code) =~ s/\s*\#\s*(?:=>|returns?)\s*.+$//;
		$code_only =~ s/\s+$//;

		next unless length $code_only;

		push @examples, {
			section        => $section,
			code           => $code_only,
			expected       => $expected,
			annotated_line => $code_only,
		};
	}

	return @examples;
}

# --------------------------------------------------
# _verbatim_paragraphs
#
# Purpose:    Split a POD text block into its indented
#             (verbatim) paragraphs and return example hashrefs.
#             Paragraphs that contain no Perl-looking syntax
#             (e.g. shell commands like "prove -l t/foo.t") are
#             silently dropped — they would cause compile errors
#             under "use strict" in the generated test file.
#
# Entry:      $block   - text block to scan
#             $section - label string for the containing section
#
# Exit:       Returns a list of example hashrefs with no expected value.
# --------------------------------------------------
sub _verbatim_paragraphs {
	my ($block, $section) = @_;

	my @examples;
	my @current;

	for my $line (split /\n/, $block) {
		if($line =~ $VERBATIM_RE || ($line =~ /\S/ && @current)) {
			push @current, $line;
		} else {
			if(@current) {
				my $code = _dedent(join("\n", @current));
				push @examples, {
					section        => $section,
					code           => $code,
					expected       => undef,
					annotated_line => undef,
				} if length($code) && _looks_like_perl($code);
				@current = ();
			}
		}
	}

	if(@current) {
		my $code = _dedent(join("\n", @current));
		push @examples, {
			section        => $section,
			code           => $code,
			expected       => undef,
			annotated_line => undef,
		} if length($code) && _looks_like_perl($code);
	}

	return @examples;
}

# --------------------------------------------------
# _dedent
#
# Purpose:    Remove the common leading whitespace from every line
#             of a verbatim block so relative indentation is kept
#             (like Python's textwrap.dedent).
#
# Entry:      $text - multi-line string
#
# Exit:       Returns the dedented string with trailing whitespace removed.
# --------------------------------------------------
sub _dedent {
	my $text = $_[0];
	my @lines = split /\n/, $text;
	my @non_empty = grep { /\S/ } @lines;
	return '' unless @non_empty;
	my ($min) = sort { $a <=> $b }
	            map  { /^([ \t]*)/ ? length($1) : 0 } @non_empty;
	s/^[ \t]{0,$min}// for @lines;
	my $out = join("\n", @lines);
	$out =~ s/\s+$//;
	return $out;
}

# --------------------------------------------------
# _looks_like_perl
#
# Purpose:    Return true when a verbatim block contains at least one
#             line that is recognisably Perl syntax.  Used to skip
#             blocks of shell commands (e.g. "prove -l t/foo.t") that
#             would cause compile errors under "use strict".
#
# Entry:      $code - dedented block text
#
# Exit:       Returns 1 (Perl) or '' (not Perl).
# --------------------------------------------------
sub _looks_like_perl {
	my $code = $_[0];
	for my $line (split /\n/, $code) {
		next unless $line =~ /\S/;    # skip blank lines
		next if $line =~ /^\s*#/;     # skip comment-only lines
		# Perl sigils
		return 1 if $line =~ /[\$\@\%]/;
		# Perl keywords at start of statement
		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/;
		# Method call or package separator
		return 1 if $line =~ /(?:->|::)/;
		# Fat comma — a hash or argument list
		return 1 if $line =~ /=>/;
	}
	return '';
}

=head1 AUTHOR

Nigel Horne

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;