| [ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 2 package Pod::Simple::BlackBox; 3 # 4 # "What's in the box?" "Pain." 5 # 6 ########################################################################### 7 # 8 # This is where all the scary things happen: parsing lines into 9 # paragraphs; and then into directives, verbatims, and then also 10 # turning formatting sequences into treelets. 11 # 12 # Are you really sure you want to read this code? 13 # 14 #----------------------------------------------------------------------------- 15 # 16 # The basic work of this module Pod::Simple::BlackBox is doing the dirty work 17 # of parsing Pod into treelets (generally one per non-verbatim paragraph), and 18 # to call the proper callbacks on the treelets. 19 # 20 # Every node in a treelet is a ['name', {attrhash}, ...children...] 21 22 use integer; # vroom! 23 use strict; 24 use Carp (); 25 BEGIN { 26 require Pod::Simple; 27 *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG 28 } 29 30 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 31 32 sub parse_line { shift->parse_lines(@_) } # alias 33 34 # - - - Turn back now! Run away! - - - 35 36 sub parse_lines { # Usage: $parser->parse_lines(@lines) 37 # an undef means end-of-stream 38 my $self = shift; 39 40 my $code_handler = $self->{'code_handler'}; 41 my $cut_handler = $self->{'cut_handler'}; 42 $self->{'line_count'} ||= 0; 43 44 my $scratch; 45 46 DEBUG > 4 and 47 print "# Parsing starting at line ", $self->{'line_count'}, ".\n"; 48 49 DEBUG > 5 and 50 print "# About to parse lines: ", 51 join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n"; 52 53 my $paras = ($self->{'paras'} ||= []); 54 # paragraph buffer. Because we need to defer processing of =over 55 # directives and verbatim paragraphs. We call _ponder_paragraph_buffer 56 # to process this. 57 58 $self->{'pod_para_count'} ||= 0; 59 60 my $line; 61 foreach my $source_line (@_) { 62 if( $self->{'source_dead'} ) { 63 DEBUG > 4 and print "# Source is dead.\n"; 64 last; 65 } 66 67 unless( defined $source_line ) { 68 DEBUG > 4 and print "# Undef-line seen.\n"; 69 70 push @$paras, ['~end', {'start_line' => $self->{'line_count'}}]; 71 push @$paras, $paras->[-1], $paras->[-1]; 72 # So that it definitely fills the buffer. 73 $self->{'source_dead'} = 1; 74 $self->_ponder_paragraph_buffer; 75 next; 76 } 77 78 79 if( $self->{'line_count'}++ ) { 80 ($line = $source_line) =~ tr/\n\r//d; 81 # If we don't have two vars, we'll end up with that there 82 # tr/// modding the (potentially read-only) original source line! 83 84 } else { 85 DEBUG > 2 and print "First line: [$source_line]\n"; 86 87 if( ($line = $source_line) =~ s/^\xEF\xBB\xBF//s ) { 88 DEBUG and print "UTF-8 BOM seen. Faking a '=encode utf8'.\n"; 89 $self->_handle_encoding_line( "=encode utf8" ); 90 $line =~ tr/\n\r//d; 91 92 } elsif( $line =~ s/^\xFE\xFF//s ) { 93 DEBUG and print "Big-endian UTF-16 BOM seen. Aborting parsing.\n"; 94 $self->scream( 95 $self->{'line_count'}, 96 "UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet." 97 ); 98 splice @_; 99 push @_, undef; 100 next; 101 102 # TODO: implement somehow? 103 104 } elsif( $line =~ s/^\xFF\xFE//s ) { 105 DEBUG and print "Little-endian UTF-16 BOM seen. Aborting parsing.\n"; 106 $self->scream( 107 $self->{'line_count'}, 108 "UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet." 109 ); 110 splice @_; 111 push @_, undef; 112 next; 113 114 # TODO: implement somehow? 115 116 } else { 117 DEBUG > 2 and print "First line is BOM-less.\n"; 118 ($line = $source_line) =~ tr/\n\r//d; 119 } 120 } 121 122 123 DEBUG > 5 and print "# Parsing line: [$line]\n"; 124 125 if(!$self->{'in_pod'}) { 126 if($line =~ m/^=([a-zA-Z]+)/s) { 127 if($1 eq 'cut') { 128 $self->scream( 129 $self->{'line_count'}, 130 "=cut found outside a pod block. Skipping to next block." 131 ); 132 133 ## Before there were errata sections in the world, it was 134 ## least-pessimal to abort processing the file. But now we can 135 ## just barrel on thru (but still not start a pod block). 136 #splice @_; 137 #push @_, undef; 138 139 next; 140 } else { 141 $self->{'in_pod'} = $self->{'start_of_pod_block'} 142 = $self->{'last_was_blank'} = 1; 143 # And fall thru to the pod-mode block further down 144 } 145 } else { 146 DEBUG > 5 and print "# It's a code-line.\n"; 147 $code_handler->(map $_, $line, $self->{'line_count'}, $self) 148 if $code_handler; 149 # Note: this may cause code to be processed out of order relative 150 # to pods, but in order relative to cuts. 151 152 # Note also that we haven't yet applied the transcoding to $line 153 # by time we call $code_handler! 154 155 if( $line =~ m/^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/ ) { 156 # That RE is from perlsyn, section "Plain Old Comments (Not!)", 157 #$fname = $2 if defined $2; 158 #DEBUG > 1 and defined $2 and print "# Setting fname to \"$fname\"\n"; 159 DEBUG > 1 and print "# Setting nextline to $1\n"; 160 $self->{'line_count'} = $1 - 1; 161 } 162 163 next; 164 } 165 } 166 167 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . 168 # Else we're in pod mode: 169 170 # Apply any necessary transcoding: 171 $self->{'_transcoder'} && $self->{'_transcoder'}->($line); 172 173 # HERE WE CATCH =encoding EARLY! 174 if( $line =~ m/^=encoding\s+\S+\s*$/s ) { 175 $line = $self->_handle_encoding_line( $line ); 176 } 177 178 if($line =~ m/^=cut/s) { 179 # here ends the pod block, and therefore the previous pod para 180 DEBUG > 1 and print "Noting =cut at line ${$self}{'line_count'}\n"; 181 $self->{'in_pod'} = 0; 182 # ++$self->{'pod_para_count'}; 183 $self->_ponder_paragraph_buffer(); 184 # by now it's safe to consider the previous paragraph as done. 185 $cut_handler->(map $_, $line, $self->{'line_count'}, $self) 186 if $cut_handler; 187 188 # TODO: add to docs: Note: this may cause cuts to be processed out 189 # of order relative to pods, but in order relative to code. 190 191 } elsif($line =~ m/^\s*$/s) { # it's a blank line 192 if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { 193 DEBUG > 1 and print "Saving blank line at line ${$self}{'line_count'}\n"; 194 push @{$paras->[-1]}, $line; 195 } # otherwise it's not interesting 196 197 if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) { 198 DEBUG > 1 and print "Noting para ends with blank line at ${$self}{'line_count'}\n"; 199 } 200 201 $self->{'last_was_blank'} = 1; 202 203 } elsif($self->{'last_was_blank'}) { # A non-blank line starting a new para... 204 205 if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) { 206 # THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS 207 my $new = [$1, {'start_line' => $self->{'line_count'}}, $2]; 208 # Note that in "=head1 foo", the WS is lost. 209 # Example: ['=head1', {'start_line' => 123}, ' foo'] 210 211 ++$self->{'pod_para_count'}; 212 213 $self->_ponder_paragraph_buffer(); 214 # by now it's safe to consider the previous paragraph as done. 215 216 push @$paras, $new; # the new incipient paragraph 217 DEBUG > 1 and print "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n"; 218 219 } elsif($line =~ m/^\s/s) { 220 221 if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { 222 DEBUG > 1 and print "Resuming verbatim para at line ${$self}{'line_count'}\n"; 223 push @{$paras->[-1]}, $line; 224 } else { 225 ++$self->{'pod_para_count'}; 226 $self->_ponder_paragraph_buffer(); 227 # by now it's safe to consider the previous paragraph as done. 228 DEBUG > 1 and print "Starting verbatim para at line ${$self}{'line_count'}\n"; 229 push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line]; 230 } 231 } else { 232 ++$self->{'pod_para_count'}; 233 $self->_ponder_paragraph_buffer(); 234 # by now it's safe to consider the previous paragraph as done. 235 push @$paras, ['~Para', {'start_line' => $self->{'line_count'}}, $line]; 236 DEBUG > 1 and print "Starting plain para at line ${$self}{'line_count'}\n"; 237 } 238 $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; 239 240 } else { 241 # It's a non-blank line /continuing/ the current para 242 if(@$paras) { 243 DEBUG > 2 and print "Line ${$self}{'line_count'} continues current paragraph\n"; 244 push @{$paras->[-1]}, $line; 245 } else { 246 # Unexpected case! 247 die "Continuing a paragraph but \@\$paras is empty?"; 248 } 249 $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; 250 } 251 252 } # ends the big while loop 253 254 DEBUG > 1 and print(pretty(@$paras), "\n"); 255 return $self; 256 } 257 258 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 259 260 sub _handle_encoding_line { 261 my($self, $line) = @_; 262 263 # The point of this routine is to set $self->{'_transcoder'} as indicated. 264 265 return $line unless $line =~ m/^=encoding\s+(\S+)\s*$/s; 266 DEBUG > 1 and print "Found an encoding line \"=encoding $1\"\n"; 267 268 my $e = $1; 269 my $orig = $e; 270 push @{ $self->{'encoding_command_reqs'} }, "=encoding $orig"; 271 272 my $enc_error; 273 274 # Cf. perldoc Encode and perldoc Encode::Supported 275 276 require Pod::Simple::Transcode; 277 278 if( $self->{'encoding'} ) { 279 my $norm_current = $self->{'encoding'}; 280 my $norm_e = $e; 281 foreach my $that ($norm_current, $norm_e) { 282 $that = lc($that); 283 $that =~ s/[-_]//g; 284 } 285 if($norm_current eq $norm_e) { 286 DEBUG > 1 and print "The '=encoding $orig' line is ", 287 "redundant. ($norm_current eq $norm_e). Ignoring.\n"; 288 $enc_error = ''; 289 # But that doesn't necessarily mean that the earlier one went okay 290 } else { 291 $enc_error = "Encoding is already set to " . $self->{'encoding'}; 292 DEBUG > 1 and print $enc_error; 293 } 294 } elsif ( 295 # OK, let's turn on the encoding 296 do { 297 DEBUG > 1 and print " Setting encoding to $e\n"; 298 $self->{'encoding'} = $e; 299 1; 300 } 301 and $e eq 'HACKRAW' 302 ) { 303 DEBUG and print " Putting in HACKRAW (no-op) encoding mode.\n"; 304 305 } elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) { 306 307 die($enc_error = "WHAT? _transcoder is already set?!") 308 if $self->{'_transcoder'}; # should never happen 309 require Pod::Simple::Transcode; 310 $self->{'_transcoder'} = Pod::Simple::Transcode::->make_transcoder($e); 311 eval { 312 my @x = ('', "abc", "123"); 313 $self->{'_transcoder'}->(@x); 314 }; 315 $@ && die( $enc_error = 316 "Really unexpected error setting up encoding $e: $@\nAborting" 317 ); 318 319 } else { 320 my @supported = Pod::Simple::Transcode::->all_encodings; 321 322 # Note unsupported, and complain 323 DEBUG and print " Encoding [$e] is unsupported.", 324 "\nSupporteds: @supported\n"; 325 my $suggestion = ''; 326 327 # Look for a near match: 328 my $norm = lc($e); 329 $norm =~ tr[-_][]d; 330 my $n; 331 foreach my $enc (@supported) { 332 $n = lc($enc); 333 $n =~ tr[-_][]d; 334 next unless $n eq $norm; 335 $suggestion = " (Maybe \"$e\" should be \"$enc\"?)"; 336 last; 337 } 338 my $encmodver = Pod::Simple::Transcode::->encmodver; 339 $enc_error = join '' => 340 "This document probably does not appear as it should, because its ", 341 "\"=encoding $e\" line calls for an unsupported encoding.", 342 $suggestion, " [$encmodver\'s supported encodings are: @supported]" 343 ; 344 345 $self->scream( $self->{'line_count'}, $enc_error ); 346 } 347 push @{ $self->{'encoding_command_statuses'} }, $enc_error; 348 349 return '=encoding ALREADYDONE'; 350 } 351 352 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 353 354 sub _handle_encoding_second_level { 355 # By time this is called, the encoding (if well formed) will already 356 # have been acted one. 357 my($self, $para) = @_; 358 my @x = @$para; 359 my $content = join ' ', splice @x, 2; 360 $content =~ s/^\s+//s; 361 $content =~ s/\s+$//s; 362 363 DEBUG > 2 and print "Ogling encoding directive: =encoding $content\n"; 364 365 if($content eq 'ALREADYDONE') { 366 # It's already been handled. Check for errors. 367 if(! $self->{'encoding_command_statuses'} ) { 368 DEBUG > 2 and print " CRAZY ERROR: It wasn't really handled?!\n"; 369 } elsif( $self->{'encoding_command_statuses'}[-1] ) { 370 $self->whine( $para->[1]{'start_line'}, 371 sprintf "Couldn't do %s: %s", 372 $self->{'encoding_command_reqs' }[-1], 373 $self->{'encoding_command_statuses'}[-1], 374 ); 375 } else { 376 DEBUG > 2 and print " (Yup, it was successfully handled already.)\n"; 377 } 378 379 } else { 380 # Otherwise it's a syntax error 381 $self->whine( $para->[1]{'start_line'}, 382 "Invalid =encoding syntax: $content" 383 ); 384 } 385 386 return; 387 } 388 389 #~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~` 390 391 { 392 my $m = -321; # magic line number 393 394 sub _gen_errata { 395 my $self = $_[0]; 396 # Return 0 or more fake-o paragraphs explaining the accumulated 397 # errors on this document. 398 399 return() unless $self->{'errata'} and keys %{$self->{'errata'}}; 400 401 my @out; 402 403 foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) { 404 push @out, 405 ['=item', {'start_line' => $m}, "Around line $line:"], 406 map( ['~Para', {'start_line' => $m, '~cooked' => 1}, 407 #['~Top', {'start_line' => $m}, 408 $_ 409 #] 410 ], 411 @{$self->{'errata'}{$line}} 412 ) 413 ; 414 } 415 416 # TODO: report of unknown entities? unrenderable characters? 417 418 unshift @out, 419 ['=head1', {'start_line' => $m, 'errata' => 1}, 'POD ERRORS'], 420 ['~Para', {'start_line' => $m, '~cooked' => 1, 'errata' => 1}, 421 "Hey! ", 422 ['B', {}, 423 'The above document had some coding errors, which are explained below:' 424 ] 425 ], 426 ['=over', {'start_line' => $m, 'errata' => 1}, ''], 427 ; 428 429 push @out, 430 ['=back', {'start_line' => $m, 'errata' => 1}, ''], 431 ; 432 433 DEBUG and print "\n<<\n", pretty(\@out), "\n>>\n\n"; 434 435 return @out; 436 } 437 438 } 439 440 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 441 442 ############################################################################## 443 ## 444 ## stop reading now stop reading now stop reading now stop reading now stop 445 ## 446 ## HERE IT BECOMES REALLY SCARY 447 ## 448 ## stop reading now stop reading now stop reading now stop reading now stop 449 ## 450 ############################################################################## 451 452 sub _ponder_paragraph_buffer { 453 454 # Para-token types as found in the buffer. 455 # ~Verbatim, ~Para, ~end, =head1..4, =for, =begin, =end, 456 # =over, =back, =item 457 # and the null =pod (to be complained about if over one line) 458 # 459 # "~data" paragraphs are something we generate at this level, depending on 460 # a currently open =over region 461 462 # Events fired: Begin and end for: 463 # directivename (like head1 .. head4), item, extend, 464 # for (from =begin...=end, =for), 465 # over-bullet, over-number, over-text, over-block, 466 # item-bullet, item-number, item-text, 467 # Document, 468 # Data, Para, Verbatim 469 # B, C, longdirname (TODO -- wha?), etc. for all directives 470 # 471 472 my $self = $_[0]; 473 my $paras; 474 return unless @{$paras = $self->{'paras'}}; 475 my $curr_open = ($self->{'curr_open'} ||= []); 476 477 my $scratch; 478 479 DEBUG > 10 and print "# Paragraph buffer: <<", pretty($paras), ">>\n"; 480 481 # We have something in our buffer. So apparently the document has started. 482 unless($self->{'doc_has_started'}) { 483 $self->{'doc_has_started'} = 1; 484 485 my $starting_contentless; 486 $starting_contentless = 487 ( 488 !@$curr_open 489 and @$paras and ! grep $_->[0] ne '~end', @$paras 490 # i.e., if the paras is all ~ends 491 ) 492 ; 493 DEBUG and print "# Starting ", 494 $starting_contentless ? 'contentless' : 'contentful', 495 " document\n" 496 ; 497 498 $self->_handle_element_start( 499 ($scratch = 'Document'), 500 { 501 'start_line' => $paras->[0][1]{'start_line'}, 502 $starting_contentless ? ( 'contentless' => 1 ) : (), 503 }, 504 ); 505 } 506 507 my($para, $para_type); 508 while(@$paras) { 509 last if @$paras == 1 and 510 ( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim' 511 or $paras->[0][0] eq '=item' ) 512 ; 513 # Those're the three kinds of paragraphs that require lookahead. 514 # Actually, an "=item Foo" inside an <over type=text> region 515 # and any =item inside an <over type=block> region (rare) 516 # don't require any lookahead, but all others (bullets 517 # and numbers) do. 518 519 # TODO: winge about many kinds of directives in non-resolving =for regions? 520 # TODO: many? like what? =head1 etc? 521 522 $para = shift @$paras; 523 $para_type = $para->[0]; 524 525 DEBUG > 1 and print "Pondering a $para_type paragraph, given the stack: (", 526 $self->_dump_curr_open(), ")\n"; 527 528 if($para_type eq '=for') { 529 next if $self->_ponder_for($para,$curr_open,$paras); 530 531 } elsif($para_type eq '=begin') { 532 next if $self->_ponder_begin($para,$curr_open,$paras); 533 534 } elsif($para_type eq '=end') { 535 next if $self->_ponder_end($para,$curr_open,$paras); 536 537 } elsif($para_type eq '~end') { # The virtual end-document signal 538 next if $self->_ponder_doc_end($para,$curr_open,$paras); 539 } 540 541 542 # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ 543 #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ 544 if(grep $_->[1]{'~ignore'}, @$curr_open) { 545 DEBUG > 1 and 546 print "Skipping $para_type paragraph because in ignore mode.\n"; 547 next; 548 } 549 #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ 550 # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ 551 552 if($para_type eq '=pod') { 553 $self->_ponder_pod($para,$curr_open,$paras); 554 555 } elsif($para_type eq '=over') { 556 next if $self->_ponder_over($para,$curr_open,$paras); 557 558 } elsif($para_type eq '=back') { 559 next if $self->_ponder_back($para,$curr_open,$paras); 560 561 } else { 562 563 # All non-magical codes!!! 564 565 # Here we start using $para_type for our own twisted purposes, to 566 # mean how it should get treated, not as what the element name 567 # should be. 568 569 DEBUG > 1 and print "Pondering non-magical $para_type\n"; 570 571 my $i; 572 573 # Enforce some =headN discipline 574 if($para_type =~ m/^=head\d$/s 575 and ! $self->{'accept_heads_anywhere'} 576 and @$curr_open 577 and $curr_open->[-1][0] eq '=over' 578 ) { 579 DEBUG > 2 and print "'=$para_type' inside an '=over'!\n"; 580 $self->whine( 581 $para->[1]{'start_line'}, 582 "You forgot a '=back' before '$para_type'" 583 ); 584 unshift @$paras, ['=back', {}, ''], $para; # close the =over 585 next; 586 } 587 588 589 if($para_type eq '=item') { 590 591 my $over; 592 unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') { 593 $self->whine( 594 $para->[1]{'start_line'}, 595 "'=item' outside of any '=over'" 596 ); 597 unshift @$paras, 598 ['=over', {'start_line' => $para->[1]{'start_line'}}, ''], 599 $para 600 ; 601 next; 602 } 603 604 605 my $over_type = $over->[1]{'~type'}; 606 607 if(!$over_type) { 608 # Shouldn't happen1 609 die "Typeless over in stack, starting at line " 610 . $over->[1]{'start_line'}; 611 612 } elsif($over_type eq 'block') { 613 unless($curr_open->[-1][1]{'~bitched_about'}) { 614 $curr_open->[-1][1]{'~bitched_about'} = 1; 615 $self->whine( 616 $curr_open->[-1][1]{'start_line'}, 617 "You can't have =items (as at line " 618 . $para->[1]{'start_line'} 619 . ") unless the first thing after the =over is an =item" 620 ); 621 } 622 # Just turn it into a paragraph and reconsider it 623 $para->[0] = '~Para'; 624 unshift @$paras, $para; 625 next; 626 627 } elsif($over_type eq 'text') { 628 my $item_type = $self->_get_item_type($para); 629 # That kills the content of the item if it's a number or bullet. 630 DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 631 632 if($item_type eq 'text') { 633 # Nothing special needs doing for 'text' 634 } elsif($item_type eq 'number' or $item_type eq 'bullet') { 635 die "Unknown item type $item_type" 636 unless $item_type eq 'number' or $item_type eq 'bullet'; 637 # Undo our clobbering: 638 push @$para, $para->[1]{'~orig_content'}; 639 delete $para->[1]{'number'}; 640 # Only a PROPER item-number element is allowed 641 # to have a number attribute. 642 } else { 643 die "Unhandled item type $item_type"; # should never happen 644 } 645 646 # =item-text thingies don't need any assimilation, it seems. 647 648 } elsif($over_type eq 'number') { 649 my $item_type = $self->_get_item_type($para); 650 # That kills the content of the item if it's a number or bullet. 651 DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 652 653 my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; 654 655 if($item_type eq 'bullet') { 656 # Hm, it's not numeric. Correct for this. 657 $para->[1]{'number'} = $expected_value; 658 $self->whine( 659 $para->[1]{'start_line'}, 660 "Expected '=item $expected_value'" 661 ); 662 push @$para, $para->[1]{'~orig_content'}; 663 # restore the bullet, blocking the assimilation of next para 664 665 } elsif($item_type eq 'text') { 666 # Hm, it's not numeric. Correct for this. 667 $para->[1]{'number'} = $expected_value; 668 $self->whine( 669 $para->[1]{'start_line'}, 670 "Expected '=item $expected_value'" 671 ); 672 # Text content will still be there and will block next ~Para 673 674 } elsif($item_type ne 'number') { 675 die "Unknown item type $item_type"; # should never happen 676 677 } elsif($expected_value == $para->[1]{'number'}) { 678 DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n"; 679 680 } else { 681 DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'}, 682 " instead of the expected value of $expected_value\n"; 683 $self->whine( 684 $para->[1]{'start_line'}, 685 "You have '=item " . $para->[1]{'number'} . 686 "' instead of the expected '=item $expected_value'" 687 ); 688 $para->[1]{'number'} = $expected_value; # correcting!! 689 } 690 691 if(@$para == 2) { 692 # For the cases where we /didn't/ push to @$para 693 if($paras->[0][0] eq '~Para') { 694 DEBUG and print "Assimilating following ~Para content into $over_type item\n"; 695 push @$para, splice @{shift @$paras},2; 696 } else { 697 DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; 698 push @$para, ''; # Just so it's not contentless 699 } 700 } 701 702 703 } elsif($over_type eq 'bullet') { 704 my $item_type = $self->_get_item_type($para); 705 # That kills the content of the item if it's a number or bullet. 706 DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 707 708 if($item_type eq 'bullet') { 709 # as expected! 710 711 if( $para->[1]{'~_freaky_para_hack'} ) { 712 DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n"; 713 push @$para, delete $para->[1]{'~_freaky_para_hack'}; 714 } 715 716 } elsif($item_type eq 'number') { 717 $self->whine( 718 $para->[1]{'start_line'}, 719 "Expected '=item *'" 720 ); 721 push @$para, $para->[1]{'~orig_content'}; 722 # and block assimilation of the next paragraph 723 delete $para->[1]{'number'}; 724 # Only a PROPER item-number element is allowed 725 # to have a number attribute. 726 } elsif($item_type eq 'text') { 727 $self->whine( 728 $para->[1]{'start_line'}, 729 "Expected '=item *'" 730 ); 731 # But doesn't need processing. But it'll block assimilation 732 # of the next para. 733 } else { 734 die "Unhandled item type $item_type"; # should never happen 735 } 736 737 if(@$para == 2) { 738 # For the cases where we /didn't/ push to @$para 739 if($paras->[0][0] eq '~Para') { 740 DEBUG and print "Assimilating following ~Para content into $over_type item\n"; 741 push @$para, splice @{shift @$paras},2; 742 } else { 743 DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; 744 push @$para, ''; # Just so it's not contentless 745 } 746 } 747 748 } else { 749 die "Unhandled =over type \"$over_type\"?"; 750 # Shouldn't happen! 751 } 752 753 $para_type = 'Plain'; 754 $para->[0] .= '-' . $over_type; 755 # Whew. Now fall thru and process it. 756 757 758 } elsif($para_type eq '=extend') { 759 # Well, might as well implement it here. 760 $self->_ponder_extend($para); 761 next; # and skip 762 } elsif($para_type eq '=encoding') { 763 # Not actually acted on here, but we catch errors here. 764 $self->_handle_encoding_second_level($para); 765 766 next; # and skip 767 } elsif($para_type eq '~Verbatim') { 768 $para->[0] = 'Verbatim'; 769 $para_type = '?Verbatim'; 770 } elsif($para_type eq '~Para') { 771 $para->[0] = 'Para'; 772 $para_type = '?Plain'; 773 } elsif($para_type eq 'Data') { 774 $para->[0] = 'Data'; 775 $para_type = '?Data'; 776 } elsif( $para_type =~ s/^=//s 777 and defined( $para_type = $self->{'accept_directives'}{$para_type} ) 778 ) { 779 DEBUG > 1 and print " Pondering known directive ${$para}[0] as $para_type\n"; 780 } else { 781 # An unknown directive! 782 DEBUG > 1 and printf "Unhandled directive %s (Handled: %s)\n", 783 $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} ) 784 ; 785 $self->whine( 786 $para->[1]{'start_line'}, 787 "Unknown directive: $para->[0]" 788 ); 789 790 # And maybe treat it as text instead of just letting it go? 791 next; 792 } 793 794 if($para_type =~ s/^\?//s) { 795 if(! @$curr_open) { # usual case 796 DEBUG and print "Treating $para_type paragraph as such because stack is empty.\n"; 797 } else { 798 my @fors = grep $_->[0] eq '=for', @$curr_open; 799 DEBUG > 1 and print "Containing fors: ", 800 join(',', map $_->[1]{'target'}, @fors), "\n"; 801 802 if(! @fors) { 803 DEBUG and print "Treating $para_type paragraph as such because stack has no =for's\n"; 804 805 #} elsif(grep $_->[1]{'~resolve'}, @fors) { 806 #} elsif(not grep !$_->[1]{'~resolve'}, @fors) { 807 } elsif( $fors[-1][1]{'~resolve'} ) { 808 # Look to the immediately containing for 809 810 if($para_type eq 'Data') { 811 DEBUG and print "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; 812 $para->[0] = 'Para'; 813 $para_type = 'Plain'; 814 } else { 815 DEBUG and print "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; 816 } 817 } else { 818 DEBUG and print "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n"; 819 $para->[0] = $para_type = 'Data'; 820 } 821 } 822 } 823 824 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 825 if($para_type eq 'Plain') { 826 $self->_ponder_Plain($para); 827 } elsif($para_type eq 'Verbatim') { 828 $self->_ponder_Verbatim($para); 829 } elsif($para_type eq 'Data') { 830 $self->_ponder_Data($para); 831 } else { 832 die "\$para type is $para_type -- how did that happen?"; 833 # Shouldn't happen. 834 } 835 836 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 837 $para->[0] =~ s/^[~=]//s; 838 839 DEBUG and print "\n", pretty($para), "\n"; 840 841 # traverse the treelet (which might well be just one string scalar) 842 $self->{'content_seen'} ||= 1; 843 $self->_traverse_treelet_bit(@$para); 844 } 845 } 846 847 return; 848 } 849 850 ########################################################################### 851 # The sub-ponderers... 852 853 854 855 sub _ponder_for { 856 my ($self,$para,$curr_open,$paras) = @_; 857 858 # Fake it out as a begin/end 859 my $target; 860 861 if(grep $_->[1]{'~ignore'}, @$curr_open) { 862 DEBUG > 1 and print "Ignoring ignorable =for\n"; 863 return 1; 864 } 865 866 for(my $i = 2; $i < @$para; ++$i) { 867 if($para->[$i] =~ s/^\s*(\S+)\s*//s) { 868 $target = $1; 869 last; 870 } 871 } 872 unless(defined $target) { 873 $self->whine( 874 $para->[1]{'start_line'}, 875 "=for without a target?" 876 ); 877 return 1; 878 } 879 DEBUG > 1 and 880 print "Faking out a =for $target as a =begin $target / =end $target\n"; 881 882 $para->[0] = 'Data'; 883 884 unshift @$paras, 885 ['=begin', 886 {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, 887 $target, 888 ], 889 $para, 890 ['=end', 891 {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, 892 $target, 893 ], 894 ; 895 896 return 1; 897 } 898 899 sub _ponder_begin { 900 my ($self,$para,$curr_open,$paras) = @_; 901 my $content = join ' ', splice @$para, 2; 902 $content =~ s/^\s+//s; 903 $content =~ s/\s+$//s; 904 unless(length($content)) { 905 $self->whine( 906 $para->[1]{'start_line'}, 907 "=begin without a target?" 908 ); 909 DEBUG and print "Ignoring targetless =begin\n"; 910 return 1; 911 } 912 913 unless($content =~ m/^\S+$/s) { # i.e., unless it's one word 914 $self->whine( 915 $para->[1]{'start_line'}, 916 "'=begin' only takes one parameter, not several as in '=begin $content'" 917 ); 918 DEBUG and print "Ignoring unintelligible =begin $content\n"; 919 return 1; 920 } 921 922 923 $para->[1]{'target'} = $content; # without any ':' 924 925 $content =~ s/^:!/!:/s; 926 my $neg; # whether this is a negation-match 927 $neg = 1 if $content =~ s/^!//s; 928 my $to_resolve; # whether to process formatting codes 929 $to_resolve = 1 if $content =~ s/^://s; 930 931 my $dont_ignore; # whether this target matches us 932 933 foreach my $target_name ( 934 split(',', $content, -1), 935 $neg ? () : '*' 936 ) { 937 DEBUG > 2 and 938 print " Considering whether =begin $content matches $target_name\n"; 939 next unless $self->{'accept_targets'}{$target_name}; 940 941 DEBUG > 2 and 942 print " It DOES match the acceptable target $target_name!\n"; 943 $to_resolve = 1 944 if $self->{'accept_targets'}{$target_name} eq 'force_resolve'; 945 $dont_ignore = 1; 946 $para->[1]{'target_matching'} = $target_name; 947 last; # stop looking at other target names 948 } 949 950 if($neg) { 951 if( $dont_ignore ) { 952 $dont_ignore = ''; 953 delete $para->[1]{'target_matching'}; 954 DEBUG > 2 and print " But the leading ! means that this is a NON-match!\n"; 955 } else { 956 $dont_ignore = 1; 957 $para->[1]{'target_matching'} = '!'; 958 DEBUG > 2 and print " But the leading ! means that this IS a match!\n"; 959 } 960 } 961 962 $para->[0] = '=for'; # Just what we happen to call these, internally 963 $para->[1]{'~really'} ||= '=begin'; 964 $para->[1]{'~ignore'} = (! $dont_ignore) || 0; 965 $para->[1]{'~resolve'} = $to_resolve || 0; 966 967 DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '', 968 "ignore contents of this region\n"; 969 DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ", 970 ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n"; 971 DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n"; 972 973 push @$curr_open, $para; 974 if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) { 975 DEBUG > 1 and print "Ignoring ignorable =begin\n"; 976 } else { 977 $self->{'content_seen'} ||= 1; 978 $self->_handle_element_start((my $scratch='for'), $para->[1]); 979 } 980 981 return 1; 982 } 983 984 sub _ponder_end { 985 my ($self,$para,$curr_open,$paras) = @_; 986 my $content = join ' ', splice @$para, 2; 987 $content =~ s/^\s+//s; 988 $content =~ s/\s+$//s; 989 DEBUG and print "Ogling '=end $content' directive\n"; 990 991 unless(length($content)) { 992 $self->whine( 993 $para->[1]{'start_line'}, 994 "'=end' without a target?" . ( 995 ( @$curr_open and $curr_open->[-1][0] eq '=for' ) 996 ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' ) 997 : '' 998 ) 999 ); 1000 DEBUG and print "Ignoring targetless =end\n"; 1001 return 1; 1002 } 1003 1004 unless($content =~ m/^\S+$/) { # i.e., unless it's one word 1005 $self->whine( 1006 $para->[1]{'start_line'}, 1007 "'=end $content' is invalid. (Stack: " 1008 . $self->_dump_curr_open() . ')' 1009 ); 1010 DEBUG and print "Ignoring mistargetted =end $content\n"; 1011 return 1; 1012 } 1013 1014 unless(@$curr_open and $curr_open->[-1][0] eq '=for') { 1015 $self->whine( 1016 $para->[1]{'start_line'}, 1017 "=end $content without matching =begin. (Stack: " 1018 . $self->_dump_curr_open() . ')' 1019 ); 1020 DEBUG and print "Ignoring mistargetted =end $content\n"; 1021 return 1; 1022 } 1023 1024 unless($content eq $curr_open->[-1][1]{'target'}) { 1025 $self->whine( 1026 $para->[1]{'start_line'}, 1027 "=end $content doesn't match =begin " 1028 . $curr_open->[-1][1]{'target'} 1029 . ". (Stack: " 1030 . $self->_dump_curr_open() . ')' 1031 ); 1032 DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n"; 1033 return 1; 1034 } 1035 1036 # Else it's okay to close... 1037 if(grep $_->[1]{'~ignore'}, @$curr_open) { 1038 DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n"; 1039 # And that may be because of this to-be-closed =for region, or some 1040 # other one, but it doesn't matter. 1041 } else { 1042 $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'}; 1043 # what's that for? 1044 1045 $self->{'content_seen'} ||= 1; 1046 $self->_handle_element_end( my $scratch = 'for' ); 1047 } 1048 DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; 1049 pop @$curr_open; 1050 1051 return 1; 1052 } 1053 1054 sub _ponder_doc_end { 1055 my ($self,$para,$curr_open,$paras) = @_; 1056 if(@$curr_open) { # Deal with things left open 1057 DEBUG and print "Stack is nonempty at end-document: (", 1058 $self->_dump_curr_open(), ")\n"; 1059 1060 DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n"; 1061 unshift @$paras, $self->_closers_for_all_curr_open; 1062 # Make sure there is exactly one ~end in the parastack, at the end: 1063 @$paras = grep $_->[0] ne '~end', @$paras; 1064 push @$paras, $para, $para; 1065 # We need two -- once for the next cycle where we 1066 # generate errata, and then another to be at the end 1067 # when that loop back around to process the errata. 1068 return 1; 1069 1070 } else { 1071 DEBUG and print "Okay, stack is empty now.\n"; 1072 } 1073 1074 # Try generating errata section, if applicable 1075 unless($self->{'~tried_gen_errata'}) { 1076 $self->{'~tried_gen_errata'} = 1; 1077 my @extras = $self->_gen_errata(); 1078 if(@extras) { 1079 unshift @$paras, @extras; 1080 DEBUG and print "Generated errata... relooping...\n"; 1081 return 1; # I.e., loop around again to process these fake-o paragraphs 1082 } 1083 } 1084 1085 splice @$paras; # Well, that's that for this paragraph buffer. 1086 DEBUG and print "Throwing end-document event.\n"; 1087 1088 $self->_handle_element_end( my $scratch = 'Document' ); 1089 return 1; # Hasta la byebye 1090 } 1091 1092 sub _ponder_pod { 1093 my ($self,$para,$curr_open,$paras) = @_; 1094 $self->whine( 1095 $para->[1]{'start_line'}, 1096 "=pod directives shouldn't be over one line long! Ignoring all " 1097 . (@$para - 2) . " lines of content" 1098 ) if @$para > 3; 1099 # Content is always ignored. 1100 return; 1101 } 1102 1103 sub _ponder_over { 1104 my ($self,$para,$curr_open,$paras) = @_; 1105 return 1 unless @$paras; 1106 my $list_type; 1107 1108 if($paras->[0][0] eq '=item') { # most common case 1109 $list_type = $self->_get_initial_item_type($paras->[0]); 1110 1111 } elsif($paras->[0][0] eq '=back') { 1112 # Ignore empty lists. TODO: make this an option? 1113 shift @$paras; 1114 return 1; 1115 1116 } elsif($paras->[0][0] eq '~end') { 1117 $self->whine( 1118 $para->[1]{'start_line'}, 1119 "=over is the last thing in the document?!" 1120 ); 1121 return 1; # But feh, ignore it. 1122 } else { 1123 $list_type = 'block'; 1124 } 1125 $para->[1]{'~type'} = $list_type; 1126 push @$curr_open, $para; 1127 # yes, we reuse the paragraph as a stack item 1128 1129 my $content = join ' ', splice @$para, 2; 1130 my $overness; 1131 if($content =~ m/^\s*$/s) { 1132 $para->[1]{'indent'} = 4; 1133 } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) { 1134 no integer; 1135 $para->[1]{'indent'} = $1; 1136 if($1 == 0) { 1137 $self->whine( 1138 $para->[1]{'start_line'}, 1139 "Can't have a 0 in =over $content" 1140 ); 1141 $para->[1]{'indent'} = 4; 1142 } 1143 } else { 1144 $self->whine( 1145 $para->[1]{'start_line'}, 1146 "=over should be: '=over' or '=over positive_number'" 1147 ); 1148 $para->[1]{'indent'} = 4; 1149 } 1150 DEBUG > 1 and print "=over found of type $list_type\n"; 1151 1152 $self->{'content_seen'} ||= 1; 1153 $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]); 1154 1155 return; 1156 } 1157 1158 sub _ponder_back { 1159 my ($self,$para,$curr_open,$paras) = @_; 1160 # TODO: fire off </item-number> or </item-bullet> or </item-text> ?? 1161 1162 my $content = join ' ', splice @$para, 2; 1163 if($content =~ m/\S/) { 1164 $self->whine( 1165 $para->[1]{'start_line'}, 1166 "=back doesn't take any parameters, but you said =back $content" 1167 ); 1168 } 1169 1170 if(@$curr_open and $curr_open->[-1][0] eq '=over') { 1171 DEBUG > 1 and print "=back happily closes matching =over\n"; 1172 # Expected case: we're closing the most recently opened thing 1173 #my $over = pop @$curr_open; 1174 $self->{'content_seen'} ||= 1; 1175 $self->_handle_element_end( my $scratch = 1176 'over-' . ( (pop @$curr_open)->[1]{'~type'} ) 1177 ); 1178 } else { 1179 DEBUG > 1 and print "=back found without a matching =over. Stack: (", 1180 join(', ', map $_->[0], @$curr_open), ").\n"; 1181 $self->whine( 1182 $para->[1]{'start_line'}, 1183 '=back without =over' 1184 ); 1185 return 1; # and ignore it 1186 } 1187 } 1188 1189 sub _ponder_item { 1190 my ($self,$para,$curr_open,$paras) = @_; 1191 my $over; 1192 unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') { 1193 $self->whine( 1194 $para->[1]{'start_line'}, 1195 "'=item' outside of any '=over'" 1196 ); 1197 unshift @$paras, 1198 ['=over', {'start_line' => $para->[1]{'start_line'}}, ''], 1199 $para 1200 ; 1201 return 1; 1202 } 1203 1204 1205 my $over_type = $over->[1]{'~type'}; 1206 1207 if(!$over_type) { 1208 # Shouldn't happen1 1209 die "Typeless over in stack, starting at line " 1210 . $over->[1]{'start_line'}; 1211 1212 } elsif($over_type eq 'block') { 1213 unless($curr_open->[-1][1]{'~bitched_about'}) { 1214 $curr_open->[-1][1]{'~bitched_about'} = 1; 1215 $self->whine( 1216 $curr_open->[-1][1]{'start_line'}, 1217 "You can't have =items (as at line " 1218 . $para->[1]{'start_line'} 1219 . ") unless the first thing after the =over is an =item" 1220 ); 1221 } 1222 # Just turn it into a paragraph and reconsider it 1223 $para->[0] = '~Para'; 1224 unshift @$paras, $para; 1225 return 1; 1226 1227 } elsif($over_type eq 'text') { 1228 my $item_type = $self->_get_item_type($para); 1229 # That kills the content of the item if it's a number or bullet. 1230 DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 1231 1232 if($item_type eq 'text') { 1233 # Nothing special needs doing for 'text' 1234 } elsif($item_type eq 'number' or $item_type eq 'bullet') { 1235 die "Unknown item type $item_type" 1236 unless $item_type eq 'number' or $item_type eq 'bullet'; 1237 # Undo our clobbering: 1238 push @$para, $para->[1]{'~orig_content'}; 1239 delete $para->[1]{'number'}; 1240 # Only a PROPER item-number element is allowed 1241 # to have a number attribute. 1242 } else { 1243 die "Unhandled item type $item_type"; # should never happen 1244 } 1245 1246 # =item-text thingies don't need any assimilation, it seems. 1247 1248 } elsif($over_type eq 'number') { 1249 my $item_type = $self->_get_item_type($para); 1250 # That kills the content of the item if it's a number or bullet. 1251 DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 1252 1253 my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; 1254 1255 if($item_type eq 'bullet') { 1256 # Hm, it's not numeric. Correct for this. 1257 $para->[1]{'number'} = $expected_value; 1258 $self->whine( 1259 $para->[1]{'start_line'}, 1260 "Expected '=item $expected_value'" 1261 ); 1262 push @$para, $para->[1]{'~orig_content'}; 1263 # restore the bullet, blocking the assimilation of next para 1264 1265 } elsif($item_type eq 'text') { 1266 # Hm, it's not numeric. Correct for this. 1267 $para->[1]{'number'} = $expected_value; 1268 $self->whine( 1269 $para->[1]{'start_line'}, 1270 "Expected '=item $expected_value'" 1271 ); 1272 # Text content will still be there and will block next ~Para 1273 1274 } elsif($item_type ne 'number') { 1275 die "Unknown item type $item_type"; # should never happen 1276 1277 } elsif($expected_value == $para->[1]{'number'}) { 1278 DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n"; 1279 1280 } else { 1281 DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'}, 1282 " instead of the expected value of $expected_value\n"; 1283 $self->whine( 1284 $para->[1]{'start_line'}, 1285 "You have '=item " . $para->[1]{'number'} . 1286 "' instead of the expected '=item $expected_value'" 1287 ); 1288 $para->[1]{'number'} = $expected_value; # correcting!! 1289 } 1290 1291 if(@$para == 2) { 1292 # For the cases where we /didn't/ push to @$para 1293 if($paras->[0][0] eq '~Para') { 1294 DEBUG and print "Assimilating following ~Para content into $over_type item\n"; 1295 push @$para, splice @{shift @$paras},2; 1296 } else { 1297 DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; 1298 push @$para, ''; # Just so it's not contentless 1299 } 1300 } 1301 1302 1303 } elsif($over_type eq 'bullet') { 1304 my $item_type = $self->_get_item_type($para); 1305 # That kills the content of the item if it's a number or bullet. 1306 DEBUG and print " Item is of type ", $para->[0], " under $over_type\n"; 1307 1308 if($item_type eq 'bullet') { 1309 # as expected! 1310 1311 if( $para->[1]{'~_freaky_para_hack'} ) { 1312 DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n"; 1313 push @$para, delete $para->[1]{'~_freaky_para_hack'}; 1314 } 1315 1316 } elsif($item_type eq 'number') { 1317 $self->whine( 1318 $para->[1]{'start_line'}, 1319 "Expected '=item *'" 1320 ); 1321 push @$para, $para->[1]{'~orig_content'}; 1322 # and block assimilation of the next paragraph 1323 delete $para->[1]{'number'}; 1324 # Only a PROPER item-number element is allowed 1325 # to have a number attribute. 1326 } elsif($item_type eq 'text') { 1327 $self->whine( 1328 $para->[1]{'start_line'}, 1329 "Expected '=item *'" 1330 ); 1331 # But doesn't need processing. But it'll block assimilation 1332 # of the next para. 1333 } else { 1334 die "Unhandled item type $item_type"; # should never happen 1335 } 1336 1337 if(@$para == 2) { 1338 # For the cases where we /didn't/ push to @$para 1339 if($paras->[0][0] eq '~Para') { 1340 DEBUG and print "Assimilating following ~Para content into $over_type item\n"; 1341 push @$para, splice @{shift @$paras},2; 1342 } else { 1343 DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n"; 1344 push @$para, ''; # Just so it's not contentless 1345 } 1346 } 1347 1348 } else { 1349 die "Unhandled =over type \"$over_type\"?"; 1350 # Shouldn't happen! 1351 } 1352 $para->[0] .= '-' . $over_type; 1353 1354 return; 1355 } 1356 1357 sub _ponder_Plain { 1358 my ($self,$para) = @_; 1359 DEBUG and print " giving plain treatment...\n"; 1360 unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' ) 1361 or $para->[1]{'~cooked'} 1362 ) { 1363 push @$para, 1364 @{$self->_make_treelet( 1365 join("\n", splice(@$para, 2)), 1366 $para->[1]{'start_line'} 1367 )}; 1368 } 1369 # Empty paragraphs don't need a treelet for any reason I can see. 1370 # And precooked paragraphs already have a treelet. 1371 return; 1372 } 1373 1374 sub _ponder_Verbatim { 1375 my ($self,$para) = @_; 1376 DEBUG and print " giving verbatim treatment...\n"; 1377 1378 $para->[1]{'xml:space'} = 'preserve'; 1379 for(my $i = 2; $i < @$para; $i++) { 1380 foreach my $line ($para->[$i]) { # just for aliasing 1381 while( $line =~ 1382 # Sort of adapted from Text::Tabs -- yes, it's hardwired in that 1383 # tabs are at every EIGHTH column. For portability, it has to be 1384 # one setting everywhere, and 8th wins. 1385 s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e 1386 ) {} 1387 1388 # TODO: whinge about (or otherwise treat) unindented or overlong lines 1389 1390 } 1391 } 1392 1393 # Now the VerbatimFormatted hoodoo... 1394 if( $self->{'accept_codes'} and 1395 $self->{'accept_codes'}{'VerbatimFormatted'} 1396 ) { 1397 while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para } 1398 # Kill any number of terminal newlines 1399 $self->_verbatim_format($para); 1400 } elsif ($self->{'codes_in_verbatim'}) { 1401 push @$para, 1402 @{$self->_make_treelet( 1403 join("\n", splice(@$para, 2)), 1404 $para->[1]{'start_line'}, $para->[1]{'xml:space'} 1405 )}; 1406 $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines 1407 } else { 1408 push @$para, join "\n", splice(@$para, 2) if @$para > 3; 1409 $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines 1410 } 1411 return; 1412 } 1413 1414 sub _ponder_Data { 1415 my ($self,$para) = @_; 1416 DEBUG and print " giving data treatment...\n"; 1417 $para->[1]{'xml:space'} = 'preserve'; 1418 push @$para, join "\n", splice(@$para, 2) if @$para > 3; 1419 return; 1420 } 1421 1422 1423 1424 1425 ########################################################################### 1426 1427 sub _traverse_treelet_bit { # for use only by the routine above 1428 my($self, $name) = splice @_,0,2; 1429 1430 my $scratch; 1431 $self->_handle_element_start(($scratch=$name), shift @_); 1432 1433 foreach my $x (@_) { 1434 if(ref($x)) { 1435 &_traverse_treelet_bit($self, @$x); 1436 } else { 1437 $self->_handle_text($x); 1438 } 1439 } 1440 1441 $self->_handle_element_end($scratch=$name); 1442 return; 1443 } 1444 1445 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 1446 1447 sub _closers_for_all_curr_open { 1448 my $self = $_[0]; 1449 my @closers; 1450 foreach my $still_open (@{ $self->{'curr_open'} || return }) { 1451 my @copy = @$still_open; 1452 $copy[1] = {%{ $copy[1] }}; 1453 #$copy[1]{'start_line'} = -1; 1454 if($copy[0] eq '=for') { 1455 $copy[0] = '=end'; 1456 } elsif($copy[0] eq '=over') { 1457 $copy[0] = '=back'; 1458 } else { 1459 die "I don't know how to auto-close an open $copy[0] region"; 1460 } 1461 1462 unless( @copy > 2 ) { 1463 push @copy, $copy[1]{'target'}; 1464 $copy[-1] = '' unless defined $copy[-1]; 1465 # since =over's don't have targets 1466 } 1467 1468 DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n"; 1469 unshift @closers, \@copy; 1470 } 1471 return @closers; 1472 } 1473 1474 #-------------------------------------------------------------------------- 1475 1476 sub _verbatim_format { 1477 my($it, $p) = @_; 1478 1479 my $formatting; 1480 1481 for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines 1482 DEBUG and print "_verbatim_format appends a newline to $i: $p->[$i]\n"; 1483 $p->[$i] .= "\n"; 1484 # Unlike with simple Verbatim blocks, we don't end up just doing 1485 # a join("\n", ...) on the contents, so we have to append a 1486 # newline to ever line, and then nix the last one later. 1487 } 1488 1489 if( DEBUG > 4 ) { 1490 print "<<\n"; 1491 for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines 1492 print "_verbatim_format $i: $p->[$i]"; 1493 } 1494 print ">>\n"; 1495 } 1496 1497 for(my $i = $#$p; $i > 2; $i--) { 1498 # work backwards over the lines, except the first (#2) 1499 1500 #next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s 1501 # and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s; 1502 # look at a formatty line preceding a nonformatty one 1503 DEBUG > 5 and print "Scrutinizing line $i: $$p[$i]\n"; 1504 if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) { 1505 DEBUG > 5 and print " It's a formatty line. ", 1506 "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n"; 1507 1508 if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) { 1509 DEBUG > 5 and print " Previous line is formatty! Skipping this one.\n"; 1510 next; 1511 } else { 1512 DEBUG > 5 and print " Previous line is non-formatty! Yay!\n"; 1513 } 1514 } else { 1515 DEBUG > 5 and print " It's not a formatty line. Ignoring\n"; 1516 next; 1517 } 1518 1519 # A formatty line has to have #: in the first two columns, and uses 1520 # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic. 1521 # Example: 1522 # What do you want? i like pie. [or whatever] 1523 # #:^^^^^^^^^^^^^^^^^ ///////////// 1524 1525 1526 DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n"; 1527 1528 $formatting = ' ' . $1; 1529 $formatting =~ s/\s+$//s; # nix trailing whitespace 1530 unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op 1531 splice @$p,$i,1; # remove this line 1532 $i--; # don't consider next line 1533 next; 1534 } 1535 1536 if( length($formatting) >= length($p->[$i-1]) ) { 1537 $formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' '; 1538 } else { 1539 $formatting .= ' ' x (length($p->[$i-1]) - length($formatting)); 1540 } 1541 # Make $formatting and the previous line be exactly the same length, 1542 # with $formatting having a " " as the last character. 1543 1544 DEBUG > 4 and print "Formatting <$formatting> on <", $p->[$i-1], ">\n"; 1545 1546 1547 my @new_line; 1548 while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) { 1549 #print "Format matches $1\n"; 1550 1551 if($2) { 1552 #print "SKIPPING <$2>\n"; 1553 push @new_line, 1554 substr($p->[$i-1], pos($formatting)-length($1), length($1)); 1555 } else { 1556 #print "SNARING $+\n"; 1557 push @new_line, [ 1558 ( 1559 $3 ? 'VerbatimB' : 1560 $4 ? 'VerbatimI' : 1561 $5 ? 'VerbatimBI' : die("Should never get called") 1562 ), {}, 1563 substr($p->[$i-1], pos($formatting)-length($1), length($1)) 1564 ]; 1565 #print "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n"; 1566 } 1567 } 1568 my @nixed = 1569 splice @$p, $i-1, 2, @new_line; # replace myself and the next line 1570 DEBUG > 10 and print "Nixed count: ", scalar(@nixed), "\n"; 1571 1572 DEBUG > 6 and print "New version of the above line is these tokens (", 1573 scalar(@new_line), "):", 1574 map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n"; 1575 $i--; # So the next line we scrutinize is the line before the one 1576 # that we just went and formatted 1577 } 1578 1579 $p->[0] = 'VerbatimFormatted'; 1580 1581 # Collapse adjacent text nodes, just for kicks. 1582 for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last 1583 if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) { 1584 DEBUG > 5 and print "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n"; 1585 $p->[$i] .= splice @$p, $i+1, 1; # merge 1586 --$i; # and back up 1587 } 1588 } 1589 1590 # Now look for the last text token, and remove the terminal newline 1591 for( my $i = $#$p; $i >= 2; $i-- ) { 1592 # work backwards over the tokens, even the first 1593 if( !ref($p->[$i]) ) { 1594 if($p->[$i] =~ s/\n$//s) { 1595 DEBUG > 5 and print "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n"; 1596 } else { 1597 DEBUG > 5 and print 1598 "No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n"; 1599 } 1600 last; # we only want the next one 1601 } 1602 } 1603 1604 return; 1605 } 1606 1607 1608 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 1609 1610 1611 sub _treelet_from_formatting_codes { 1612 # Given a paragraph, returns a treelet. Full of scary tokenizing code. 1613 # Like [ '~Top', {'start_line' => $start_line}, 1614 # "I like ", 1615 # [ 'B', {}, "pie" ], 1616 # "!" 1617 # ] 1618 1619 my($self, $para, $start_line, $preserve_space) = @_; 1620 1621 my $treelet = ['~Top', {'start_line' => $start_line},]; 1622 1623 unless ($preserve_space || $self->{'preserve_whitespace'}) { 1624 $para =~ s/\. /\.\xA0 /g if $self->{'fullstop_space_harden'}; 1625 1626 $para =~ s/\s+/ /g; # collapse and trim all whitespace first. 1627 $para =~ s/ $//; 1628 $para =~ s/^ //; 1629 } 1630 1631 # Only apparent problem the above code is that N<< >> turns into 1632 # N<< >>. But then, word wrapping does that too! So don't do that! 1633 1634 my @stack; 1635 my @lineage = ($treelet); 1636 1637 DEBUG > 4 and print "Paragraph:\n$para\n\n"; 1638 1639 # Here begins our frightening tokenizer RE. The following regex matches 1640 # text in four main parts: 1641 # 1642 # * Start-codes. The first alternative matches C< or C<<, the latter 1643 # followed by some whitespace. $1 will hold the entire start code 1644 # (including any space following a multiple-angle-bracket delimiter), 1645 # and $2 will hold only the additional brackets past the first in a 1646 # multiple-bracket delimiter. length($2) + 1 will be the number of 1647 # closing brackets we have to find. 1648 # 1649 # * Closing brackets. Match some amount of whitespace followed by 1650 # multiple close brackets. The logic to see if this closes anything 1651 # is down below. Note that in order to parse C<< >> correctly, we 1652 # have to use look-behind (?<=\s\s), since the match of the starting 1653 # code will have consumed the whitespace. 1654 # 1655 # * A single closing bracket, to close a simple code like C<>. 1656 # 1657 # * Something that isn't a start or end code. We have to be careful 1658 # about accepting whitespace, since perlpodspec says that any whitespace 1659 # before a multiple-bracket closing delimiter should be ignored. 1660 # 1661 while($para =~ 1662 m/\G 1663 (?: 1664 # Match starting codes, including the whitespace following a 1665 # multiple-delimiter start code. $1 gets the whole start code and 1666 # $2 gets all but one of the <s in the multiple-bracket case. 1667 ([A-Z]<(?:(<+)\s+)?) 1668 | 1669 # Match multiple-bracket end codes. $3 gets the whitespace that 1670 # should be discarded before an end bracket but kept in other cases 1671 # and $4 gets the end brackets themselves. 1672 (\s+|(?<=\s\s))(>{2,}) 1673 | 1674 (\s?>) # $5: simple end-codes 1675 | 1676 ( # $6: stuff containing no start-codes or end-codes 1677 (?: 1678 [^A-Z\s>] 1679 | 1680 (?: 1681 [A-Z](?!<) 1682 ) 1683 | 1684 (?: 1685 \s(?!\s*>) 1686 ) 1687 )+ 1688 ) 1689 ) 1690 /xgo 1691 ) { 1692 DEBUG > 4 and print "\nParagraphic tokenstack = (@stack)\n"; 1693 if(defined $1) { 1694 if(defined $2) { 1695 DEBUG > 3 and print "Found complex start-text code \"$1\"\n"; 1696 push @stack, length($2) + 1; 1697 # length of the necessary complex end-code string 1698 } else { 1699 DEBUG > 3 and print "Found simple start-text code \"$1\"\n"; 1700 push @stack, 0; # signal that we're looking for simple 1701 } 1702 push @lineage, [ substr($1,0,1), {}, ]; # new node object 1703 push @{ $lineage[-2] }, $lineage[-1]; 1704 1705 } elsif(defined $4) { 1706 DEBUG > 3 and print "Found apparent complex end-text code \"$3$4\"\n"; 1707 # This is where it gets messy... 1708 if(! @stack) { 1709 # We saw " >>>>" but needed nothing. This is ALL just stuff then. 1710 DEBUG > 4 and print " But it's really just stuff.\n"; 1711 push @{ $lineage[-1] }, $3, $4; 1712 next; 1713 } elsif(!$stack[-1]) { 1714 # We saw " >>>>" but needed only ">". Back pos up. 1715 DEBUG > 4 and print " And that's more than we needed to close simple.\n"; 1716 push @{ $lineage[-1] }, $3; # That was a for-real space, too. 1717 pos($para) = pos($para) - length($4) + 1; 1718 } elsif($stack[-1] == length($4)) { 1719 # We found " >>>>", and it was exactly what we needed. Commonest case. 1720 DEBUG > 4 and print " And that's exactly what we needed to close complex.\n"; 1721 } elsif($stack[-1] < length($4)) { 1722 # We saw " >>>>" but needed only " >>". Back pos up. 1723 DEBUG > 4 and print " And that's more than we needed to close complex.\n"; 1724 pos($para) = pos($para) - length($4) + $stack[-1]; 1725 } else { 1726 # We saw " >>>>" but needed " >>>>>>". So this is all just stuff! 1727 DEBUG > 4 and print " But it's really just stuff, because we needed more.\n"; 1728 push @{ $lineage[-1] }, $3, $4; 1729 next; 1730 } 1731 #print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n"; 1732 1733 push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; 1734 # Keep the element from being childless 1735 1736 pop @stack; 1737 pop @lineage; 1738 1739 } elsif(defined $5) { 1740 DEBUG > 3 and print "Found apparent simple end-text code \"$4\"\n"; 1741 1742 if(@stack and ! $stack[-1]) { 1743 # We're indeed expecting a simple end-code 1744 DEBUG > 4 and print " It's indeed an end-code.\n"; 1745 1746 if(length($5) == 2) { # There was a space there: " >" 1747 push @{ $lineage[-1] }, ' '; 1748 } elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element 1749 push @{ $lineage[-1] }, ''; # keep it from being really childless 1750 } 1751 1752 pop @stack; 1753 pop @lineage; 1754 } else { 1755 DEBUG > 4 and print " It's just stuff.\n"; 1756 push @{ $lineage[-1] }, $5; 1757 } 1758 1759 } elsif(defined $6) { 1760 DEBUG > 3 and print "Found stuff \"$6\"\n"; 1761 push @{ $lineage[-1] }, $6; 1762 1763 } else { 1764 # should never ever ever ever happen 1765 DEBUG and print "AYYAYAAAAA at line ", __LINE__, "\n"; 1766 die "SPORK 512512!"; 1767 } 1768 } 1769 1770 if(@stack) { # Uhoh, some sequences weren't closed. 1771 my $x= "..."; 1772 while(@stack) { 1773 push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; 1774 # Hmmmmm! 1775 1776 my $code = (pop @lineage)->[0]; 1777 my $ender_length = pop @stack; 1778 if($ender_length) { 1779 --$ender_length; 1780 $x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length); 1781 } else { 1782 $x = $code . "<$x>"; 1783 } 1784 } 1785 DEBUG > 1 and print "Unterminated $x sequence\n"; 1786 $self->whine($start_line, 1787 "Unterminated $x sequence", 1788 ); 1789 } 1790 1791 return $treelet; 1792 } 1793 1794 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 1795 1796 sub text_content_of_treelet { # method: $parser->text_content_of_treelet($lol) 1797 return stringify_lol($_[1]); 1798 } 1799 1800 sub stringify_lol { # function: stringify_lol($lol) 1801 my $string_form = ''; 1802 _stringify_lol( $_[0] => \$string_form ); 1803 return $string_form; 1804 } 1805 1806 sub _stringify_lol { # the real recursor 1807 my($lol, $to) = @_; 1808 use UNIVERSAL (); 1809 for(my $i = 2; $i < @$lol; ++$i) { 1810 if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) { 1811 _stringify_lol( $lol->[$i], $to); # recurse! 1812 } else { 1813 $$to .= $lol->[$i]; 1814 } 1815 } 1816 return; 1817 } 1818 1819 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 1820 1821 sub _dump_curr_open { # return a string representation of the stack 1822 my $curr_open = $_[0]{'curr_open'}; 1823 1824 return '[empty]' unless @$curr_open; 1825 return join '; ', 1826 map {; 1827 ($_->[0] eq '=for') 1828 ? ( ($_->[1]{'~really'} || '=over') 1829 . ' ' . $_->[1]{'target'}) 1830 : $_->[0] 1831 } 1832 @$curr_open 1833 ; 1834 } 1835 1836 ########################################################################### 1837 my %pretty_form = ( 1838 "\a" => '\a', # ding! 1839 "\b" => '\b', # BS 1840 "\e" => '\e', # ESC 1841 "\f" => '\f', # FF 1842 "\t" => '\t', # tab 1843 "\cm" => '\cm', 1844 "\cj" => '\cj', 1845 "\n" => '\n', # probably overrides one of either \cm or \cj 1846 '"' => '\"', 1847 '\\' => '\\\\', 1848 '$' => '\\$', 1849 '@' => '\\@', 1850 '%' => '\\%', 1851 '#' => '\\#', 1852 ); 1853 1854 sub pretty { # adopted from Class::Classless 1855 # Not the most brilliant routine, but passable. 1856 # Don't give it a cyclic data structure! 1857 my @stuff = @_; # copy 1858 my $x; 1859 my $out = 1860 # join ",\n" . 1861 join ", ", 1862 map {; 1863 if(!defined($_)) { 1864 "undef"; 1865 } elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') { 1866 $x = "[ " . pretty(@$_) . " ]" ; 1867 $x; 1868 } elsif(ref($_) eq 'SCALAR') { 1869 $x = "\\" . pretty($$_) ; 1870 $x; 1871 } elsif(ref($_) eq 'HASH') { 1872 my $hr = $_; 1873 $x = "{" . join(", ", 1874 map(pretty($_) . '=>' . pretty($hr->{$_}), 1875 sort keys %$hr ) ) . "}" ; 1876 $x; 1877 } elsif(!length($_)) { q{''} # empty string 1878 } elsif( 1879 $_ eq '0' # very common case 1880 or( 1881 m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s 1882 and $_ ne '-0' # the strange case that that RE lets thru 1883 ) 1884 ) { $_; 1885 } else { 1886 if( chr(65) eq 'A' ) { 1887 s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> 1888 #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg; 1889 <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg; 1890 } else { 1891 # We're in some crazy non-ASCII world! 1892 s<([^abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])> 1893 #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg; 1894 <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg; 1895 } 1896 qq{"$_"}; 1897 } 1898 } @stuff; 1899 # $out =~ s/\n */ /g if length($out) < 75; 1900 return $out; 1901 } 1902 1903 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 1904 1905 # A rather unsubtle method of blowing away all the state information 1906 # from a parser object so it can be reused. Provided as a utility for 1907 # backward compatibilty in Pod::Man, etc. but not recommended for 1908 # general use. 1909 1910 sub reinit { 1911 my $self = shift; 1912 foreach (qw(source_dead source_filename doc_has_started 1913 start_of_pod_block content_seen last_was_blank paras curr_open 1914 line_count pod_para_count in_pod ~tried_gen_errata errata errors_seen 1915 Title)) { 1916 1917 delete $self->{$_}; 1918 } 1919 } 1920 1921 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 1922 1; 1923
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
| Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |