File Coverage

blib/lib/Pod/Abstract/Parser.pm
Criterion Covered Total %
statement 104 123 84.5
branch 25 36 69.4
condition 5 14 35.7
subroutine 12 13 92.3
pod 1 8 12.5
total 147 194 75.7


line stmt bran cond sub pod time code
1             package Pod::Abstract::Parser;
2 3     3   16 use strict;
  3         7  
  3         93  
3              
4 3     3   15 use Pod::Parser;
  3         7  
  3         115  
5 3     3   15 use Pod::Abstract::Node;
  3         5  
  3         59  
6 3     3   15 use Data::Dumper;
  3         6  
  3         284  
7 3     3   17 use base qw(Pod::Parser);
  3         6  
  3         8021  
8              
9             our $VERSION = '0.20';
10              
11             =head1 NAME
12              
13             Pod::Abstract::Parser - Internal Parser class of Pod::Abstract.
14              
15             =head1 DESCRIPTION
16              
17             This is a C subclass, used by C to convert Pod
18             text into a Node tree. You do not need to use this class yourself, the
19             C class will do the work of creating the parser and running
20             it for you.
21              
22             =head1 METHODS
23              
24             =head2 new
25              
26             Pod::Abstract::Parser->new( $pod_abstract );
27              
28             Requires a Pod::Abstract object to load Pod data into. Should only be
29             called internally by Pod::Abstract.
30              
31             =cut
32              
33             sub new {
34 9     9 1 14 my $class = shift;
35 9         13 my $p_a = shift;
36            
37             # Always accept non-POD paras, so that the input document can
38             # always be reproduced exactly as entered. These will be stored in
39             # the tree but will be available through distinct methods.
40 9         153 my $self = $class->SUPER::new();
41 9         227 $self->parseopts(
42             -want_nonPODs => 1,
43             -process_cut_cmd => 1,
44             );
45 9         30 $self->{pod_abstract} = $p_a;
46 9         50 my $root_node = Pod::Abstract::Node->new(
47             type => "[ROOT]",
48             );
49 9         21 $self->{cmd_stack} = [ $root_node ];
50 9         18 $self->{root} = $root_node;
51            
52 9         25 return $self;
53             }
54              
55             sub root {
56 15     15 0 22 my $self = shift;
57 15         102 return $self->{root};
58             }
59              
60             # Automatically nest these items: A head1 section continues until the
61             # next head1, list items continue until the next item or end of list,
62             # etc. POD doesn't specify these relationships, but they are natural
63             # and make sense in the whole document context.
64             #
65             # SPECIAL: Start node with < to pull the end node out of the tree and
66             # into the opening node - e.g, pull a "back" into an "over", but not
67             # into an "item". Pulling a command stops it from closing any more
68             # elements, so begin/end style blocks need to use a pull, or one end
69             # will close all begins.
70             my %section_commands = (
71             'head1' => [ 'head1' ],
72             'head2' => [ 'head2', 'head1' ],
73             'head3' => [ 'head3', 'head2', 'head1' ],
74             'head4' => [ 'head4', 'head3', 'head2', 'head1' ],
75             'over' => [ '
76             'item' => [ 'item', 'back' ],
77             'begin' => [ '
78             );
79              
80             # Don't parse anything inside these.
81             my %no_parse = (
82             'begin' => 1,
83             'for' => 1,
84             );
85              
86             my %attr_names = (
87             head1 => 'heading',
88             head2 => 'heading',
89             head3 => 'heading',
90             head4 => 'heading',
91             item => 'label',
92             );
93              
94             sub command {
95 4     4 0 7 my ($self, $command, $paragraph, $line_num) = @_;
96 4   50     14 my $cmd_stack = $self->{cmd_stack} || [ ];
97            
98 4         11 my $p_break = "\n\n";
99 4 100       18 if($paragraph =~ s/([ \t]*\n[ \t]*\n)$//s) {
100 2         6 $p_break = $1;
101             }
102            
103 4 50       16 if($self->cutting) {
104             # Treat as non-pod - i.e, verbatim program text block.
105 0         0 my $element_node = Pod::Abstract::Node->new(
106             type => "#cut",
107             body => "=$command $paragraph$p_break",
108             );
109 0         0 my $top = $cmd_stack->[$#$cmd_stack];
110 0         0 $top->push($element_node);
111             } else {
112             # Treat as command.
113 4         5 my $pull = undef;
114 4         56 while(@$cmd_stack > 0) {
115 5         8 my $last = scalar(@$cmd_stack) - 1;
116 5         7 my @should_end = ( );
117 5         13 @should_end =
118 5         13 grep { $command eq $_ }
119 5         6 @{$section_commands{$cmd_stack->[$last]->type}};
120 5         9 my @should_pull = ( );
121 5         12 @should_pull =
122 5         12 grep { "<$command" eq $_ }
123 5         9 @{$section_commands{$cmd_stack->[$last]->type}};
124 5 100       22 if(@should_end) {
    100          
125 1         4 my $end_cmd = pop @$cmd_stack;
126             } elsif(@should_pull) {
127 1         2 $pull = pop @$cmd_stack;
128 1         3 last;
129             } else {
130 3         5 last;
131             }
132             }
133            
134             # Don't do anything special if we're on a no_parse node
135 4         7 my $top = $cmd_stack->[$#$cmd_stack];
136 4 50 33     12 if($no_parse{$top->type} && !$top->param('parse_me')) {
137 0 0       0 my $t_node = Pod::Abstract::Node->new(
138             type => ':text',
139             body => ($paragraph ne '' ?
140             "=$command $paragraph$p_break" :
141             "=$command$p_break"),
142             );
143 0         0 $top->push($t_node);
144 0         0 return;
145             }
146            
147             # Some commands have to get expandable interior sequences
148 4         6 my $attr_node = undef;
149 4         6 my $attr_name = $attr_names{$command};
150 4         9 my %attr = ( parse_me => 0 );
151 4 100       12 if($attr_name) {
    50          
152 2         7 $attr_node = Pod::Abstract::Node->new(
153             type => '@attribute',
154             );
155 2         83 my $pt = $self->parse_text($paragraph);
156 2         6 $self->load_pt($attr_node, $pt);
157 2         4 $attr{$attr_name} = $attr_node;
158 2         15 $attr{body_attr} = $attr_name;
159             } elsif($paragraph =~ m/^\:/) {
160 0         0 $attr{parse_me} = 1;
161             }
162            
163 4 100       21 my $element_node = Pod::Abstract::Node->new(
164             type => $command,
165             body => ($attr_name ? undef : $paragraph),
166             p_break => $p_break,
167             %attr,
168             );
169 4 100       10 if($pull) {
170 1         5 $pull->param('close_element', $element_node);
171             } else {
172 3         14 $top->push($element_node);
173             }
174 4 100       13 if($section_commands{$command}) {
175 3         8 push @$cmd_stack, $element_node;
176             } else {
177             # No push
178             }
179             }
180            
181 4         51 $self->{cmd_stack} = $cmd_stack;
182             }
183              
184             sub verbatim {
185 0     0 0 0 my ($self, $paragraph, $line_num) = @_;
186            
187 0         0 my $cmd_stack = $self->{cmd_stack};
188 0         0 my $top = $cmd_stack->[$#$cmd_stack];
189              
190 0         0 my $type = ':verbatim';
191 0 0 0     0 if($no_parse{$top->type} && !$top->param('parse_me')) {
192 0         0 $type = ':text';
193             }
194            
195 0         0 my $element_node = Pod::Abstract::Node->new(
196             type => ':verbatim',
197             body => $paragraph,
198             );
199 0         0 $top->push($element_node);
200             }
201              
202             sub preprocess_paragraph {
203 10     10 0 510 my ($self, $text, $line_num) = @_;
204 10 100       196 return $text unless $self->cutting;
205            
206             # This is a non-pod text segment
207 4         16 my $element_node = Pod::Abstract::Node->new(
208             type => "#cut",
209             body => $text,
210             );
211 4         8 my $cmd_stack = $self->{cmd_stack};
212 4         10 my $top = $cmd_stack->[$#$cmd_stack];
213 4         16 $top->push($element_node);
214             }
215              
216             sub textblock {
217 2     2 0 3 my ($self, $paragraph, $line_num) = @_;
218 2         3 my $p_break = "\n\n";
219 2 50       11 if($paragraph =~ s/([ \t]*\n[ \t]*\n)$//s) {
220 2         4 $p_break = $1;
221             }
222 2         7 my $cmd_stack = $self->{cmd_stack};
223 2         3 my $top = $cmd_stack->[$#$cmd_stack];
224 2 50 33     6 if($no_parse{$top->type} && !$top->param('parse_me')) {
225 0         0 my $element_node = Pod::Abstract::Node->new(
226             type => ':text',
227             body => "$paragraph$p_break",
228             );
229 0         0 $top->push($element_node);
230 0         0 return;
231             }
232              
233 2         14 my $element_node = Pod::Abstract::Node->new(
234             type => ':paragraph',
235             p_break => $p_break,
236             );
237 2         119 my $pt = $self->parse_text($paragraph);
238 2         5 $self->load_pt($element_node, $pt);
239              
240 2         23 $top->push($element_node);
241             }
242              
243             # Recursive load
244             sub load_pt {
245 10     10 0 14 my $self = shift;
246 10         12 my $elt = shift;
247 10         11 my $pt = shift;
248            
249 10         45 my @c = $pt->children;
250 10         16 foreach my $c(@c) {
251 12 100       25 if(ref $c) {
252             # Object;
253 2 50       14 if($c->isa('Pod::InteriorSequence')) {
254 2         10 my $cmd = $c->cmd_name;
255 2         21 my $i_node = Pod::Abstract::Node->new(
256             type => ":$cmd",
257             left_delimiter => $c->left_delimiter,
258             right_delimiter => $c->right_delimiter,
259             );
260 2         15 $self->load_pt($i_node, $c->parse_tree);
261 2         5 $elt->push($i_node);
262             } else {
263 0         0 die "$c not an interior sequence!";
264             }
265             } else {
266             # text
267 10         27 my $t_node = Pod::Abstract::Node->new(
268             type => ':text',
269             body => $c,
270             );
271 10         26 $elt->push($t_node);
272             }
273             }
274 10         76 return $elt;
275             }
276              
277             sub end_pod {
278 5     5 0 50 my $self = shift;
279 5         11 my $cmd_stack = $self->{cmd_stack};
280            
281 5         9 my $end_cmd;
282 5   66     34 while(defined $cmd_stack && @$cmd_stack) {
283 6         30 $end_cmd = pop @$cmd_stack;
284             }
285 5 50       25 die "Last node was not root node" unless $end_cmd->type eq '[ROOT]';
286            
287             # Replace the root node.
288 5         100 push @$cmd_stack, $end_cmd;
289             }
290              
291             =head1 AUTHOR
292              
293             Ben Lilburne
294              
295             =head1 COPYRIGHT AND LICENSE
296              
297             Copyright (C) 2009 Ben Lilburne
298              
299             This program is free software; you can redistribute it and/or modify
300             it under the same terms as Perl itself.
301              
302             =cut
303              
304             1;