home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / BlackBox.pm < prev    next >
Encoding:
Perl POD Document  |  2003-11-01  |  53.7 KB  |  1,639 lines
  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.       # Fake it out as a begin/end
  530.       my $target;
  531.  
  532.       if(grep $_->[1]{'~ignore'}, @$curr_open) {
  533.         DEBUG > 1 and print "Ignoring ignorable =for\n";
  534.         next;
  535.       }
  536.  
  537.       for(my $i = 2; $i < @$para; ++$i) {
  538.         if($para->[$i] =~ s/^\s*(\S+)\s*//s) {
  539.           $target = $1;
  540.           last;
  541.         }
  542.       }
  543.       unless(defined $target) {
  544.         $self->whine(
  545.           $para->[1]{'start_line'},
  546.           "=for without a target?"
  547.         );
  548.         next;
  549.       }
  550.       DEBUG > 1 and
  551.        print "Faking out a =for $target as a =begin $target / =end $target\n";
  552.       
  553.       $para->[0] = 'Data';
  554.       
  555.       unshift @$paras,
  556.         ['=begin',
  557.           {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
  558.           $target,
  559.         ],
  560.         $para,
  561.         ['=end',
  562.           {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
  563.           $target,
  564.         ],
  565.       ;
  566.       
  567.       next;
  568.       
  569.     } elsif($para_type eq '=begin') { #///////////////////////////////////////
  570.  
  571.       my $content = join ' ', splice @$para, 2;
  572.       $content =~ s/^\s+//s;
  573.       $content =~ s/\s+$//s;
  574.       unless(length($content)) {
  575.         $self->whine(
  576.           $para->[1]{'start_line'},
  577.           "=begin without a target?"
  578.         );
  579.         DEBUG and print "Ignoring targetless =begin\n";
  580.         next;
  581.       }
  582.       
  583.       unless($content =~ m/^\S+$/s) {  # i.e., unless it's one word
  584.         $self->whine(
  585.           $para->[1]{'start_line'},
  586.           "'=begin' only takes one parameter, not several as in '=begin $content'"
  587.         );
  588.         DEBUG and print "Ignoring unintelligible =begin $content\n";
  589.         next;
  590.       }
  591.  
  592.  
  593.       $para->[1]{'target'} = $content;  # without any ':'
  594.  
  595.       $content =~ s/^:!/!:/s;
  596.       my $neg;  # whether this is a negation-match
  597.       $neg = 1        if $content =~ s/^!//s;
  598.       my $to_resolve;  # whether to process formatting codes
  599.       $to_resolve = 1 if $content =~ s/^://s;
  600.       
  601.       my $dont_ignore; # whether this target matches us
  602.       
  603.       foreach my $target_name (
  604.         split(',', $content, -1),
  605.         $neg ? () : '*'
  606.       ) {
  607.         DEBUG > 2 and
  608.          print " Considering whether =begin $content matches $target_name\n";
  609.         next unless $self->{'accept_targets'}{$target_name};
  610.         
  611.         DEBUG > 2 and
  612.          print "  It DOES match the acceptable target $target_name!\n";
  613.         $to_resolve = 1
  614.           if $self->{'accept_targets'}{$target_name} eq 'force_resolve';
  615.         $dont_ignore = 1;
  616.         $para->[1]{'target_matching'} = $target_name;
  617.         last; # stop looking at other target names
  618.       }
  619.  
  620.       if($neg) {
  621.         if( $dont_ignore ) {
  622.           $dont_ignore = '';
  623.           delete $para->[1]{'target_matching'};
  624.           DEBUG > 2 and print " But the leading ! means that this is a NON-match!\n";
  625.         } else {
  626.           $dont_ignore = 1;
  627.           $para->[1]{'target_matching'} = '!';
  628.           DEBUG > 2 and print " But the leading ! means that this IS a match!\n";
  629.         }
  630.       }
  631.  
  632.       $para->[0] = '=for';  # Just what we happen to call these, internally
  633.       $para->[1]{'~really'} ||= '=begin';
  634.       $para->[1]{'~ignore'}   = (! $dont_ignore) || 0;
  635.       $para->[1]{'~resolve'}  = $to_resolve || 0;
  636.  
  637.       DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '',
  638.         "ignore contents of this region\n";
  639.       DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ",
  640.         ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n";
  641.       DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n";
  642.  
  643.       push @$curr_open, $para;
  644.       if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) {
  645.         DEBUG > 1 and print "Ignoring ignorable =begin\n";
  646.       } else {
  647.         $self->{'content_seen'} ||= 1;
  648.         $self->_handle_element_start(($scratch='for'), $para->[1]);
  649.       }
  650.  
  651.       next;
  652.       
  653.     } elsif($para_type eq '=end') { #/////////////////////////////////////////
  654.  
  655.       my $content = join ' ', splice @$para, 2;
  656.       $content =~ s/^\s+//s;
  657.       $content =~ s/\s+$//s;
  658.       DEBUG and print "Ogling '=end $content' directive\n";
  659.       
  660.       unless(length($content)) {
  661.         $self->whine(
  662.           $para->[1]{'start_line'},
  663.           "'=end' without a target?" . (
  664.             ( @$curr_open and $curr_open->[-1][0] eq '=for' )
  665.             ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' )
  666.             : ''
  667.           )
  668.         );
  669.         DEBUG and print "Ignoring targetless =end\n";
  670.         next;
  671.       }
  672.       
  673.       unless($content =~ m/^\S+$/) {  # i.e., unless it's one word
  674.         $self->whine(
  675.           $para->[1]{'start_line'},
  676.           "'=end $content' is invalid.  (Stack: "
  677.           . $self->_dump_curr_open() . ')'
  678.         );
  679.         DEBUG and print "Ignoring mistargetted =end $content\n";
  680.         next;
  681.       }
  682.       
  683.       unless(@$curr_open and $curr_open->[-1][0] eq '=for') {
  684.         $self->whine(
  685.           $para->[1]{'start_line'},
  686.           "=end $content without matching =begin.  (Stack: "
  687.           . $self->_dump_curr_open() . ')'
  688.         );
  689.         DEBUG and print "Ignoring mistargetted =end $content\n";
  690.         next;
  691.       }
  692.       
  693.       unless($content eq $curr_open->[-1][1]{'target'}) {
  694.         $self->whine(
  695.           $para->[1]{'start_line'},
  696.           "=end $content doesn't match =begin " 
  697.           . $curr_open->[-1][1]{'target'}
  698.           . ".  (Stack: "
  699.           . $self->_dump_curr_open() . ')'
  700.         );
  701.         DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n";
  702.         next;
  703.       }
  704.  
  705.       # Else it's okay to close...
  706.       if(grep $_->[1]{'~ignore'}, @$curr_open) {
  707.         DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n";
  708.         # And that may be because of this to-be-closed =for region, or some
  709.         #  other one, but it doesn't matter.
  710.       } else {
  711.         $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'};
  712.           # what's that for?
  713.         
  714.         $self->{'content_seen'} ||= 1;
  715.         $self->_handle_element_end( $scratch = 'for' );
  716.       }
  717.       DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n";
  718.       pop @$curr_open;
  719.  
  720.       next;
  721.       
  722.     } elsif($para_type eq '~end') { #/////////////////////////////////////////
  723.       # The virtual end-document signal
  724.       
  725.       if(@$curr_open) { # Deal with things left open
  726.         DEBUG and print "Stack is nonempty at end-document: (",
  727.           $self->_dump_curr_open(), ")\n";
  728.           
  729.         DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n";
  730.         unshift @$paras, $self->_closers_for_all_curr_open;
  731.         # Make sure there is exactly one ~end in the parastack, at the end:
  732.         @$paras = grep $_->[0] ne '~end', @$paras;
  733.         push @$paras, $para, $para;
  734.          # We need two -- once for the next cycle where we
  735.          #  generate errata, and then another to be at the end
  736.          #  when that loop back around to process the errata.
  737.         next;
  738.         
  739.       } else {
  740.         DEBUG and print "Okay, stack is empty now.\n";
  741.       }
  742.       
  743.       # Try generating errata section, if applicable
  744.       unless($self->{'~tried_gen_errata'}) {
  745.         $self->{'~tried_gen_errata'} = 1;
  746.         my @extras = $self->_gen_errata();
  747.         if(@extras) {
  748.           unshift @$paras, @extras;
  749.           DEBUG and print "Generated errata... relooping...\n";
  750.           next;  # I.e., loop around again to process these fake-o paragraphs
  751.         }
  752.       }
  753.       
  754.       splice @$paras; # Well, that's that for this paragraph buffer.
  755.       DEBUG and print "Throwing end-document event.\n";
  756.  
  757.       $self->_handle_element_end( $scratch = 'Document' );
  758.       next; # Hasta la byebye
  759.     }
  760.  
  761.  
  762.     # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  763.     #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  764.     if(grep $_->[1]{'~ignore'}, @$curr_open) {
  765.       DEBUG > 1 and
  766.        print "Skipping $para_type paragraph because in ignore mode.\n";
  767.       next;
  768.     }
  769.     #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  770.     # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  771.  
  772.     if($para_type eq '=pod') { #//////////////////////////////////////////////
  773.       $self->whine(
  774.         $para->[1]{'start_line'},
  775.         "=pod directives shouldn't be over one line long!  Ignoring all "
  776.          . (@$para - 2) . " lines of content"
  777.       ) if @$para > 3;
  778.       # Content is always ignored.
  779.       
  780.  
  781.     } elsif($para_type eq '=over') { #////////////////////////////////////////
  782.       next unless @$paras;
  783.       my $list_type;
  784.  
  785.       if($paras->[0][0] eq '=item') { # most common case
  786.         $list_type = $self->_get_initial_item_type($paras->[0]);
  787.  
  788.       } elsif($paras->[0][0] eq '=back') {
  789.         # Ignore empty lists.  TODO: make this an option?
  790.         shift @$paras;
  791.         next;
  792.         
  793.       } elsif($paras->[0][0] eq '~end') {
  794.         $self->whine(
  795.           $para->[1]{'start_line'},
  796.           "=over is the last thing in the document?!"
  797.         );
  798.         next; # But feh, ignore it.
  799.       } else {
  800.         $list_type = 'block';
  801.       }
  802.       $para->[1]{'~type'} = $list_type;
  803.       push @$curr_open, $para;
  804.        # yes, we reuse the paragraph as a stack item
  805.       
  806.       my $content = join ' ', splice @$para, 2;
  807.       my $overness;
  808.       if($content =~ m/^\s*$/s) {
  809.         $para->[1]{'indent'} = 4;
  810.       } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) {
  811.         no integer;
  812.         $para->[1]{'indent'} = $1;
  813.         if($1 == 0) {
  814.           $self->whine(
  815.             $para->[1]{'start_line'},
  816.             "Can't have a 0 in =over $content"
  817.           );
  818.           $para->[1]{'indent'} = 4;
  819.         }
  820.       } else {
  821.         $self->whine(
  822.           $para->[1]{'start_line'},
  823.           "=over should be: '=over' or '=over positive_number'"
  824.         );
  825.         $para->[1]{'indent'} = 4;
  826.       }
  827.       DEBUG > 1 and print "=over found of type $list_type\n";
  828.       
  829.       $self->{'content_seen'} ||= 1;
  830.       $self->_handle_element_start(($scratch = 'over-' . $list_type), $para->[1]);
  831.       
  832.     } elsif($para_type eq '=back') { #////////////////////////////////////////
  833.  
  834.       # TODO: fire off </item-number> or </item-bullet> or </item-text> ??
  835.  
  836.       my $content = join ' ', splice @$para, 2;
  837.       if($content =~ m/\S/) {
  838.         $self->whine(
  839.           $para->[1]{'start_line'},
  840.           "=back doesn't take any parameters, but you said =back $content"
  841.         );
  842.       }
  843.  
  844.       if(@$curr_open and $curr_open->[-1][0] eq '=over') {
  845.         DEBUG > 1 and print "=back happily closes matching =over\n";
  846.         # Expected case: we're closing the most recently opened thing
  847.         #my $over = pop @$curr_open;
  848.         $self->{'content_seen'} ||= 1;
  849.         $self->_handle_element_end( $scratch =
  850.           'over-' . ( (pop @$curr_open)->[1]{'~type'} )
  851.         );
  852.       } else {
  853.         DEBUG > 1 and print "=back found without a matching =over.  Stack: (",
  854.             join(', ', map $_->[0], @$curr_open), ").\n";
  855.         $self->whine(
  856.           $para->[1]{'start_line'},
  857.           '=back without =over'
  858.         );
  859.         next; # and ignore it
  860.       }
  861.       
  862.     } else { #////////////////////////////////////////////////////////////////
  863.       # All non-magical codes!!!
  864.       
  865.       # Here we start using $para_type for our own twisted purposes, to
  866.       #  mean how it should get treated, not as what the element name
  867.       #  should be.
  868.  
  869.       DEBUG > 1 and print "Pondering non-magical $para_type\n";
  870.  
  871.       my $i;
  872.  
  873.       # Enforce some =headN discipline
  874.       if($para_type =~ m/^=head\d$/s
  875.          and ! $self->{'accept_heads_anywhere'}
  876.          and @$curr_open
  877.          and $curr_open->[-1][0] eq '=over'
  878.       ) {
  879.         DEBUG > 2 and print "'=$para_type' inside an '=over'!\n";
  880.         $self->whine(
  881.           $para->[1]{'start_line'},
  882.           "You forgot a '=back' before '$para_type'"
  883.         );
  884.         unshift @$paras, ['=back', {}, ''], $para;   # close the =over
  885.         next;
  886.       }
  887.  
  888.  
  889.       if($para_type eq '=item') {
  890.  
  891.         my $over;
  892.         unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
  893.           $self->whine(
  894.             $para->[1]{'start_line'},
  895.             "'=item' outside of any '=over'"
  896.           );
  897.           unshift @$paras,
  898.             ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
  899.             $para
  900.           ;
  901.           next;
  902.         }
  903.         
  904.         
  905.         my $over_type = $over->[1]{'~type'};
  906.         
  907.         if(!$over_type) {
  908.           # Shouldn't happen1
  909.           die "Typeless over in stack, starting at line "
  910.            . $over->[1]{'start_line'};
  911.  
  912.         } elsif($over_type eq 'block') {
  913.           unless($curr_open->[-1][1]{'~bitched_about'}) {
  914.             $curr_open->[-1][1]{'~bitched_about'} = 1;
  915.             $self->whine(
  916.               $curr_open->[-1][1]{'start_line'},
  917.               "You can't have =items (as at line "
  918.               . $para->[1]{'start_line'}
  919.               . ") unless the first thing after the =over is an =item"
  920.             );
  921.           }
  922.           # Just turn it into a paragraph and reconsider it
  923.           $para->[0] = '~Para';
  924.           unshift @$paras, $para;
  925.           next;
  926.  
  927.         } elsif($over_type eq 'text') {
  928.           my $item_type = $self->_get_item_type($para);
  929.             # That kills the content of the item if it's a number or bullet.
  930.           DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  931.           
  932.           if($item_type eq 'text') {
  933.             # Nothing special needs doing for 'text'
  934.           } elsif($item_type eq 'number' or $item_type eq 'bullet') {
  935.             die "Unknown item type $item_type"
  936.              unless $item_type eq 'number' or $item_type eq 'bullet';
  937.             # Undo our clobbering:
  938.             push @$para, $para->[1]{'~orig_content'};
  939.             delete $para->[1]{'number'};
  940.              # Only a PROPER item-number element is allowed
  941.              #  to have a number attribute.
  942.           } else {
  943.             die "Unhandled item type $item_type"; # should never happen
  944.           }
  945.           
  946.           # =item-text thingies don't need any assimilation, it seems.
  947.  
  948.         } elsif($over_type eq 'number') {
  949.           my $item_type = $self->_get_item_type($para);
  950.             # That kills the content of the item if it's a number or bullet.
  951.           DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  952.           
  953.           my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
  954.           
  955.           if($item_type eq 'bullet') {
  956.             # Hm, it's not numeric.  Correct for this.
  957.             $para->[1]{'number'} = $expected_value;
  958.             $self->whine(
  959.               $para->[1]{'start_line'},
  960.               "Expected '=item $expected_value'"
  961.             );
  962.             push @$para, $para->[1]{'~orig_content'};
  963.               # restore the bullet, blocking the assimilation of next para
  964.  
  965.           } elsif($item_type eq 'text') {
  966.             # Hm, it's not numeric.  Correct for this.
  967.             $para->[1]{'number'} = $expected_value;
  968.             $self->whine(
  969.               $para->[1]{'start_line'},
  970.               "Expected '=item $expected_value'"
  971.             );
  972.             # Text content will still be there and will block next ~Para
  973.  
  974.           } elsif($item_type ne 'number') {
  975.             die "Unknown item type $item_type"; # should never happen
  976.  
  977.           } elsif($expected_value == $para->[1]{'number'}) {
  978.             DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
  979.             
  980.           } else {
  981.             DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
  982.              " instead of the expected value of $expected_value\n";
  983.             $self->whine(
  984.               $para->[1]{'start_line'},
  985.               "You have '=item " . $para->[1]{'number'} .
  986.               "' instead of the expected '=item $expected_value'"
  987.             );
  988.             $para->[1]{'number'} = $expected_value;  # correcting!!
  989.           }
  990.             
  991.           if(@$para == 2) {
  992.             # For the cases where we /didn't/ push to @$para
  993.             if($paras->[0][0] eq '~Para') {
  994.               DEBUG and print "Assimilating following ~Para content into $over_type item\n";
  995.               push @$para, splice @{shift @$paras},2;
  996.             } else {
  997.               DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
  998.               push @$para, '';  # Just so it's not contentless
  999.             }
  1000.           }
  1001.  
  1002.  
  1003.         } elsif($over_type eq 'bullet') {
  1004.           my $item_type = $self->_get_item_type($para);
  1005.             # That kills the content of the item if it's a number or bullet.
  1006.           DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
  1007.           
  1008.           if($item_type eq 'bullet') {
  1009.             # as expected!
  1010.  
  1011.             if( $para->[1]{'~_freaky_para_hack'} ) {
  1012.               DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
  1013.               push @$para, delete $para->[1]{'~_freaky_para_hack'};
  1014.             }
  1015.  
  1016.           } elsif($item_type eq 'number') {
  1017.             $self->whine(
  1018.               $para->[1]{'start_line'},
  1019.               "Expected '=item *'"
  1020.             );
  1021.             push @$para, $para->[1]{'~orig_content'};
  1022.              # and block assimilation of the next paragraph
  1023.             delete $para->[1]{'number'};
  1024.              # Only a PROPER item-number element is allowed
  1025.              #  to have a number attribute.
  1026.           } elsif($item_type eq 'text') {
  1027.             $self->whine(
  1028.               $para->[1]{'start_line'},
  1029.               "Expected '=item *'"
  1030.             );
  1031.              # But doesn't need processing.  But it'll block assimilation
  1032.              #  of the next para.
  1033.           } else {
  1034.             die "Unhandled item type $item_type"; # should never happen
  1035.           }
  1036.  
  1037.           if(@$para == 2) {
  1038.             # For the cases where we /didn't/ push to @$para
  1039.             if($paras->[0][0] eq '~Para') {
  1040.               DEBUG and print "Assimilating following ~Para content into $over_type item\n";
  1041.               push @$para, splice @{shift @$paras},2;
  1042.             } else {
  1043.               DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
  1044.               push @$para, '';  # Just so it's not contentless
  1045.             }
  1046.           }
  1047.  
  1048.         } else {
  1049.           die "Unhandled =over type \"$over_type\"?";
  1050.           # Shouldn't happen!
  1051.         }
  1052.  
  1053.         $para_type = 'Plain';
  1054.         $para->[0] .= '-' . $over_type;
  1055.         # Whew.  Now fall thru and process it.
  1056.  
  1057.  
  1058.       } elsif($para_type eq '=extend') {
  1059.         # Well, might as well implement it here.
  1060.         $self->_ponder_extend($para);
  1061.         next;  # and skip
  1062.       } elsif($para_type eq '=encoding') {
  1063.         # Not actually acted on here, but we catch errors here.
  1064.         $self->_handle_encoding_second_level($para);
  1065.  
  1066.         next;  # and skip
  1067.       } elsif($para_type eq '~Verbatim') {
  1068.         $para->[0] = 'Verbatim';
  1069.         $para_type = '?Verbatim';
  1070.       } elsif($para_type eq '~Para') {
  1071.         $para->[0] = 'Para';
  1072.         $para_type = '?Plain';
  1073.       } elsif($para_type eq 'Data') {
  1074.         $para->[0] = 'Data';
  1075.         $para_type = '?Data';
  1076.       } elsif( $para_type =~ s/^=//s
  1077.         and defined( $para_type = $self->{'accept_directives'}{$para_type} )
  1078.       ) {
  1079.         DEBUG > 1 and print " Pondering known directive ${$para}[0] as $para_type\n";
  1080.       } else {
  1081.         # An unknown directive!
  1082.         DEBUG > 1 and printf "Unhandled directive %s (Handled: %s)\n",
  1083.          $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} )
  1084.         ;
  1085.         $self->whine(
  1086.           $para->[1]{'start_line'},
  1087.           "Unknown directive: $para->[0]"
  1088.         );
  1089.  
  1090.         # And maybe treat it as text instead of just letting it go?
  1091.         next;
  1092.       }
  1093.  
  1094.       if($para_type =~ s/^\?//s) {
  1095.         if(! @$curr_open) {  # usual case
  1096.           DEBUG and print "Treating $para_type paragraph as such because stack is empty.\n";
  1097.         } else {
  1098.           my @fors = grep $_->[0] eq '=for', @$curr_open;
  1099.           DEBUG > 1 and print "Containing fors: ",
  1100.             join(',', map $_->[1]{'target'}, @fors), "\n";
  1101.           
  1102.           if(! @fors) {
  1103.             DEBUG and print "Treating $para_type paragraph as such because stack has no =for's\n";
  1104.             
  1105.           #} elsif(grep $_->[1]{'~resolve'}, @fors) {
  1106.           #} elsif(not grep !$_->[1]{'~resolve'}, @fors) {
  1107.           } elsif( $fors[-1][1]{'~resolve'} ) {
  1108.             # Look to the immediately containing for
  1109.           
  1110.             if($para_type eq 'Data') {
  1111.               DEBUG and print "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
  1112.               $para->[0] = 'Para';
  1113.               $para_type = 'Plain';
  1114.             } else {
  1115.               DEBUG and print "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
  1116.             }
  1117.           } else {
  1118.             DEBUG and print "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n";
  1119.             $para->[0] = $para_type = 'Data';
  1120.           }
  1121.         }
  1122.       }
  1123.  
  1124.       #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1125.       if($para_type eq 'Plain') {
  1126.         DEBUG and print " giving plain treatment...\n";
  1127.         unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' )
  1128.           or $para->[1]{'~cooked'}
  1129.         ) {
  1130.           push @$para,
  1131.           @{$self->_make_treelet(
  1132.             join("\n", splice(@$para, 2)),
  1133.             $para->[1]{'start_line'}
  1134.           )};
  1135.         }
  1136.         # Empty paragraphs don't need a treelet for any reason I can see.
  1137.         # And precooked paragraphs already have a treelet.
  1138.         
  1139.       } elsif($para_type eq 'Verbatim') {
  1140.         DEBUG and print " giving verbatim treatment...\n";
  1141.       
  1142.         $para->[1]{'xml:space'} = 'preserve';
  1143.         for($i = 2; $i < @$para; $i++) {
  1144.           foreach my $line ($para->[$i]) { # just for aliasing
  1145.             while( $line =~
  1146.               # Sort of adapted from Text::Tabs -- yes, it's hardwired in that
  1147.               # tabs are at every EIGHTH column.  For portability, it has to be
  1148.               # one setting everywhere, and 8th wins.
  1149.               s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
  1150.             ) {}
  1151.  
  1152.             # TODO: whinge about (or otherwise treat) unindented or overlong lines
  1153.  
  1154.           }
  1155.         }
  1156.         
  1157.         # Now the VerbatimFormatted hoodoo...
  1158.         if( $self->{'accept_codes'} and
  1159.             $self->{'accept_codes'}{'VerbatimFormatted'}
  1160.         ) {
  1161.           while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para }
  1162.            # Kill any number of terminal newlines
  1163.           $self->_verbatim_format($para);
  1164.         } else {
  1165.           push @$para, join "\n", splice(@$para, 2) if @$para > 3;
  1166.           $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
  1167.         }
  1168.         
  1169.       } elsif($para_type eq 'Data') {
  1170.         DEBUG and print " giving data treatment...\n";
  1171.         $para->[1]{'xml:space'} = 'preserve';
  1172.         push @$para, join "\n", splice(@$para, 2) if @$para > 3;
  1173.         
  1174.       } else {
  1175.         die "\$para type is $para_type -- how did that happen?";
  1176.         # Shouldn't happen.
  1177.       }
  1178.  
  1179.       #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  1180.       $para->[0] =~ s/^[~=]//s;
  1181.  
  1182.       DEBUG and print "\n", pretty($para), "\n";
  1183.  
  1184.       # traverse the treelet (which might well be just one string scalar)
  1185.       $self->{'content_seen'} ||= 1;
  1186.       $self->_traverse_treelet_bit(@$para);
  1187.     }
  1188.   }
  1189.   
  1190.   return;
  1191. }
  1192.  
  1193. sub _traverse_treelet_bit {  # for use only by the routine above
  1194.   my($self, $name) = splice @_,0,2;
  1195.  
  1196.   my $scratch;
  1197.   $self->_handle_element_start(($scratch=$name), shift @_);
  1198.   
  1199.   foreach my $x (@_) {
  1200.     if(ref($x)) {
  1201.       &_traverse_treelet_bit($self, @$x);
  1202.     } else {
  1203.       $self->_handle_text($x);
  1204.     }
  1205.   }
  1206.   
  1207.   $self->_handle_element_end($scratch=$name);
  1208.   return;
  1209. }
  1210.  
  1211. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1212.  
  1213. sub _closers_for_all_curr_open {
  1214.   my $self = $_[0];
  1215.   my @closers;
  1216.   foreach my $still_open (@{  $self->{'curr_open'} || return  }) {
  1217.     my @copy = @$still_open;
  1218.     $copy[1] = {%{ $copy[1] }};
  1219.     #$copy[1]{'start_line'} = -1;
  1220.     if($copy[0] eq '=for') {
  1221.       $copy[0] = '=end';
  1222.     } elsif($copy[0] eq '=over') {
  1223.       $copy[0] = '=back';
  1224.     } else {
  1225.       die "I don't know how to auto-close an open $copy[0] region";
  1226.     }
  1227.  
  1228.     unless( @copy > 2 ) {
  1229.       push @copy, $copy[1]{'target'};
  1230.       $copy[-1] = '' unless defined $copy[-1];
  1231.        # since =over's don't have targets
  1232.     }
  1233.     
  1234.     DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n";
  1235.     unshift @closers, \@copy;
  1236.   }
  1237.   return @closers;
  1238. }
  1239.  
  1240. #--------------------------------------------------------------------------
  1241.  
  1242. sub _verbatim_format {
  1243.   my($it, $p) = @_;
  1244.   
  1245.   my $formatting;
  1246.  
  1247.   for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines
  1248.     DEBUG and print "_verbatim_format appends a newline to $i: $p->[$i]\n";
  1249.     $p->[$i] .= "\n";
  1250.      # Unlike with simple Verbatim blocks, we don't end up just doing
  1251.      # a join("\n", ...) on the contents, so we have to append a
  1252.      # newline to ever line, and then nix the last one later.
  1253.   }
  1254.  
  1255.   if( DEBUG > 4 ) {
  1256.     print "<<\n";
  1257.     for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines
  1258.       print "_verbatim_format $i: $p->[$i]";
  1259.     }
  1260.     print ">>\n";
  1261.   }
  1262.  
  1263.   for(my $i = $#$p; $i > 2; $i--) {
  1264.     # work backwards over the lines, except the first (#2)
  1265.     
  1266.     #next unless $p->[$i]   =~ m{^#:([ \^\/\%]*)\n?$}s
  1267.     #        and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s;
  1268.      # look at a formatty line preceding a nonformatty one
  1269.     DEBUG > 5 and print "Scrutinizing line $i: $$p[$i]\n";
  1270.     if($p->[$i]   =~ m{^#:([ \^\/\%]*)\n?$}s) {
  1271.       DEBUG > 5 and print "  It's a formatty line.  ",
  1272.        "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n";
  1273.       
  1274.       if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) {
  1275.         DEBUG > 5 and print "  Previous line is formatty!  Skipping this one.\n";
  1276.         next;
  1277.       } else {
  1278.         DEBUG > 5 and print "  Previous line is non-formatty!  Yay!\n";
  1279.       }
  1280.     } else {
  1281.       DEBUG > 5 and print "  It's not a formatty line.  Ignoring\n";
  1282.       next;
  1283.     }
  1284.  
  1285.     # A formatty line has to have #: in the first two columns, and uses
  1286.     # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic.
  1287.     # Example:
  1288.     #   What do you want?  i like pie. [or whatever]
  1289.     # #:^^^^^^^^^^^^^^^^^              /////////////         
  1290.     
  1291.  
  1292.     DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n";
  1293.     
  1294.     $formatting = '  ' . $1;
  1295.     $formatting =~ s/\s+$//s; # nix trailing whitespace
  1296.     unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op
  1297.       splice @$p,$i,1; # remove this line
  1298.       $i--; # don't consider next line
  1299.       next;
  1300.     }
  1301.  
  1302.     if( length($formatting) >= length($p->[$i-1]) ) {
  1303.       $formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' ';
  1304.     } else {
  1305.       $formatting .= ' ' x (length($p->[$i-1]) - length($formatting));
  1306.     }
  1307.     # Make $formatting and the previous line be exactly the same length,
  1308.     # with $formatting having a " " as the last character.
  1309.  
  1310.     DEBUG > 4 and print "Formatting <$formatting>    on <", $p->[$i-1], ">\n";
  1311.  
  1312.  
  1313.     my @new_line;
  1314.     while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) {
  1315.       #print "Format matches $1\n";
  1316.  
  1317.       if($2) {
  1318.         #print "SKIPPING <$2>\n";
  1319.         push @new_line,
  1320.           substr($p->[$i-1], pos($formatting)-length($1), length($1));
  1321.       } else {
  1322.         #print "SNARING $+\n";
  1323.         push @new_line, [
  1324.           (
  1325.             $3 ? 'VerbatimB'  :
  1326.             $4 ? 'VerbatimI'  :
  1327.             $5 ? 'VerbatimBI' : die("Should never get called")
  1328.           ), {},
  1329.           substr($p->[$i-1], pos($formatting)-length($1), length($1))
  1330.         ];
  1331.         #print "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n";
  1332.       }
  1333.     }
  1334.     my @nixed =    
  1335.       splice @$p, $i-1, 2, @new_line; # replace myself and the next line
  1336.     DEBUG > 10 and print "Nixed count: ", scalar(@nixed), "\n";
  1337.     
  1338.     DEBUG > 6 and print "New version of the above line is these tokens (",
  1339.       scalar(@new_line), "):",
  1340.       map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n";
  1341.     $i--; # So the next line we scrutinize is the line before the one
  1342.           #  that we just went and formatted
  1343.   }
  1344.  
  1345.   $p->[0] = 'VerbatimFormatted';
  1346.  
  1347.   # Collapse adjacent text nodes, just for kicks.
  1348.   for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last
  1349.     if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) {
  1350.       DEBUG > 5 and print "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n";
  1351.       $p->[$i] .= splice @$p, $i+1, 1; # merge
  1352.       --$i;  # and back up
  1353.     }
  1354.   }
  1355.  
  1356.   # Now look for the last text token, and remove the terminal newline
  1357.   for( my $i = $#$p; $i >= 2; $i-- ) {
  1358.     # work backwards over the tokens, even the first
  1359.     if( !ref($p->[$i]) ) {
  1360.       if($p->[$i] =~ s/\n$//s) {
  1361.         DEBUG > 5 and print "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n";
  1362.       } else {
  1363.         DEBUG > 5 and print
  1364.          "No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n";
  1365.       }
  1366.       last; # we only want the next one
  1367.     }
  1368.   }
  1369.  
  1370.   return;
  1371. }
  1372.  
  1373.  
  1374. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1375.  
  1376.  
  1377. sub _treelet_from_formatting_codes {
  1378.   # Given a paragraph, returns a treelet.  Full of scary tokenizing code.
  1379.   #  Like [ '~Top', {'start_line' => $start_line},
  1380.   #            "I like ",
  1381.   #            [ 'B', {}, "pie" ],
  1382.   #            "!"
  1383.   #       ]
  1384.   
  1385.   my($self, $para, $start_line) = @_;
  1386.   my $treelet = ['~Top', {'start_line' => $start_line},];
  1387.   
  1388.   $para =~ s/\s+/ /g; # collapse and trim all whitespace first.
  1389.   $para =~ s/ $//g;
  1390.   $para =~ s/^ //g;
  1391.   
  1392.   # Only apparent problem the above code is that N<<  >> turns into
  1393.   # N<< >>.  But then, word wrapping does that too!  So don't do that!
  1394.   
  1395.   my @stack;
  1396.   my @lineage = ($treelet);
  1397.  
  1398.   DEBUG > 4 and print "Paragraph:\n$para\n\n";
  1399.   
  1400.   while($para =~  # Here begins our frightening tokenizer RE.
  1401.     m/\G
  1402.       (?:
  1403.         ([A-Z]<(<+\ )?) # that's $1 and $2 for both kinds of start-codes
  1404.         |
  1405.         (\ >{2,})       # $3: end-codes of the type " >>", " >>>", etc.
  1406.         |
  1407.         (\ ?>)          # $4: simple end-codes
  1408.         |
  1409.         (               # $5: stuff containing no start-codes or end-codes
  1410.           (?:
  1411.             [^A-Z\ >]+
  1412.             |
  1413.             (?:
  1414.               [A-Z](?!<)
  1415.             )
  1416.             |
  1417.             (?:
  1418.               \ (?!>)
  1419.             )
  1420.           )+
  1421.         )
  1422.       )
  1423.     /xgo
  1424.   ) {
  1425.     DEBUG > 4 and print "\nParagraphic tokenstack = (@stack)\n";
  1426.     if(defined $1) {
  1427.       if(defined $2) {
  1428.         DEBUG > 3 and print "Found complex start-text code \"$1\"\n";
  1429.         push @stack, length($1) - 1; 
  1430.           # length of the necessary complex end-code string
  1431.       } else {
  1432.         DEBUG > 3 and print "Found simple start-text code \"$1\"\n";
  1433.         push @stack, 0;  # signal that we're looking for simple
  1434.       }
  1435.       push @lineage, [ substr($1,0,1), {}, ];  # new node object
  1436.       push @{ $lineage[-2] }, $lineage[-1];
  1437.       
  1438.     } elsif(defined $3) {
  1439.       DEBUG > 3 and print "Found apparent complex end-text code \"$3\"\n";
  1440.       # This is where it gets messy...
  1441.       if(! @stack) {
  1442.         # We saw " >>>>" but needed nothing.  This is ALL just stuff then.
  1443.         DEBUG > 4 and print " But it's really just stuff.\n";
  1444.         push @{ $lineage[-1] }, $3;
  1445.         next;
  1446.       } elsif(!$stack[-1]) {
  1447.         # We saw " >>>>" but needed only ">".  Back pos up.
  1448.         DEBUG > 4 and print " And that's more than we needed to close simple.\n";
  1449.         push @{ $lineage[-1] }, ' '; # That was a for-real space, too.
  1450.         pos($para) = pos($para) - length($3) + 2;
  1451.       } elsif($stack[-1] == length($3)) {
  1452.         # We found " >>>>", and it was exactly what we needed.  Commonest case.
  1453.         DEBUG > 4 and print " And that's exactly what we needed to close complex.\n";
  1454.       } elsif($stack[-1] < length($3)) {
  1455.         # We saw " >>>>" but needed only " >>".  Back pos up.
  1456.         DEBUG > 4 and print " And that's more than we needed to close complex.\n";
  1457.         pos($para) = pos($para) - length($3) + $stack[-1];
  1458.       } else {
  1459.         # We saw " >>>>" but needed " >>>>>>".  So this is all just stuff!
  1460.         DEBUG > 4 and print " But it's really just stuff, because we needed more.\n";
  1461.         push @{ $lineage[-1] }, $3;
  1462.         next;
  1463.       }
  1464.       #print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n";
  1465.       
  1466.       push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
  1467.       # Keep the element from being childless
  1468.       
  1469.       pop @stack;
  1470.       pop @lineage;
  1471.       
  1472.     } elsif(defined $4) {
  1473.       DEBUG > 3 and print "Found apparent simple end-text code \"$4\"\n";
  1474.  
  1475.       if(@stack and ! $stack[-1]) {
  1476.         # We're indeed expecting a simple end-code
  1477.         DEBUG > 4 and print " It's indeed an end-code.\n";
  1478.  
  1479.         if(length($4) == 2) { # There was a space there: " >"
  1480.           push @{ $lineage[-1] }, ' ';
  1481.         } elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element
  1482.           push @{ $lineage[-1] }, ''; # keep it from being really childless
  1483.         }
  1484.  
  1485.         pop @stack;
  1486.         pop @lineage;
  1487.       } else {
  1488.         DEBUG > 4 and print " It's just stuff.\n";
  1489.         push @{ $lineage[-1] }, $4;
  1490.       }
  1491.  
  1492.     } elsif(defined $5) {
  1493.       DEBUG > 3 and print "Found stuff \"$5\"\n";
  1494.       push @{ $lineage[-1] }, $5;
  1495.       
  1496.     } else {
  1497.       # should never ever ever ever happen
  1498.       DEBUG and print "AYYAYAAAAA at line ", __LINE__, "\n";
  1499.       die "SPORK 512512!";
  1500.     }
  1501.   }
  1502.  
  1503.   if(@stack) { # Uhoh, some sequences weren't closed.
  1504.     my $x= "...";
  1505.     while(@stack) {
  1506.       push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
  1507.       # Hmmmmm!
  1508.  
  1509.       my $code         = (pop @lineage)->[0];
  1510.       my $ender_length =  pop @stack;
  1511.       if($ender_length) {
  1512.         --$ender_length;
  1513.         $x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length);
  1514.       } else {
  1515.         $x = $code . "<$x>";
  1516.       }
  1517.     }
  1518.     DEBUG > 1 and print "Unterminated $x sequence\n";
  1519.     $self->whine($start_line,
  1520.       "Unterminated $x sequence",
  1521.     );
  1522.   }
  1523.   
  1524.   return $treelet;
  1525. }
  1526.  
  1527. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1528.  
  1529. sub text_content_of_treelet {  # method: $parser->text_content_of_treelet($lol)
  1530.   return stringify_lol($_[1]);
  1531. }
  1532.  
  1533. sub stringify_lol {  # function: stringify_lol($lol)
  1534.   my $string_form = '';
  1535.   _stringify_lol( $_[0] => \$string_form );
  1536.   return $string_form;
  1537. }
  1538.  
  1539. sub _stringify_lol {  # the real recursor
  1540.   my($lol, $to) = @_;
  1541.   use UNIVERSAL ();
  1542.   for(my $i = 2; $i < @$lol; ++$i) {
  1543.     if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) {
  1544.       _stringify_lol( $lol->[$i], $to);  # recurse!
  1545.     } else {
  1546.       $$to .= $lol->[$i];
  1547.     }
  1548.   }
  1549.   return;
  1550. }
  1551.  
  1552. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1553.  
  1554. sub _dump_curr_open { # return a string representation of the stack
  1555.   my $curr_open = $_[0]{'curr_open'};
  1556.  
  1557.   return '[empty]' unless @$curr_open;
  1558.   return join '; ',
  1559.     map {;
  1560.            ($_->[0] eq '=for')
  1561.              ? ( ($_->[1]{'~really'} || '=over')
  1562.                . ' ' . $_->[1]{'target'})
  1563.              : $_->[0]
  1564.         }
  1565.     @$curr_open
  1566.   ;
  1567. }
  1568.  
  1569. ###########################################################################
  1570. my %pretty_form = (
  1571.   "\a" => '\a', # ding!
  1572.   "\b" => '\b', # BS
  1573.   "\e" => '\e', # ESC
  1574.   "\f" => '\f', # FF
  1575.   "\t" => '\t', # tab
  1576.   "\cm" => '\cm',
  1577.   "\cj" => '\cj',
  1578.   "\n" => '\n', # probably overrides one of either \cm or \cj
  1579.   '"' => '\"',
  1580.   '\\' => '\\\\',
  1581.   '$' => '\\$',
  1582.   '@' => '\\@',
  1583.   '%' => '\\%',
  1584.   '#' => '\\#',
  1585. );
  1586.  
  1587. sub pretty { # adopted from Class::Classless
  1588.   # Not the most brilliant routine, but passable.
  1589.   # Don't give it a cyclic data structure!
  1590.   my @stuff = @_; # copy
  1591.   my $x;
  1592.   my $out =
  1593.     # join ",\n" .
  1594.     join ", ",
  1595.     map {;
  1596.     if(!defined($_)) {
  1597.       "undef";
  1598.     } elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') {
  1599.       $x = "[ " . pretty(@$_) . " ]" ;
  1600.       $x;
  1601.     } elsif(ref($_) eq 'SCALAR') {
  1602.       $x = "\\" . pretty($$_) ;
  1603.       $x;
  1604.     } elsif(ref($_) eq 'HASH') {
  1605.       my $hr = $_;
  1606.       $x = "{" . join(", ",
  1607.         map(pretty($_) . '=>' . pretty($hr->{$_}),
  1608.             sort keys %$hr ) ) . "}" ;
  1609.       $x;
  1610.     } elsif(!length($_)) { q{''} # empty string
  1611.     } elsif(
  1612.       $_ eq '0' # very common case
  1613.       or(
  1614.          m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s
  1615.          and $_ ne '-0' # the strange case that that RE lets thru
  1616.       )
  1617.     ) { $_;
  1618.     } else {
  1619.       if( chr(65) eq 'A' ) {
  1620.         s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
  1621.          #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
  1622.          <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
  1623.       } else {
  1624.         # We're in some crazy non-ASCII world!
  1625.         s<([^abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])>
  1626.          #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
  1627.          <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
  1628.       }
  1629.       qq{"$_"};
  1630.     }
  1631.   } @stuff;
  1632.   # $out =~ s/\n */ /g if length($out) < 75;
  1633.   return $out;
  1634. }
  1635.  
  1636. #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1637. 1;
  1638.  
  1639.