local-lib5/lib/perl5/Pod/Simple/BlackBox.pm

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