Commit | Line | Data |
351625bd |
1 | |
2 | require 5; |
3 | package Pod::Simple; |
4 | use strict; |
5 | use Carp (); |
6 | BEGIN { *DEBUG = sub () {0} unless defined &DEBUG } |
7 | use integer; |
9d65762f |
8 | use Pod::Escapes 1.04 (); |
351625bd |
9 | use Pod::Simple::LinkSection (); |
10 | use Pod::Simple::BlackBox (); |
11 | #use utf8; |
12 | |
13 | use vars qw( |
14 | $VERSION @ISA |
15 | @Known_formatting_codes @Known_directives |
16 | %Known_formatting_codes %Known_directives |
17 | $NL |
18 | ); |
19 | |
20 | @ISA = ('Pod::Simple::BlackBox'); |
433cf6b4 |
21 | $VERSION = '3.13'; |
351625bd |
22 | |
23 | @Known_formatting_codes = qw(I B C L E F S X Z); |
24 | %Known_formatting_codes = map(($_=>1), @Known_formatting_codes); |
25 | @Known_directives = qw(head1 head2 head3 head4 item over back); |
26 | %Known_directives = map(($_=>'Plain'), @Known_directives); |
27 | $NL = $/ unless defined $NL; |
28 | |
29 | #----------------------------------------------------------------------------- |
30 | # Set up some constants: |
31 | |
32 | BEGIN { |
33 | if(defined &ASCII) { } |
34 | elsif(chr(65) eq 'A') { *ASCII = sub () {1} } |
35 | else { *ASCII = sub () {''} } |
36 | |
37 | unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} } |
38 | DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n"; |
39 | unless(MANY_LINES() >= 1) { |
40 | die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting"; |
41 | } |
42 | if(defined &UNICODE) { } |
43 | elsif($] >= 5.008) { *UNICODE = sub() {1} } |
44 | else { *UNICODE = sub() {''} } |
45 | } |
46 | if(DEBUG > 2) { |
47 | print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n"; |
48 | print "# We are under a Unicode-safe Perl.\n"; |
49 | } |
50 | |
51 | # Design note: |
52 | # This is a parser for Pod. It is not a parser for the set of Pod-like |
53 | # languages which happens to contain Pod -- it is just for Pod, plus possibly |
54 | # some extensions. |
55 | |
56 | # @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ |
57 | #@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ |
58 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
59 | |
60 | __PACKAGE__->_accessorize( |
61 | 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters |
62 | 'source_filename', # Filename of the source, for use in warnings |
63 | 'source_dead', # Whether to consider this parser's source dead |
64 | |
65 | 'output_fh', # The filehandle we're writing to, if applicable. |
66 | # Used only in some derived classes. |
67 | |
68 | 'hide_line_numbers', # For some dumping subclasses: whether to pointedly |
69 | # suppress the start_line attribute |
9d65762f |
70 | |
351625bd |
71 | 'line_count', # the current line number |
72 | 'pod_para_count', # count of pod paragraphs seen so far |
73 | |
74 | 'no_whining', # whether to suppress whining |
75 | 'no_errata_section', # whether to suppress the errata section |
76 | 'complain_stderr', # whether to complain to stderr |
77 | |
78 | 'doc_has_started', # whether we've fired the open-Document event yet |
79 | |
80 | 'bare_output', # For some subclasses: whether to prepend |
81 | # header-code and postpend footer-code |
82 | |
351625bd |
83 | 'nix_X_codes', # whether to ignore X<...> codes |
84 | 'merge_text', # whether to avoid breaking a single piece of |
85 | # text up into several events |
86 | |
87 | 'preserve_whitespace', # whether to try to keep whitespace as-is |
9d65762f |
88 | 'strip_verbatim_indent', # What indent to strip from verbatim |
351625bd |
89 | |
90 | 'content_seen', # whether we've seen any real Pod content |
91 | 'errors_seen', # TODO: document. whether we've seen any errors (fatal or not) |
92 | |
93 | 'codes_in_verbatim', # for PseudoPod extensions |
94 | |
95 | 'code_handler', # coderef to call when a code (non-pod) line is seen |
96 | 'cut_handler', # coderef to call when a =cut line is seen |
97 | #Called like: |
98 | # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler; |
99 | # $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler; |
9d65762f |
100 | |
351625bd |
101 | ); |
102 | |
103 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
104 | |
105 | sub any_errata_seen { # good for using as an exit() value... |
106 | return shift->{'errors_seen'} || 0; |
107 | } |
108 | |
109 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
110 | # Pull in some functions that, for some reason, I expect to see here too: |
111 | BEGIN { |
112 | *pretty = \&Pod::Simple::BlackBox::pretty; |
113 | *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol; |
114 | } |
115 | |
116 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
117 | |
118 | sub version_report { |
119 | my $class = ref($_[0]) || $_[0]; |
120 | if($class eq __PACKAGE__) { |
121 | return "$class $VERSION"; |
122 | } else { |
123 | my $v = $class->VERSION; |
124 | return "$class $v (" . __PACKAGE__ . " $VERSION)"; |
125 | } |
126 | } |
127 | |
128 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
129 | |
130 | #sub curr_open { # read-only list accessor |
131 | # return @{ $_[0]{'curr_open'} || return() }; |
132 | #} |
133 | #sub _curr_open_listref { $_[0]{'curr_open'} ||= [] } |
134 | |
135 | |
136 | sub output_string { |
137 | # Works by faking out output_fh. Simplifies our code. |
138 | # |
139 | my $this = shift; |
140 | return $this->{'output_string'} unless @_; # GET. |
141 | |
142 | require Pod::Simple::TiedOutFH; |
143 | my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] ); |
144 | $$x = '' unless defined $$x; |
145 | DEBUG > 4 and print "# Output string set to $x ($$x)\n"; |
146 | $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]); |
147 | return |
148 | $this->{'output_string'} = $_[0]; |
149 | #${ ${ $this->{'output_fh'} } }; |
150 | } |
151 | |
152 | sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} } |
153 | sub abandon_output_fh { $_[0]->output_fh(undef) } |
154 | # These don't delete the string or close the FH -- they just delete our |
155 | # references to it/them. |
156 | # TODO: document these |
157 | |
158 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
159 | |
160 | sub new { |
161 | # takes no parameters |
162 | my $class = ref($_[0]) || $_[0]; |
163 | #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc " |
164 | # . __PACKAGE__ ); |
165 | return bless { |
166 | 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) }, |
167 | 'accept_directives' => { %Known_directives }, |
168 | 'accept_targets' => {}, |
169 | }, $class; |
170 | } |
171 | |
172 | |
173 | |
174 | # TODO: an option for whether to interpolate E<...>'s, or just resolve to codes. |
175 | |
176 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
177 | |
178 | sub _handle_element_start { # OVERRIDE IN DERIVED CLASS |
179 | my($self, $element_name, $attr_hash_r) = @_; |
180 | return; |
181 | } |
182 | |
183 | sub _handle_element_end { # OVERRIDE IN DERIVED CLASS |
184 | my($self, $element_name) = @_; |
185 | return; |
186 | } |
187 | |
188 | sub _handle_text { # OVERRIDE IN DERIVED CLASS |
189 | my($self, $text) = @_; |
190 | return; |
191 | } |
192 | |
193 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
194 | # |
195 | # And now directives (not targets) |
196 | |
197 | sub accept_directive_as_verbatim { shift->_accept_directives('Verbatim', @_) } |
198 | sub accept_directive_as_data { shift->_accept_directives('Data', @_) } |
199 | sub accept_directive_as_processed { shift->_accept_directives('Plain', @_) } |
200 | |
201 | sub _accept_directives { |
202 | my($this, $type) = splice @_,0,2; |
203 | foreach my $d (@_) { |
204 | next unless defined $d and length $d; |
205 | Carp::croak "\"$d\" isn't a valid directive name" |
206 | unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s; |
207 | Carp::croak "\"$d\" is already a reserved Pod directive name" |
208 | if exists $Known_directives{$d}; |
209 | $this->{'accept_directives'}{$d} = $type; |
210 | DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n"; |
211 | } |
212 | DEBUG > 6 and print "$this\'s accept_directives : ", |
213 | pretty($this->{'accept_directives'}), "\n"; |
214 | |
215 | return sort keys %{ $this->{'accept_directives'} } if wantarray; |
216 | return; |
217 | } |
218 | |
219 | #-------------------------------------------------------------------------- |
220 | # TODO: document these: |
221 | |
222 | sub unaccept_directive { shift->unaccept_directives(@_) }; |
223 | |
224 | sub unaccept_directives { |
225 | my $this = shift; |
226 | foreach my $d (@_) { |
227 | next unless defined $d and length $d; |
228 | Carp::croak "\"$d\" isn't a valid directive name" |
229 | unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s; |
230 | Carp::croak "But you must accept \"$d\" directives -- it's a builtin!" |
231 | if exists $Known_directives{$d}; |
232 | delete $this->{'accept_directives'}{$d}; |
233 | DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n"; |
234 | } |
235 | return sort keys %{ $this->{'accept_directives'} } if wantarray; |
236 | return |
237 | } |
238 | |
239 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
240 | # |
241 | # And now targets (not directives) |
242 | |
243 | sub accept_target { shift->accept_targets(@_) } # alias |
244 | sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias |
245 | |
246 | |
247 | sub accept_targets { shift->_accept_targets('1', @_) } |
248 | |
249 | sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) } |
250 | # forces them to be processed, even when there's no ":". |
251 | |
252 | sub _accept_targets { |
253 | my($this, $type) = splice @_,0,2; |
254 | foreach my $t (@_) { |
255 | next unless defined $t and length $t; |
256 | # TODO: enforce some limitations on what a target name can be? |
257 | $this->{'accept_targets'}{$t} = $type; |
258 | DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n"; |
259 | } |
260 | return sort keys %{ $this->{'accept_targets'} } if wantarray; |
261 | return; |
262 | } |
263 | |
264 | #-------------------------------------------------------------------------- |
265 | sub unaccept_target { shift->unaccept_targets(@_) } |
266 | |
267 | sub unaccept_targets { |
268 | my $this = shift; |
269 | foreach my $t (@_) { |
270 | next unless defined $t and length $t; |
271 | # TODO: enforce some limitations on what a target name can be? |
272 | delete $this->{'accept_targets'}{$t}; |
273 | DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n"; |
274 | } |
275 | return sort keys %{ $this->{'accept_targets'} } if wantarray; |
276 | return; |
277 | } |
278 | |
279 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
280 | # |
281 | # And now codes (not targets or directives) |
282 | |
283 | sub accept_code { shift->accept_codes(@_) } # alias |
284 | |
285 | sub accept_codes { # Add some codes |
286 | my $this = shift; |
287 | |
288 | foreach my $new_code (@_) { |
289 | next unless defined $new_code and length $new_code; |
290 | if(ASCII) { |
291 | # A good-enough check that it's good as an XML Name symbol: |
292 | Carp::croak "\"$new_code\" isn't a valid element name" |
293 | if $new_code =~ |
294 | m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ |
295 | # Characters under 0x80 that aren't legal in an XML Name. |
296 | or $new_code =~ m/^[-\.0-9]/s |
297 | or $new_code =~ m/:[-\.0-9]/s; |
298 | # The legal under-0x80 Name characters that |
299 | # an XML Name still can't start with. |
300 | } |
301 | |
302 | $this->{'accept_codes'}{$new_code} = $new_code; |
303 | |
304 | # Yes, map to itself -- just so that when we |
305 | # see "=extend W [whatever] thatelementname", we say that W maps |
306 | # to whatever $this->{accept_codes}{thatelementname} is, |
307 | # i.e., "thatelementname". Then when we go re-mapping, |
308 | # a "W" in the treelet turns into "thatelementname". We only |
309 | # remap once. |
310 | # If we say we accept "W", then a "W" in the treelet simply turns |
311 | # into "W". |
312 | } |
313 | |
314 | return; |
315 | } |
316 | |
317 | #-------------------------------------------------------------------------- |
318 | sub unaccept_code { shift->unaccept_codes(@_) } |
319 | |
320 | sub unaccept_codes { # remove some codes |
321 | my $this = shift; |
322 | |
323 | foreach my $new_code (@_) { |
324 | next unless defined $new_code and length $new_code; |
325 | if(ASCII) { |
326 | # A good-enough check that it's good as an XML Name symbol: |
327 | Carp::croak "\"$new_code\" isn't a valid element name" |
328 | if $new_code =~ |
329 | m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ |
330 | # Characters under 0x80 that aren't legal in an XML Name. |
331 | or $new_code =~ m/^[-\.0-9]/s |
332 | or $new_code =~ m/:[-\.0-9]/s; |
333 | # The legal under-0x80 Name characters that |
334 | # an XML Name still can't start with. |
335 | } |
336 | |
337 | Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!" |
338 | if grep $new_code eq $_, @Known_formatting_codes; |
339 | |
340 | delete $this->{'accept_codes'}{$new_code}; |
341 | |
342 | DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n"; |
343 | } |
344 | |
345 | return; |
346 | } |
347 | |
348 | |
349 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
350 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
351 | |
352 | sub parse_string_document { |
353 | my $self = shift; |
354 | my @lines; |
355 | foreach my $line_group (@_) { |
356 | next unless defined $line_group and length $line_group; |
357 | pos($line_group) = 0; |
358 | while($line_group =~ |
359 | m/([^\n\r]*)((?:\r?\n)?)/g |
360 | ) { |
361 | #print(">> $1\n"), |
362 | $self->parse_lines($1) |
363 | if length($1) or length($2) |
364 | or pos($line_group) != length($line_group); |
365 | # I.e., unless it's a zero-length "empty line" at the very |
366 | # end of "foo\nbar\n" (i.e., between the \n and the EOS). |
367 | } |
368 | } |
369 | $self->parse_lines(undef); # to signal EOF |
370 | return $self; |
371 | } |
372 | |
373 | sub _init_fh_source { |
374 | my($self, $source) = @_; |
375 | |
376 | #DEBUG > 1 and print "Declaring $source as :raw for starters\n"; |
377 | #$self->_apply_binmode($source, ':raw'); |
378 | #binmode($source, ":raw"); |
379 | |
380 | return; |
381 | } |
382 | |
383 | #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. |
384 | # |
385 | |
386 | sub parse_file { |
387 | my($self, $source) = (@_); |
388 | |
389 | if(!defined $source) { |
390 | Carp::croak("Can't use empty-string as a source for parse_file"); |
391 | } elsif(ref(\$source) eq 'GLOB') { |
392 | $self->{'source_filename'} = '' . ($source); |
393 | } elsif(ref $source) { |
394 | $self->{'source_filename'} = '' . ($source); |
395 | } elsif(!length $source) { |
396 | Carp::croak("Can't use empty-string as a source for parse_file"); |
397 | } else { |
398 | { |
399 | local *PODSOURCE; |
400 | open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!"); |
401 | $self->{'source_filename'} = $source; |
402 | $source = *PODSOURCE{IO}; |
403 | } |
404 | $self->_init_fh_source($source); |
405 | } |
406 | # By here, $source is a FH. |
407 | |
408 | $self->{'source_fh'} = $source; |
409 | |
410 | my($i, @lines); |
411 | until( $self->{'source_dead'} ) { |
412 | splice @lines; |
413 | for($i = MANY_LINES; $i--;) { # read those many lines at a time |
414 | local $/ = $NL; |
415 | push @lines, scalar(<$source>); # readline |
416 | last unless defined $lines[-1]; |
417 | # but pass thru the undef, which will set source_dead to true |
418 | } |
419 | $self->parse_lines(@lines); |
420 | } |
421 | delete($self->{'source_fh'}); # so it can be GC'd |
422 | return $self; |
423 | } |
424 | |
425 | #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. |
426 | |
427 | sub parse_from_file { |
428 | # An emulation of Pod::Parser's interface, for the sake of Perldoc. |
429 | # Basically just a wrapper around parse_file. |
430 | |
431 | my($self, $source, $to) = @_; |
432 | $self = $self->new unless ref($self); # so we tolerate being a class method |
433 | |
434 | if(!defined $source) { $source = *STDIN{IO} |
435 | } elsif(ref(\$source) eq 'GLOB') { # stet |
436 | } elsif(ref($source) ) { # stet |
437 | } elsif(!length $source |
438 | or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i |
439 | ) { |
440 | $source = *STDIN{IO}; |
441 | } |
442 | |
443 | if(!defined $to) { $self->output_fh( *STDOUT{IO} ); |
444 | } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to ); |
445 | } elsif(ref($to)) { $self->output_fh( $to ); |
446 | } elsif(!length $to |
447 | or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i |
448 | ) { |
449 | $self->output_fh( *STDOUT{IO} ); |
450 | } else { |
451 | require Symbol; |
452 | my $out_fh = Symbol::gensym(); |
453 | DEBUG and print "Write-opening to $to\n"; |
454 | open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!"; |
455 | binmode($out_fh) |
456 | if $self->can('write_with_binmode') and $self->write_with_binmode; |
457 | $self->output_fh($out_fh); |
458 | } |
459 | |
460 | return $self->parse_file($source); |
461 | } |
462 | |
463 | #----------------------------------------------------------------------------- |
464 | |
465 | sub whine { |
466 | #my($self,$line,$complaint) = @_; |
467 | my $self = shift(@_); |
468 | ++$self->{'errors_seen'}; |
469 | if($self->{'no_whining'}) { |
470 | DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n"; |
471 | return; |
472 | } |
473 | return $self->_complain_warn(@_) if $self->{'complain_stderr'}; |
474 | return $self->_complain_errata(@_); |
475 | } |
476 | |
477 | sub scream { # like whine, but not suppressable |
478 | #my($self,$line,$complaint) = @_; |
479 | my $self = shift(@_); |
480 | ++$self->{'errors_seen'}; |
481 | return $self->_complain_warn(@_) if $self->{'complain_stderr'}; |
482 | return $self->_complain_errata(@_); |
483 | } |
484 | |
485 | sub _complain_warn { |
486 | my($self,$line,$complaint) = @_; |
487 | return printf STDERR "%s around line %s: %s\n", |
488 | $self->{'source_filename'} || 'Pod input', $line, $complaint; |
489 | } |
490 | |
491 | sub _complain_errata { |
492 | my($self,$line,$complaint) = @_; |
493 | if( $self->{'no_errata_section'} ) { |
494 | DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n"; |
495 | } else { |
496 | DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n"; |
497 | push @{$self->{'errata'}{$line}}, $complaint |
498 | # for a report to be generated later! |
499 | } |
500 | return 1; |
501 | } |
502 | |
503 | #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ |
504 | |
505 | sub _get_initial_item_type { |
506 | # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n" |
507 | my($self, $para) = @_; |
508 | return $para->[1]{'~type'} if $para->[1]{'~type'}; |
509 | |
510 | return $para->[1]{'~type'} = 'text' |
511 | if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1'; |
512 | # Else fall thru to the general case: |
513 | return $self->_get_item_type($para); |
514 | } |
515 | |
516 | |
517 | |
518 | sub _get_item_type { # mutates the item!! |
519 | my($self, $para) = @_; |
520 | return $para->[1]{'~type'} if $para->[1]{'~type'}; |
521 | |
522 | |
523 | # Otherwise we haven't yet been to this node. Maybe alter it... |
524 | |
525 | my $content = join "\n", @{$para}[2 .. $#$para]; |
526 | |
527 | if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) { |
528 | # Like: "=item *", "=item * ", "=item" |
529 | splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] |
530 | $para->[1]{'~orig_content'} = $content; |
531 | return $para->[1]{'~type'} = 'bullet'; |
532 | |
533 | } elsif($content =~ m/^\s*\*\s+(.+)/s) { # tolerance |
534 | |
535 | # Like: "=item * Foo bar baz"; |
536 | $para->[1]{'~orig_content'} = $content; |
537 | $para->[1]{'~_freaky_para_hack'} = $1; |
538 | DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n"; |
539 | splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] |
540 | return $para->[1]{'~type'} = 'bullet'; |
541 | |
542 | } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) { |
543 | # Like: "=item 1.", "=item 123412" |
544 | |
545 | $para->[1]{'~orig_content'} = $content; |
546 | $para->[1]{'number'} = $1; # Yes, stores the number there! |
547 | |
548 | splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] |
549 | return $para->[1]{'~type'} = 'number'; |
550 | |
551 | } else { |
552 | # It's anything else. |
553 | return $para->[1]{'~type'} = 'text'; |
554 | |
555 | } |
556 | } |
557 | |
558 | #----------------------------------------------------------------------------- |
559 | |
560 | sub _make_treelet { |
561 | my $self = shift; # and ($para, $start_line) |
562 | my $treelet; |
563 | if(!@_) { |
564 | return ['']; |
565 | } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') { |
566 | # Hack so we can pass in fake-o pre-cooked paragraphs: |
567 | # just have the first line be a reference to a ['~Top', {}, ...] |
568 | # We use this feechure in gen_errata and stuff. |
569 | |
570 | DEBUG and print "Applying precooked treelet hack to $_[0][0]\n"; |
571 | $treelet = $_[0][0]; |
572 | splice @$treelet, 0, 2; # lop the top off |
573 | return $treelet; |
574 | } else { |
575 | $treelet = $self->_treelet_from_formatting_codes(@_); |
576 | } |
577 | |
578 | if( $self->_remap_sequences($treelet) ) { |
579 | $self->_treat_Zs($treelet); # Might as well nix these first |
580 | $self->_treat_Ls($treelet); # L has to precede E and S |
581 | $self->_treat_Es($treelet); |
582 | $self->_treat_Ss($treelet); # S has to come after E |
583 | |
584 | $self->_wrap_up($treelet); # Nix X's and merge texties |
585 | |
586 | } else { |
587 | DEBUG and print "Formatless treelet gets fast-tracked.\n"; |
588 | # Very common case! |
589 | } |
590 | |
591 | splice @$treelet, 0, 2; # lop the top off |
592 | |
593 | return $treelet; |
594 | } |
595 | |
596 | #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. |
597 | |
598 | sub _wrap_up { |
599 | my($self, @stack) = @_; |
600 | my $nixx = $self->{'nix_X_codes'}; |
601 | my $merge = $self->{'merge_text' }; |
602 | return unless $nixx or $merge; |
603 | |
604 | DEBUG > 2 and print "\nStarting _wrap_up traversal.\n", |
605 | $merge ? (" Merge mode on\n") : (), |
606 | $nixx ? (" Nix-X mode on\n") : (), |
607 | ; |
608 | |
609 | |
610 | my($i, $treelet); |
611 | while($treelet = shift @stack) { |
612 | DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n"; |
613 | for($i = 2; $i < @$treelet; ++$i) { # iterate over children |
614 | DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n"; |
615 | if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') { |
616 | DEBUG > 3 and print " Nixing X node at $i\n"; |
617 | splice(@$treelet, $i, 1); # just nix this node (and its descendants) |
618 | # no need to back-update the counter just yet |
619 | redo; |
620 | |
621 | } elsif($merge and $i != 2 and # non-initial |
622 | !ref $treelet->[$i] and !ref $treelet->[$i - 1] |
623 | ) { |
624 | DEBUG > 3 and print " Merging ", $i-1, |
625 | ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n"; |
626 | $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0]; |
627 | DEBUG > 4 and print " Now: ", $i-1, ":[$treelet->[$i-1]]\n"; |
628 | --$i; |
629 | next; |
630 | # since we just pulled the possibly last node out from under |
631 | # ourselves, we can't just redo() |
632 | |
633 | } elsif( ref $treelet->[$i] ) { |
634 | DEBUG > 4 and print " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n"; |
635 | push @stack, $treelet->[$i]; |
636 | |
637 | if($treelet->[$i][0] eq 'L') { |
638 | my $thing; |
639 | foreach my $attrname ('section', 'to') { |
640 | if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) { |
641 | unshift @stack, $thing; |
642 | DEBUG > 4 and print " +Enqueuing ", |
643 | pretty( $treelet->[$i][1]{$attrname} ), |
644 | " as an attribute value to tweak.\n"; |
645 | } |
646 | } |
647 | } |
648 | } |
649 | } |
650 | } |
651 | DEBUG > 2 and print "End of _wrap_up traversal.\n\n"; |
652 | |
653 | return; |
654 | } |
655 | |
656 | #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. |
657 | |
658 | sub _remap_sequences { |
659 | my($self,@stack) = @_; |
660 | |
661 | if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) { |
662 | # VERY common case: abort it. |
663 | DEBUG and print "Skipping _remap_sequences: formatless treelet.\n"; |
664 | return 0; |
665 | } |
666 | |
667 | my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?"); |
668 | |
669 | my $start_line = $stack[0][1]{'start_line'}; |
670 | DEBUG > 2 and printf |
671 | "\nAbout to start _remap_sequences on treelet from line %s.\n", |
672 | $start_line || '[?]' |
673 | ; |
674 | DEBUG > 3 and print " Map: ", |
675 | join('; ', map "$_=" . ( |
676 | ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_} |
677 | ), |
678 | sort keys %$map ), |
679 | ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map) |
680 | ? " (all normal)\n" : "\n" |
681 | ; |
682 | |
683 | # A recursive algorithm implemented iteratively! Whee! |
684 | |
685 | my($is, $was, $i, $treelet); # scratch |
686 | while($treelet = shift @stack) { |
687 | DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n"; |
688 | for($i = 2; $i < @$treelet; ++$i) { # iterate over children |
689 | next unless ref $treelet->[$i]; # text nodes are uninteresting |
690 | |
691 | DEBUG > 4 and print " Noting child $i : $treelet->[$i][0]<...>\n"; |
692 | |
693 | $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] }; |
694 | if( DEBUG > 3 ) { |
695 | if(!defined $is) { |
696 | print " Code $was<> is UNKNOWN!\n"; |
697 | } elsif($is eq $was) { |
698 | DEBUG > 4 and print " Code $was<> stays the same.\n"; |
699 | } else { |
700 | print " Code $was<> maps to ", |
701 | ref($is) |
702 | ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" ) |
703 | : "tag $is<...>.\n"; |
704 | } |
705 | } |
706 | |
707 | if(!defined $is) { |
708 | $self->whine($start_line, "Deleting unknown formatting code $was<>"); |
709 | $is = $treelet->[$i][0] = '1'; # But saving the children! |
710 | # I could also insert a leading "$was<" and tailing ">" as |
711 | # children of this node, but something about that seems icky. |
712 | } |
713 | if(ref $is) { |
714 | my @dynasty = @$is; |
715 | DEBUG > 4 and print " Renaming $was node to $dynasty[-1]\n"; |
716 | $treelet->[$i][0] = pop @dynasty; |
717 | my $nugget; |
718 | while(@dynasty) { |
719 | DEBUG > 4 and printf |
720 | " Grafting a new %s node between %s and %s\n", |
721 | $dynasty[-1], $treelet->[0], $treelet->[$i][0], |
722 | ; |
723 | |
724 | #$nugget = ; |
725 | splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]]; |
726 | # relace node with a new parent |
727 | } |
728 | } elsif($is eq '0') { |
729 | splice(@$treelet, $i, 1); # just nix this node (and its descendants) |
730 | --$i; # back-update the counter |
731 | } elsif($is eq '1') { |
732 | splice(@$treelet, $i, 1 # replace this node with its children! |
733 | => splice @{ $treelet->[$i] },2 |
734 | # (not catching its first two (non-child) items) |
735 | ); |
736 | --$i; # back up for new stuff |
737 | } else { |
738 | # otherwise it's unremarkable |
739 | unshift @stack, $treelet->[$i]; # just recurse |
740 | } |
741 | } |
742 | } |
743 | |
744 | DEBUG > 2 and print "End of _remap_sequences traversal.\n\n"; |
745 | |
746 | if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) { |
747 | DEBUG and print "Noting that the treelet is now formatless.\n"; |
748 | return 0; |
749 | } |
750 | return 1; |
751 | } |
752 | |
753 | # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . |
754 | |
755 | sub _ponder_extend { |
756 | |
757 | # "Go to an extreme, move back to a more comfortable place" |
758 | # -- /Oblique Strategies/, Brian Eno and Peter Schmidt |
759 | |
760 | my($self, $para) = @_; |
761 | my $content = join ' ', splice @$para, 2; |
762 | $content =~ s/^\s+//s; |
763 | $content =~ s/\s+$//s; |
764 | |
765 | DEBUG > 2 and print "Ogling extensor: =extend $content\n"; |
766 | |
767 | if($content =~ |
768 | m/^ |
769 | (\S+) # 1 : new item |
770 | \s+ |
771 | (\S+) # 2 : fallback(s) |
772 | (?:\s+(\S+))? # 3 : element name(s) |
773 | \s* |
774 | $ |
775 | /xs |
776 | ) { |
777 | my $new_letter = $1; |
778 | my $fallbacks_one = $2; |
779 | my $elements_one; |
780 | $elements_one = defined($3) ? $3 : $1; |
781 | |
782 | DEBUG > 2 and print "Extensor has good syntax.\n"; |
783 | |
784 | unless($new_letter =~ m/^[A-Z]$/s or $new_letter) { |
785 | DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n"; |
786 | $self->whine( |
787 | $para->[1]{'start_line'}, |
788 | "You can extend only formatting codes A-Z, not like \"$new_letter\"" |
789 | ); |
790 | return; |
791 | } |
792 | |
793 | if(grep $new_letter eq $_, @Known_formatting_codes) { |
794 | DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n"; |
795 | $self->whine( |
796 | $para->[1]{'start_line'}, |
797 | "You can't extend an established code like \"$new_letter\"" |
798 | ); |
799 | |
800 | #TODO: or allow if last bit is same? |
801 | |
802 | return; |
803 | } |
804 | |
805 | unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s # like "B", "M,I", etc. |
806 | or $fallbacks_one eq '0' or $fallbacks_one eq '1' |
807 | ) { |
808 | $self->whine( |
809 | $para->[1]{'start_line'}, |
810 | "Format for second =extend parameter must be like" |
811 | . " M or 1 or 0 or M,N or M,N,O but you have it like " |
812 | . $fallbacks_one |
813 | ); |
814 | return; |
815 | } |
816 | |
817 | unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc. |
818 | $self->whine( |
819 | $para->[1]{'start_line'}, |
820 | "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like " |
821 | . $elements_one |
822 | ); |
823 | return; |
824 | } |
825 | |
826 | my @fallbacks = split ',', $fallbacks_one, -1; |
827 | my @elements = split ',', $elements_one, -1; |
828 | |
829 | foreach my $f (@fallbacks) { |
830 | next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1'; |
831 | DEBUG > 2 and print " Can't fall back on unknown code $f\n"; |
832 | $self->whine( |
833 | $para->[1]{'start_line'}, |
834 | "Can't use unknown formatting code '$f' as a fallback for '$new_letter'" |
835 | ); |
836 | return; |
837 | } |
838 | |
839 | DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n", |
840 | @fallbacks, @elements; |
841 | |
842 | my $canonical_form; |
843 | foreach my $e (@elements) { |
844 | if(exists $self->{'accept_codes'}{$e}) { |
845 | DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n"; |
846 | $canonical_form = $e; |
847 | last; # first acceptable elementname wins! |
848 | } else { |
849 | DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n"; |
850 | } |
851 | } |
852 | |
853 | |
854 | if( defined $canonical_form ) { |
855 | # We found a good N => elementname mapping |
856 | $self->{'accept_codes'}{$new_letter} = $canonical_form; |
857 | DEBUG > 2 and print |
858 | "Extensor maps $new_letter => known element $canonical_form.\n"; |
859 | } else { |
860 | # We have to use the fallback(s), which might be '0', or '1'. |
861 | $self->{'accept_codes'}{$new_letter} |
862 | = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks; |
863 | DEBUG > 2 and print |
864 | "Extensor maps $new_letter => fallbacks @fallbacks.\n"; |
865 | } |
866 | |
867 | } else { |
868 | DEBUG > 2 and print "Extensor has bad syntax.\n"; |
869 | $self->whine( |
870 | $para->[1]{'start_line'}, |
871 | "Unknown =extend syntax: $content" |
872 | ) |
873 | } |
874 | return; |
875 | } |
876 | |
877 | |
878 | #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:. |
879 | |
880 | sub _treat_Zs { # Nix Z<...>'s |
881 | my($self,@stack) = @_; |
882 | |
883 | my($i, $treelet); |
884 | my $start_line = $stack[0][1]{'start_line'}; |
885 | |
886 | # A recursive algorithm implemented iteratively! Whee! |
887 | |
888 | while($treelet = shift @stack) { |
889 | for($i = 2; $i < @$treelet; ++$i) { # iterate over children |
890 | next unless ref $treelet->[$i]; # text nodes are uninteresting |
891 | unless($treelet->[$i][0] eq 'Z') { |
892 | unshift @stack, $treelet->[$i]; # recurse |
893 | next; |
894 | } |
895 | |
896 | DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n"; |
897 | |
898 | # bitch UNLESS it's empty |
899 | unless( @{$treelet->[$i]} == 2 |
900 | or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '') |
901 | ) { |
902 | $self->whine( $start_line, "A non-empty Z<>" ); |
903 | } # but kill it anyway |
904 | |
905 | splice(@$treelet, $i, 1); # thereby just nix this node. |
906 | --$i; |
907 | |
908 | } |
909 | } |
910 | |
911 | return; |
912 | } |
913 | |
914 | # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . |
915 | |
916 | # Quoting perlpodspec: |
917 | |
918 | # In parsing an L<...> code, Pod parsers must distinguish at least four |
919 | # attributes: |
920 | |
921 | ############# Not used. Expressed via the element children plus |
922 | ############# the value of the "content-implicit" flag. |
923 | # First: |
924 | # The link-text. If there is none, this must be undef. (E.g., in "L<Perl |
925 | # Functions|perlfunc>", the link-text is "Perl Functions". In |
926 | # "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note |
927 | # that link text may contain formatting.) |
928 | # |
929 | |
930 | ############# The element children |
931 | # Second: |
932 | # The possibly inferred link-text -- i.e., if there was no real link text, |
933 | # then this is the text that we'll infer in its place. (E.g., for |
934 | # "L<Getopt::Std>", the inferred link text is "Getopt::Std".) |
935 | # |
936 | |
937 | ############# The "to" attribute (which might be text, or a treelet) |
938 | # Third: |
939 | # The name or URL, or undef if none. (E.g., in "L<Perl |
940 | # Functions|perlfunc>", the name -- also sometimes called the page -- is |
941 | # "perlfunc". In "L</CAVEATS>", the name is undef.) |
942 | # |
943 | |
944 | ############# The "section" attribute (which might be next, or a treelet) |
945 | # Fourth: |
946 | # The section (AKA "item" in older perlpods), or undef if none. E.g., in |
947 | # Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this |
948 | # is not the same as a manpage section like the "5" in "man 5 crontab". |
949 | # "Section Foo" in the Pod sense means the part of the text that's |
950 | # introduced by the heading or item whose text is "Foo".) |
951 | # |
952 | # Pod parsers may also note additional attributes including: |
953 | # |
954 | |
955 | ############# The "type" attribute. |
956 | # Fifth: |
957 | # A flag for whether item 3 (if present) is a URL (like |
958 | # "http://lists.perl.org" is), in which case there should be no section |
959 | # attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or |
960 | # possibly a man page name (like "crontab(5)" is). |
961 | # |
962 | |
963 | ############# Not implemented, I guess. |
964 | # Sixth: |
965 | # The raw original L<...> content, before text is split on "|", "/", etc, |
966 | # and before E<...> codes are expanded. |
967 | |
968 | |
969 | # For L<...> codes without a "name|" part, only E<...> and Z<> codes may |
970 | # occur -- no other formatting codes. That is, authors should not use |
971 | # "L<B<Foo::Bar>>". |
972 | # |
973 | # Note, however, that formatting codes and Z<>'s can occur in any and all |
974 | # parts of an L<...> (i.e., in name, section, text, and url). |
975 | |
976 | sub _treat_Ls { # Process our dear dear friends, the L<...> sequences |
977 | |
978 | # L<name> |
979 | # L<name/"sec"> or L<name/sec> |
980 | # L</"sec"> or L</sec> or L<"sec"> |
981 | # L<text|name> |
982 | # L<text|name/"sec"> or L<text|name/sec> |
983 | # L<text|/"sec"> or L<text|/sec> or L<text|"sec"> |
984 | # L<scheme:...> |
a242eeb4 |
985 | # L<text|scheme:...> |
351625bd |
986 | |
987 | my($self,@stack) = @_; |
988 | |
989 | my($i, $treelet); |
990 | my $start_line = $stack[0][1]{'start_line'}; |
991 | |
992 | # A recursive algorithm implemented iteratively! Whee! |
993 | |
994 | while($treelet = shift @stack) { |
995 | for(my $i = 2; $i < @$treelet; ++$i) { |
996 | # iterate over children of current tree node |
997 | next unless ref $treelet->[$i]; # text nodes are uninteresting |
998 | unless($treelet->[$i][0] eq 'L') { |
999 | unshift @stack, $treelet->[$i]; # recurse |
1000 | next; |
1001 | } |
1002 | |
1003 | |
1004 | # By here, $treelet->[$i] is definitely an L node |
69473a20 |
1005 | my $ell = $treelet->[$i]; |
1006 | DEBUG > 1 and print "Ogling L node $ell\n"; |
351625bd |
1007 | |
1008 | # bitch if it's empty |
69473a20 |
1009 | if( @{$ell} == 2 |
1010 | or (@{$ell} == 3 and $ell->[2] eq '') |
351625bd |
1011 | ) { |
1012 | $self->whine( $start_line, "An empty L<>" ); |
1013 | $treelet->[$i] = 'L<>'; # just make it a text node |
1014 | next; # and move on |
1015 | } |
1016 | |
1017 | # Catch URLs: |
69473a20 |
1018 | |
1019 | # there are a number of possible cases: |
1020 | # 1) text node containing url: http://foo.com |
1021 | # -> [ 'http://foo.com' ] |
1022 | # 2) text node containing url and text: foo|http://foo.com |
1023 | # -> [ 'foo|http://foo.com' ] |
1024 | # 3) text node containing url start: mailto:xE<at>foo.com |
1025 | # -> [ 'mailto:x', [ E ... ], 'foo.com' ] |
1026 | # 4) text node containing url start and text: foo|mailto:xE<at>foo.com |
1027 | # -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ] |
1028 | # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com |
1029 | # -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ] |
1030 | # ... etc. |
1031 | |
1032 | # anything before the url is part of the text. |
1033 | # anything after it is part of the url. |
1034 | # the url text node itself may contain parts of both. |
1035 | |
1036 | if (my ($url_index, $text_part, $url_part) = |
1037 | # grep is no good here; we want to bail out immediately so that we can |
1038 | # use $1, $2, etc. without having to do the match twice. |
1039 | sub { |
1040 | for (2..$#$ell) { |
1041 | next if ref $ell->[$_]; |
1042 | next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s; |
1043 | return ($_, $1, $2); |
1044 | } |
1045 | return; |
1046 | }->() |
351625bd |
1047 | ) { |
69473a20 |
1048 | $ell->[1]{'type'} = 'url'; |
351625bd |
1049 | |
69473a20 |
1050 | my @text = @{$ell}[2..$url_index-1]; |
1051 | push @text, $text_part if defined $text_part; |
351625bd |
1052 | |
69473a20 |
1053 | my @url = @{$ell}[$url_index+1..$#$ell]; |
1054 | unshift @url, $url_part; |
1055 | |
1056 | unless (@text) { |
1057 | $ell->[1]{'content-implicit'} = 'yes'; |
1058 | @text = @url; |
351625bd |
1059 | } |
1060 | |
69473a20 |
1061 | $ell->[1]{to} = Pod::Simple::LinkSection->new( |
1062 | @url == 1 |
1063 | ? $url[0] |
1064 | : [ '', {}, @url ], |
1065 | ); |
1066 | |
1067 | splice @$ell, 2, $#$ell, @text; |
1068 | |
1069 | next; |
351625bd |
1070 | } |
1071 | |
351625bd |
1072 | # Catch some very simple and/or common cases |
69473a20 |
1073 | if(@{$ell} == 3 and ! ref $ell->[2]) { |
1074 | my $it = $ell->[2]; |
351625bd |
1075 | if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections |
1076 | # Hopefully neither too broad nor too restrictive a RE |
1077 | DEBUG > 1 and print "Catching \"$it\" as manpage link.\n"; |
69473a20 |
1078 | $ell->[1]{'type'} = 'man'; |
351625bd |
1079 | # This's the only place where man links can get made. |
69473a20 |
1080 | $ell->[1]{'content-implicit'} = 'yes'; |
1081 | $ell->[1]{'to' } = |
351625bd |
1082 | Pod::Simple::LinkSection->new( $it ); # treelet! |
1083 | |
1084 | next; |
1085 | } |
1086 | if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) { |
1087 | # Extremely forgiving idea of what constitutes a bare |
1088 | # modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala> |
1089 | DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n"; |
69473a20 |
1090 | $ell->[1]{'type'} = 'pod'; |
1091 | $ell->[1]{'content-implicit'} = 'yes'; |
1092 | $ell->[1]{'to' } = |
351625bd |
1093 | Pod::Simple::LinkSection->new( $it ); # treelet! |
1094 | next; |
1095 | } |
1096 | # else fall thru... |
1097 | } |
1098 | |
1099 | |
1100 | |
1101 | # ...Uhoh, here's the real L<...> parsing stuff... |
1102 | # "With the ill behavior, with the ill behavior, with the ill behavior..." |
1103 | |
1104 | DEBUG > 1 and print "Running a real parse on this non-trivial L\n"; |
1105 | |
1106 | |
1107 | my $link_text; # set to an arrayref if found |
351625bd |
1108 | my @ell_content = @$ell; |
1109 | splice @ell_content,0,2; # Knock off the 'L' and {} bits |
1110 | |
1111 | DEBUG > 3 and print " Ell content to start: ", |
1112 | pretty(@ell_content), "\n"; |
1113 | |
1114 | |
1115 | # Look for the "|" -- only in CHILDREN (not all underlings!) |
1116 | # Like L<I like the strictness|strict> |
1117 | DEBUG > 3 and |
1118 | print " Peering at L content for a '|' ...\n"; |
1119 | for(my $j = 0; $j < @ell_content; ++$j) { |
1120 | next if ref $ell_content[$j]; |
1121 | DEBUG > 3 and |
1122 | print " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n"; |
1123 | |
1124 | if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) { |
1125 | my @link_text = ($1); # might be 0-length |
1126 | $ell_content[$j] = $2; # might be 0-length |
1127 | |
1128 | DEBUG > 3 and |
1129 | print " FOUND a '|' in it. Splitting into [$1] + [$2]\n"; |
1130 | |
1131 | unshift @link_text, splice @ell_content, 0, $j; |
1132 | # leaving only things at J and after |
1133 | @ell_content = grep ref($_)||length($_), @ell_content ; |
1134 | $link_text = [grep ref($_)||length($_), @link_text ]; |
1135 | DEBUG > 3 and printf |
1136 | " So link text is %s\n and remaining ell content is %s\n", |
1137 | pretty($link_text), pretty(@ell_content); |
1138 | last; |
1139 | } |
1140 | } |
1141 | |
1142 | |
1143 | # Now look for the "/" -- only in CHILDREN (not all underlings!) |
1144 | # And afterward, anything left in @ell_content will be the raw name |
1145 | # Like L<Foo::Bar/Object Methods> |
1146 | my $section_name; # set to arrayref if found |
1147 | DEBUG > 3 and print " Peering at L-content for a '/' ...\n"; |
1148 | for(my $j = 0; $j < @ell_content; ++$j) { |
1149 | next if ref $ell_content[$j]; |
1150 | DEBUG > 3 and |
1151 | print " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n"; |
1152 | |
1153 | if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) { |
1154 | my @section_name = ($2); # might be 0-length |
1155 | $ell_content[$j] = $1; # might be 0-length |
1156 | |
1157 | DEBUG > 3 and |
1158 | print " FOUND a '/' in it.", |
1159 | " Splitting to page [...$1] + section [$2...]\n"; |
1160 | |
1161 | push @section_name, splice @ell_content, 1+$j; |
1162 | # leaving only things before and including J |
1163 | |
1164 | @ell_content = grep ref($_)||length($_), @ell_content ; |
1165 | @section_name = grep ref($_)||length($_), @section_name ; |
1166 | |
1167 | # Turn L<.../"foo"> into L<.../foo> |
1168 | if(@section_name |
1169 | and !ref($section_name[0]) and !ref($section_name[-1]) |
1170 | and $section_name[ 0] =~ m/^\"/s |
1171 | and $section_name[-1] =~ m/\"$/s |
1172 | and !( # catch weird degenerate case of L<"> ! |
1173 | @section_name == 1 and $section_name[0] eq '"' |
1174 | ) |
1175 | ) { |
1176 | $section_name[ 0] =~ s/^\"//s; |
1177 | $section_name[-1] =~ s/\"$//s; |
1178 | DEBUG > 3 and |
1179 | print " Quotes removed: ", pretty(@section_name), "\n"; |
1180 | } else { |
1181 | DEBUG > 3 and |
1182 | print " No need to remove quotes in ", pretty(@section_name), "\n"; |
1183 | } |
1184 | |
1185 | $section_name = \@section_name; |
1186 | last; |
1187 | } |
1188 | } |
1189 | |
1190 | # Turn L<"Foo Bar"> into L</Foo Bar> |
1191 | if(!$section_name and @ell_content |
1192 | and !ref($ell_content[0]) and !ref($ell_content[-1]) |
1193 | and $ell_content[ 0] =~ m/^\"/s |
1194 | and $ell_content[-1] =~ m/\"$/s |
1195 | and !( # catch weird degenerate case of L<"> ! |
1196 | @ell_content == 1 and $ell_content[0] eq '"' |
1197 | ) |
1198 | ) { |
1199 | $section_name = [splice @ell_content]; |
1200 | $section_name->[ 0] =~ s/^\"//s; |
1201 | $section_name->[-1] =~ s/\"$//s; |
1202 | } |
1203 | |
1204 | # Turn L<Foo Bar> into L</Foo Bar>. |
1205 | if(!$section_name and !$link_text and @ell_content |
1206 | and grep !ref($_) && m/ /s, @ell_content |
1207 | ) { |
1208 | $section_name = [splice @ell_content]; |
1209 | # That's support for the now-deprecated syntax. |
1210 | # (Maybe generate a warning eventually?) |
1211 | # Note that it deliberately won't work on L<...|Foo Bar> |
1212 | } |
1213 | |
1214 | |
1215 | # Now make up the link_text |
1216 | # L<Foo> -> L<Foo|Foo> |
1217 | # L</Bar> -> L<"Bar"|Bar> |
1218 | # L<Foo/Bar> -> L<"Bar" in Foo/Foo> |
1219 | unless($link_text) { |
1220 | $ell->[1]{'content-implicit'} = 'yes'; |
1221 | $link_text = []; |
1222 | push @$link_text, '"', @$section_name, '"' if $section_name; |
1223 | |
1224 | if(@ell_content) { |
1225 | $link_text->[-1] .= ' in ' if $section_name; |
1226 | push @$link_text, @ell_content; |
1227 | } |
1228 | } |
1229 | |
1230 | |
1231 | # And the E resolver will have to deal with all our treeletty things: |
1232 | |
1233 | if(@ell_content == 1 and !ref($ell_content[0]) |
1234 | and $ell_content[0] =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s |
1235 | ) { |
1236 | $ell->[1]{'type'} = 'man'; |
1237 | DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n"; |
1238 | } else { |
1239 | $ell->[1]{'type'} = 'pod'; |
1240 | DEBUG > 3 and print "Considering this a pod link (not man or url).\n"; |
1241 | } |
1242 | |
1243 | if( defined $section_name ) { |
1244 | $ell->[1]{'section'} = Pod::Simple::LinkSection->new( |
1245 | ['', {}, @$section_name] |
1246 | ); |
1247 | DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n"; |
1248 | } |
1249 | |
1250 | if( @ell_content ) { |
1251 | $ell->[1]{'to'} = Pod::Simple::LinkSection->new( |
1252 | ['', {}, @ell_content] |
1253 | ); |
1254 | DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n"; |
1255 | } |
1256 | |
1257 | # And update children to be the link-text: |
1258 | @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : ''); |
1259 | |
1260 | DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n"; |
1261 | |
1262 | unshift @stack, $treelet->[$i]; # might as well recurse |
1263 | } |
1264 | } |
1265 | |
1266 | return; |
1267 | } |
1268 | |
1269 | # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . |
1270 | |
1271 | sub _treat_Es { |
1272 | my($self,@stack) = @_; |
1273 | |
1274 | my($i, $treelet, $content, $replacer, $charnum); |
1275 | my $start_line = $stack[0][1]{'start_line'}; |
1276 | |
1277 | # A recursive algorithm implemented iteratively! Whee! |
1278 | |
1279 | |
1280 | # Has frightening side effects on L nodes' attributes. |
1281 | |
1282 | #my @ells_to_tweak; |
1283 | |
1284 | while($treelet = shift @stack) { |
1285 | for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children |
1286 | next unless ref $treelet->[$i]; # text nodes are uninteresting |
1287 | if($treelet->[$i][0] eq 'L') { |
1288 | # SPECIAL STUFF for semi-processed L<>'s |
1289 | |
1290 | my $thing; |
1291 | foreach my $attrname ('section', 'to') { |
1292 | if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) { |
1293 | unshift @stack, $thing; |
1294 | DEBUG > 2 and print " Enqueuing ", |
1295 | pretty( $treelet->[$i][1]{$attrname} ), |
1296 | " as an attribute value to tweak.\n"; |
1297 | } |
1298 | } |
1299 | |
1300 | unshift @stack, $treelet->[$i]; # recurse |
1301 | next; |
1302 | } elsif($treelet->[$i][0] ne 'E') { |
1303 | unshift @stack, $treelet->[$i]; # recurse |
1304 | next; |
1305 | } |
1306 | |
1307 | DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n"; |
1308 | |
1309 | # bitch if it's empty |
1310 | if( @{$treelet->[$i]} == 2 |
1311 | or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '') |
1312 | ) { |
1313 | $self->whine( $start_line, "An empty E<>" ); |
1314 | $treelet->[$i] = 'E<>'; # splice in a literal |
1315 | next; |
1316 | } |
1317 | |
1318 | # bitch if content is weird |
1319 | unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) { |
1320 | $self->whine( $start_line, "An E<...> surrounding strange content" ); |
1321 | $replacer = $treelet->[$i]; # scratch |
1322 | splice(@$treelet, $i, 1, # fake out a literal |
1323 | 'E<', |
1324 | splice(@$replacer,2), # promote its content |
1325 | '>' |
1326 | ); |
1327 | # Don't need to do --$i, as the 'E<' we just added isn't interesting. |
1328 | next; |
1329 | } |
1330 | |
1331 | DEBUG > 1 and print "Ogling E<$content>\n"; |
1332 | |
1333 | $charnum = Pod::Escapes::e2charnum($content); |
1334 | DEBUG > 1 and print " Considering E<$content> with char ", |
1335 | defined($charnum) ? $charnum : "undef", ".\n"; |
1336 | |
1337 | if(!defined( $charnum )) { |
1338 | DEBUG > 1 and print "I don't know how to deal with E<$content>.\n"; |
1339 | $self->whine( $start_line, "Unknown E content in E<$content>" ); |
1340 | $replacer = "E<$content>"; # better than nothing |
1341 | } elsif($charnum >= 255 and !UNICODE) { |
1342 | $replacer = ASCII ? "\xA4" : "?"; |
1343 | DEBUG > 1 and print "This Perl version can't handle ", |
1344 | "E<$content> (chr $charnum), so replacing with $replacer\n"; |
1345 | } else { |
1346 | $replacer = Pod::Escapes::e2char($content); |
1347 | DEBUG > 1 and print " Replacing E<$content> with $replacer\n"; |
1348 | } |
1349 | |
1350 | splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho |
1351 | } |
1352 | } |
1353 | |
1354 | return; |
1355 | } |
1356 | |
1357 | |
1358 | # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . |
1359 | |
1360 | sub _treat_Ss { |
1361 | my($self,$treelet) = @_; |
1362 | |
1363 | _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'}; |
1364 | |
1365 | # TODO: or a change_nbsp_to_S |
1366 | # Normalizing nbsp's to S is harder: for each text node, make S content |
1367 | # out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/ |
1368 | |
1369 | |
1370 | return; |
1371 | } |
1372 | |
1373 | |
1374 | sub _change_S_to_nbsp { # a recursive function |
1375 | # Sanely assumes that the top node in the excursion won't be an S node. |
1376 | my($treelet, $in_s) = @_; |
1377 | |
1378 | my $is_s = ('S' eq $treelet->[0]); |
1379 | $in_s ||= $is_s; # So in_s is on either by this being an S element, |
1380 | # or by an ancestor being an S element. |
1381 | |
1382 | for(my $i = 2; $i < @$treelet; ++$i) { |
1383 | if(ref $treelet->[$i]) { |
1384 | if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) { |
1385 | my $to_pull_up = $treelet->[$i]; |
1386 | splice @$to_pull_up,0,2; # ...leaving just its content |
1387 | splice @$treelet, $i, 1, @$to_pull_up; # Pull up content |
1388 | $i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff |
1389 | } |
1390 | } else { |
1391 | $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s; |
1392 | # (If not in ASCIIland, we can't assume that \xA0 == nbsp.) |
1393 | |
1394 | # Note that if you apply nbsp_for_S to text, and so turn |
1395 | # "foo S<bar baz> quux" into "foo bar faz quux", you |
1396 | # end up with something that fails to say "and don't hyphenate |
1397 | # any part of 'bar baz'". However, hyphenation is such a vexing |
1398 | # problem anyway, that most Pod renderers just don't render it |
1399 | # at all. But if you do want to implement hyphenation, I guess |
1400 | # that you'd better have nbsp_for_S off. |
1401 | } |
1402 | } |
1403 | |
1404 | return $is_s; |
1405 | } |
1406 | |
1407 | #----------------------------------------------------------------------------- |
1408 | |
1409 | sub _accessorize { # A simple-minded method-maker |
1410 | no strict 'refs'; |
1411 | foreach my $attrname (@_) { |
1412 | next if $attrname =~ m/::/; # a hack |
1413 | *{caller() . '::' . $attrname} = sub { |
1414 | use strict; |
1415 | $Carp::CarpLevel = 1, Carp::croak( |
1416 | "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)" |
1417 | ) unless (@_ == 1 or @_ == 2) and ref $_[0]; |
1418 | (@_ == 1) ? $_[0]->{$attrname} |
1419 | : ($_[0]->{$attrname} = $_[1]); |
1420 | }; |
1421 | } |
1422 | # Ya know, they say accessories make the ensemble! |
1423 | return; |
1424 | } |
1425 | |
1426 | # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . |
1427 | # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . |
1428 | #============================================================================= |
1429 | |
1430 | sub filter { |
1431 | my($class, $source) = @_; |
1432 | my $new = $class->new; |
1433 | $new->output_fh(*STDOUT{IO}); |
1434 | |
1435 | if(ref($source || '') eq 'SCALAR') { |
1436 | $new->parse_string_document( $$source ); |
1437 | } elsif(ref($source)) { # it's a file handle |
1438 | $new->parse_file($source); |
1439 | } else { # it's a filename |
1440 | $new->parse_file($source); |
1441 | } |
1442 | |
1443 | return $new; |
1444 | } |
1445 | |
1446 | |
1447 | #----------------------------------------------------------------------------- |
1448 | |
1449 | sub _out { |
1450 | # For use in testing: Class->_out($source) |
1451 | # returns the transformation of $source |
1452 | |
1453 | my $class = shift(@_); |
1454 | |
1455 | my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE'; |
1456 | |
1457 | DEBUG and print "\n\n", '#' x 76, |
1458 | "\nAbout to parse source: {{\n$_[0]\n}}\n\n"; |
1459 | |
1460 | |
69473a20 |
1461 | my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new; |
351625bd |
1462 | $parser->hide_line_numbers(1); |
1463 | |
1464 | my $out = ''; |
1465 | $parser->output_string( \$out ); |
1466 | DEBUG and print " _out to ", \$out, "\n"; |
1467 | |
1468 | $mutor->($parser) if $mutor; |
1469 | |
1470 | $parser->parse_string_document( $_[0] ); |
1471 | # use Data::Dumper; print Dumper($parser), "\n"; |
1472 | return $out; |
1473 | } |
1474 | |
1475 | |
1476 | sub _duo { |
1477 | # For use in testing: Class->_duo($source1, $source2) |
1478 | # returns the parse trees of $source1 and $source2. |
1479 | # Good in things like: &ok( Class->duo(... , ...) ); |
1480 | |
1481 | my $class = shift(@_); |
1482 | |
1483 | Carp::croak "But $class->_duo is useful only in list context!" |
1484 | unless wantarray; |
1485 | |
1486 | my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE'; |
1487 | |
1488 | Carp::croak "But $class->_duo takes two parameters, not: @_" |
1489 | unless @_ == 2; |
1490 | |
1491 | my(@out); |
1492 | |
1493 | while( @_ ) { |
1494 | my $parser = $class->new; |
1495 | |
1496 | push @out, ''; |
1497 | $parser->output_string( \( $out[-1] ) ); |
1498 | |
1499 | DEBUG and print " _duo out to ", $parser->output_string(), |
1500 | " = $parser->{'output_string'}\n"; |
1501 | |
1502 | $parser->hide_line_numbers(1); |
1503 | $mutor->($parser) if $mutor; |
1504 | $parser->parse_string_document( shift( @_ ) ); |
1505 | # use Data::Dumper; print Dumper($parser), "\n"; |
1506 | } |
1507 | |
1508 | return @out; |
1509 | } |
1510 | |
1511 | |
1512 | |
1513 | #----------------------------------------------------------------------------- |
1514 | 1; |
1515 | __END__ |
1516 | |
1517 | TODO: |
1518 | A start_formatting_code and end_formatting_code methods, which in the |
1519 | base class call start_L, end_L, start_C, end_C, etc., if they are |
1520 | defined. |
1521 | |
1522 | have the POD FORMATTING ERRORS section note the localtime, and the |
1523 | version of Pod::Simple. |
1524 | |
1525 | option to delete all E<shy>s? |
1526 | option to scream if under-0x20 literals are found in the input, or |
1527 | under-E<32> E codes are found in the tree. And ditto \x7f-\x9f |
1528 | |
1529 | Option to turn highbit characters into their compromised form? (applies |
1530 | to E parsing too) |
1531 | |
1532 | TODO: BOM/encoding things. |
1533 | |
1534 | TODO: ascii-compat things in the XML classes? |
1535 | |