File Coverage

blib/lib/Pod/Example.pm

Criterion	Covered	Total	%
statement	99	99	100.0
branch	32	32	100.0
condition	6	6	100.0
subroutine	14	14	100.0
pod	2	2	100.0
total	153	153	100.0

package Pod::Example;

use base qw(Exporter);
use strict;
use warnings;

use Error::Pure qw(err);
use Pod::Abstract 0.26;
use Pod::Find qw(pod_where);
use Readonly;

# Constants.
Readonly::Array our @EXPORT_OK => qw(get sections);
Readonly::Scalar my $EMPTY_STR => q{};

our $VERSION = 0.17;

# Get content for file or module.
sub get {
	my ($file_or_module, $section, $number_of_example) = @_;

	# Get Pod::Abstract object.
	my $pod_abstract = _pod_abstract($file_or_module);

	# Get section pod.
	my ($code, $example_filename) = _get_content($pod_abstract, $section, $number_of_example);

	return wantarray ? ($code, $example_filename) : $code;
}

# Get example sections.
sub sections {
	my ($file_or_module, $section) = @_;

	# Get Pod::Abstract object.
	my $pod_abstract = _pod_abstract($file_or_module);

	# Get first section.
	my @pod_sections = _get_sections($pod_abstract, $section);

	# Get section names.
	my @sections = map { _get_section_name($_) } @pod_sections;

	return @sections;
}

# Get content in Pod::Abstract object.
sub _get_content {
	my ($pod_abstract, $section, $number_of_example) = @_;

	# Get first section.
	my ($pod_section) = _get_sections($pod_abstract, $section,
		$number_of_example);

	# No section.
	if (! defined $pod_section) {
		return;
	}

	# Remove #cut.
	my @cut = $pod_section->select("//#cut");
	foreach my $cut (@cut) {
		$cut->detach;
	}

	# Get pod.
	my $child_pod = $EMPTY_STR;
	my $example_filename;
	my $first_node = 1;
	foreach my $child ($pod_section->children) {
		if ($child->type eq 'begin') {

			# =begin text as commented text.
			if ($child->body =~ m/^text/ms) {
				$child_pod .= join "\n",
					map { ' #'.$_ }
					split m/\n/ms,
					($child->children)[0]->pod;
				$child_pod .= "\n\n";
				$first_node = 0;

			# Skip =begin html and other unsupported sections.
			} else {
				$first_node = 0;
				next;
			}
		} elsif ($child->type eq 'for') {
			# =for paragraphs are formatter-specific data. Only a first
			# =for comment filename=... paragraph is metadata for this module.
			if ($first_node && $child->body eq 'comment') {
				my ($node) = $child->tree->children;
				my $body = $node->body;
				if ($body =~ m/^filename=([\w\-\.]+)\s*$/ms) {
					$example_filename = $1;
				}
			}
			$first_node = 0;
		} else {
			$child_pod .= $child->pod;
			$first_node = 0;
		}
	}

	# Remove spaces and return.
	my $ret = _remove_spaces($child_pod);

	return ($ret, $example_filename);
}

# Get section name.
# XXX Hack to structure.
sub _get_section_name {
	my $pod_abstract_node = shift;
	return $pod_abstract_node->{'params'}->{'heading'}->{'tree'}
		->{'nodes'}->[0]->{'body'};
}

# Get sections.
sub _get_sections {
	my ($pod_abstract, $section, $number_of_example) = @_;

	# Default section.
	if (! $section) {
		$section = 'EXAMPLE';
	}

	my $section_re = quotemeta $section;

	# Concerete number of example.
	if ($number_of_example) {
		$section_re .= quotemeta $number_of_example;

	# Number of example as potential number.
	} else {
		$section_re .= '\d*';
	}

	# Get and return sections.
	my @sections = $pod_abstract->select('/head1[@heading =~ {^'.$section_re.'$}]');
	my $parent_section_re = quotemeta($section.'S');
	push @sections, $pod_abstract->select('/head1[@heading =~ {^'.
		$parent_section_re.'$}]/head2[@heading =~ {^'.$section_re.'$}]');

	return @sections;
}

# Get pod abstract for module.
sub _pod_abstract {
	my $file_or_module = shift;

	# Module file.
	my $file;
	if (-r $file_or_module) {
		$file = $file_or_module;

	# Module.
	} else {
		$file = pod_where({ -inc => 1 }, $file_or_module);
		if (! $file) {
			err 'Cannot open pod file or Perl module.';
		}
	}

	# Get and return pod.
	return Pod::Abstract->load_file($file);
}

# Remove spaces from example.
sub _remove_spaces {
	my $string = shift;
	my @lines = split /\n/, $string;

	# Get number of spaces in begin.
	my $max = 0;
	foreach my $line (@lines) {
		if (! length $line) {
			next;
		}
		$line =~ m/^(\ +)/ms;
		my $spaces = $EMPTY_STR;
		if ($1) {
			$spaces = $1;
		}
		if ($max == 0 || length $spaces < $max) {
			$max = length $spaces;
		}
	}

	# Remove spaces.
	if ($max > 0) {
		foreach my $line (@lines) {
			if (! length $line) {
				next;
			}
			$line = substr $line, $max;
		}
	}

	# Return string.
	return join "\n", @lines;
}

1;


__END__