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