+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__
+
+=encoding utf-8
+