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


line stmt bran cond sub pod time code
1             package Pod::Constants;
2              
3 1     1   543 use 5.006002;
  1         2  
4 1     1   3 use strict;
  1         1  
  1         16  
5 1     1   9 use warnings;
  1         1  
  1         32  
6              
7 1     1   3 use base qw(Pod::Parser Exporter);
  1         2  
  1         105  
8 1     1   3 use Carp;
  1         1  
  1         1173  
9              
10             our $VERSION = 0.19;
11              
12             # An ugly hack to go from caller() to the relevant parser state
13             # variable
14             my %parsers;
15              
16             sub end_input {
17             #my ($parser, $command, $paragraph, $line_num) = (@_);
18 22     22 0 17 my $parser = shift;
19              
20 22 100       66 return unless $parser->{active};
21              
22 19 100       29 print "Found end of $parser->{active}\n" if $parser->{DEBUG};
23 19         21 my $whereto = $parser->{wanted_pod_tags}->{$parser->{active}};
24 19 100       40 print "\$_ will be set to:\n---\n$parser->{paragraphs}\n---\n" if $parser->{DEBUG};
25              
26 19 100       203 $parser->{paragraphs} =~ s/^\s*|\s*$//gs if $parser->{trimmed_tags}->{$parser->{active}};
27              
28 19 100       49 if (ref $whereto eq 'CODE') {
    100          
    100          
    50          
29 10 100       17 print "calling sub\n" if $parser->{DEBUG};
30 10         15 local ($_) = $parser->{paragraphs};
31 10         18 $whereto->();
32 10 100       220 print "done\n" if $parser->{DEBUG};
33             } elsif (ref $whereto eq 'SCALAR') {
34 7 100       15 print "inserting into scalar\n" if $parser->{DEBUG};
35 7         8 $$whereto = $parser->{paragraphs};
36             } elsif (ref $whereto eq 'ARRAY') {
37 1 50       3 print "inserting into array\n" if $parser->{DEBUG};
38 1         6 @$whereto = split /\n/, $parser->{paragraphs};
39             } elsif (ref $whereto eq 'HASH') {
40 1 50       3 print "inserting into hash\n" if $parser->{DEBUG};
41             # Oh, sorry, should I be in LISP101?
42             %$whereto = (
43 2         6 map { map { s/^\s*|\s*$//g; $_ } split /=>/ } grep m/^
  4         19  
  4         11  
44             ( (?:[^=]|=[^>])+ ) # scan up to "=>"
45             =>
46             ( (?:[^=]|=[^>])+ =? )# don't allow more "=>"'s
47 1         26 $/x, split /\n/, $parser->{paragraphs},);
48 0         0 } else { die $whereto }
49 19         33 $parser->{active} = undef;
50             }
51              
52             # Pod::Parser overloaded command
53             sub command {
54 39     39 0 51 my ($parser, $command, $paragraph, $line_num) = @_;
55              
56 39         59 $paragraph =~ s/(?:\r\n|\n\r)/\n/g;
57              
58 39 100       78 print "Got command =$command, value=$paragraph\n" if $parser->{DEBUG};
59              
60 39 100       59 $parser->end_input() if $parser->{active};
61              
62 39         23 my ($lookup);
63             # first check for a catch-all for this command type
64 39 100       137 if ( exists $parser->{wanted_pod_tags}->{"*$command"} ) {
    100          
65 2         2 $parser->{paragraphs} = $paragraph;
66 2         49 $parser->{active} = "*$command";
67             } elsif ($command =~ m/^(head\d+|item|(for|begin))$/) {
68 35 100       55 if ( $2 ) {
69             # if it's a "for" or "begin" section, the title is the
70             # first word only
71 1         5 ($lookup, $parser->{paragraphs}) = $paragraph =~ m/^\s*(\S*)\s*(.*)/s;
72             } else {
73             # otherwise, it's up to the end of the line
74 34         138 ($lookup, $parser->{paragraphs}) = $paragraph =~ m/^\s*(\S[^\n]*?)\s*\n(.*)$/s;
75             }
76              
77             # Look for a match by name
78 35 100 33     570 if (defined $lookup && exists $parser->{wanted_pod_tags}->{$lookup}) {
    50          
79 17 100       30 print "Found $lookup\n" if ($parser->{DEBUG});
80 17         515 $parser->{active} = $lookup;
81             } elsif ($parser->{DEBUG}) {
82 0         0 local $^W = 0;
83 0         0 print "Ignoring =$command $paragraph (lookup = $lookup)\n"
84             }
85              
86             } else {
87             # nothing
88 2 50       46 print "Ignoring =$command (not known)\n" if $parser->{DEBUG};
89             }
90             }
91              
92             # Pod::Parser overloaded verbatim
93             sub verbatim {
94 86     86 0 76 my ($parser, $paragraph, $line_num) = @_;
95 86         144 $paragraph =~ s/(?:\r\n|\n\r)/\n/g;
96              
97 86 100       114 my $status = $parser->{active} ? 'using' : 'ignoring';
98 86 100       128 print "Got paragraph: $paragraph ($status)\n" if $parser->{DEBUG};
99              
100             $parser->{paragraphs} .= $paragraph if defined $parser->{active}
101 86 100       2389 }
102              
103             # Pod::Parser overloaded textblock
104 52     52 0 89 sub textblock { goto \&verbatim }
105              
106             sub import {
107 6     6   39866 my $class = shift;
108              
109             # if no args, just return
110 6 100       28 return unless (@_);
111              
112             # try to guess the source file of the caller
113 5         4 my $source_file;
114 5 100       44 if (caller ne 'main') {
115 4         20 (my $module = caller.'.pm') =~ s|::|/|g;
116 4         9 $source_file = $INC{$module};
117             }
118 5   66     16 $source_file ||= $0;
119              
120 5 50       82 croak "Cannot find source file (guessed $source_file) for package ".caller unless -f $source_file;
121              
122             # nasty tricks with the stack so we don't have to be silly with
123             # caller()
124 5         13 unshift @_, $source_file;
125 5         18 goto \&import_from_file;
126             }
127              
128             sub import_from_file {
129 5     5 1 6 my $filename = shift;
130              
131 5         69 my $parser = __PACKAGE__->new();
132              
133 5         13 $parser->{wanted_pod_tags} = {};
134 5         9 $parser->{trimmed_tags} = {};
135 5         6 $parser->{trim_next} = 0;
136 5         6 $parser->{DEBUG} = 0;
137 5         7 $parser->{active} = undef;
138 5         10 $parsers{caller()} = $parser;
139              
140 5         13 $parser->add_hook(@_);
141              
142 5 100       15 print "Pod::Parser: DEBUG: Opening $filename for reading\n" if $parser->{DEBUG};
143 5 50       193 open my $fh, '<', $filename or croak "cannot open $filename for reading; $!";
144              
145 5         1432 $parser->parse_from_filehandle($fh, \*STDOUT);
146              
147 5         85 close $fh;
148             }
149              
150             sub add_hook {
151 6     6 1 9 my $parser;
152 6 100       7 if (eval { $_[0]->isa(__PACKAGE__) }) {
  6         31  
153 5         7 $parser = shift;
154             } else {
155 1 50       3 $parser = $parsers{caller()} or croak 'add_hook called, but don\'t know what for - caller = '.caller;
156             }
157 6         22 while (my ($pod_tag, $var) = splice @_, 0, 2) {
158             #print "$pod_tag: $var\n";
159 24 100       57 if (lc($pod_tag) eq '-trim') {
    100          
    50          
160 4         9 $parser->{trim_next} = $var;
161             } elsif ( lc($pod_tag) eq '-debug' ) {
162 2         5 $parser->{DEBUG} = $var;
163             } elsif (lc($pod_tag) eq '-usage') {
164             # an idea for later - automatic "usage"
165             #%wanted_pod_tags{@tags}
166             } else {
167 18 50       58 if ((ref $var) =~ /^(?:SCALAR|CODE|ARRAY|HASH)$/) {
168 18 100       56 print "Will look for $pod_tag.\n" if $parser->{DEBUG};
169 18         29 $parser->{wanted_pod_tags}->{$pod_tag} = $var;
170 18 100       73 $parser->{trimmed_tags}->{$pod_tag} = 1 if $parser->{trim_next};
171             } else {
172 0         0 croak "Sorry - need a reference to import POD sections into, not the scalar value $var"
173             }
174             }
175             }
176             }
177              
178             sub delete_hook {
179 1     1 1 3 my $parser;
180 1 50       1 if (eval { $_[0]->isa(__PACKAGE__) }) {
  1         6  
181 0         0 $parser = shift;
182             } else {
183 1 50       4 $parser = $parsers{caller()} or croak 'delete_hook called, but don\'t know what for - caller = '.caller;
184             }
185 1         3 while ( my $label = shift ) {
186 1         2 delete $parser->{wanted_pod_tags}->{$label};
187 1         3 delete $parser->{trimmed_tags}->{$label};
188             }
189             }
190              
191             1;
192             __END__