File Coverage

blib/lib/Pod/Constants.pm

Criterion	Covered	Total	%
statement	99	104	95.1
branch	68	80	85.0
condition	3	6	50.0
subroutine	13	13	100.0
pod	3	7	42.8
total	186	210	88.5

package Pod::Constants;

use 5.006002;
use strict;
use warnings;

use base qw(Pod::Parser Exporter);
use Carp;

our $VERSION = 0.18;

# An ugly hack to go from caller() to the relevant parser state
# variable
my %parsers;

sub end_input {
	#my ($parser, $command, $paragraph, $line_num) = (@_);
	my $parser = shift;

	return unless $parser->{active};

	print "Found end of $parser->{active}\n" if $parser->{DEBUG};
	my $whereto = $parser->{wanted_pod_tags}->{$parser->{active}};
	print "\$_ will be set to:\n---\n$parser->{paragraphs}\n---\n" if $parser->{DEBUG};

	$parser->{paragraphs} =~ s/^\s*|\s*$//gs if $parser->{trimmed_tags}->{$parser->{active}};

	if (ref $whereto eq 'CODE') {
		print "calling sub\n" if $parser->{DEBUG};
		local ($_) = $parser->{paragraphs};
		$whereto->();
		print "done\n" if $parser->{DEBUG};
	} elsif (ref $whereto eq 'SCALAR') {
		print "inserting into scalar\n" if $parser->{DEBUG};
		$$whereto = $parser->{paragraphs};
	} elsif (ref $whereto eq 'ARRAY') {
		print "inserting into array\n" if $parser->{DEBUG};
		@$whereto = split /\n/, $parser->{paragraphs};
	} elsif (ref $whereto eq 'HASH') {
		print "inserting into hash\n" if $parser->{DEBUG};
		# Oh, sorry, should I be in LISP101?
		%$whereto = (
			map { map { s/^\s*|\s*$//g; $_ } split /=>/ } grep m/^
					 ( (?:[^=]|=[^>])+ )   # scan up to "=>"
					 =>
					 ( (?:[^=]|=[^>])+ =? )# don't allow more "=>"'s
					 $/x, split /\n/, $parser->{paragraphs},);
	} else { die $whereto }
	$parser->{active} = undef;
}

# Pod::Parser overloaded command
sub command {
	my ($parser, $command, $paragraph, $line_num) = @_;

	$paragraph =~ s/(?:\r\n|\n\r)/\n/g;

	print "Got command =$command, value=$paragraph\n" if $parser->{DEBUG};

	$parser->end_input() if $parser->{active};

	my ($lookup);
	# first check for a catch-all for this command type
	if ( exists $parser->{wanted_pod_tags}->{"*$command"} ) {
		$parser->{paragraphs} = $paragraph;
		$parser->{active} = "*$command";
	} elsif ($command =~ m/^(head\d+|item|(for|begin))$/) {
		if ( $2 ) {
			# if it's a "for" or "begin" section, the title is the
			# first word only
			($lookup, $parser->{paragraphs}) = $paragraph =~ m/^\s*(\S*)\s*(.*)/s;
		} else {
			# otherwise, it's up to the end of the line
			($lookup, $parser->{paragraphs}) = $paragraph =~ m/^\s*(\S[^\n]*?)\s*\n(.*)$/s;
		}

		# Look for a match by name
		if (defined $lookup && exists $parser->{wanted_pod_tags}->{$lookup}) {
			print "Found $lookup\n" if ($parser->{DEBUG});
			$parser->{active} = $lookup;
		} elsif ($parser->{DEBUG}) {
			local $^W = 0;
			print "Ignoring =$command $paragraph (lookup = $lookup)\n"
		}

	} else {
		# nothing
		print "Ignoring =$command (not known)\n" if $parser->{DEBUG};
	}
}

# Pod::Parser overloaded verbatim
sub verbatim {
	my ($parser, $paragraph, $line_num) = @_;
	$paragraph =~ s/(?:\r\n|\n\r)/\n/g;

	my $status = $parser->{active} ? 'using' : 'ignoring';
	print "Got paragraph: $paragraph ($status)\n" if $parser->{DEBUG};

	$parser->{paragraphs} .= $paragraph if defined $parser->{active}
}

# Pod::Parser overloaded textblock
sub textblock { goto \&verbatim }

sub import {
	my $class = shift;

	# if no args, just return
	return unless (@_);

	# try to guess the source file of the caller
	my $source_file;
	if (caller ne 'main') {
		(my $module = caller.'.pm') =~ s|::|/|g;
		$source_file = $INC{$module};
	}
	$source_file ||= $0;

	croak "Cannot find source file (guessed $source_file) for package ".caller unless -f $source_file;

	# nasty tricks with the stack so we don't have to be silly with
	# caller()
	unshift @_, $source_file;
	goto \&import_from_file;
}

sub import_from_file {
	my $filename = shift;

	my $parser = __PACKAGE__->new();

	$parser->{wanted_pod_tags} = {};
	$parser->{trimmed_tags} = {};
	$parser->{trim_next} = 0;
	$parser->{DEBUG} = 0;
	$parser->{active} = undef;
	$parsers{caller()} = $parser;

	$parser->add_hook(@_);

	print "Pod::Parser: DEBUG: Opening $filename for reading\n" if $parser->{DEBUG};
	open my $fh, '<', $filename or croak "cannot open $filename for reading; $!";

	$parser->parse_from_filehandle($fh, \*STDOUT);

	close $fh;
}

sub add_hook {
	my $parser;
	if (eval { $_[0]->isa(__PACKAGE__) }) {
		$parser = shift;
	} else {
		$parser = $parsers{caller()} or croak 'add_hook called, but don\'t know what for - caller = '.caller;
	}
	while (my ($pod_tag, $var) = splice @_, 0, 2) {
		#print "$pod_tag: $var\n";
		if (lc($pod_tag) eq '-trim') {
			$parser->{trim_next} = $var;
		} elsif ( lc($pod_tag) eq '-debug' ) {
			$parser->{DEBUG} = $var;
		} elsif (lc($pod_tag) eq '-usage') {
			# an idea for later - automatic "usage"
			#%wanted_pod_tags{@tags}
		} else {
			if ((ref $var) =~ /^(?:SCALAR|CODE|ARRAY|HASH)$/) {
				print "Will look for $pod_tag.\n" if $parser->{DEBUG};
				$parser->{wanted_pod_tags}->{$pod_tag} = $var;
				$parser->{trimmed_tags}->{$pod_tag} = 1 if $parser->{trim_next};
			} else {
				croak "Sorry - need a reference to import POD sections into, not the scalar value $var"
			}
		}
	}
}

sub delete_hook {
	my $parser;
	if (eval { $_[0]->isa(__PACKAGE__) }) {
		$parser = shift;
	} else {
		$parser = $parsers{caller()} or croak 'delete_hook called, but don\'t know what for - caller = '.caller;
	}
	while ( my $label = shift ) {
		delete $parser->{wanted_pod_tags}->{$label};
		delete $parser->{trimmed_tags}->{$label};
	}
}

1;
__END__