blackbox.pm

source of perl for linux application,

}
      
sub _ponder_back {
  my ($self,$para,$curr_open,$paras) = @_;
  # TODO: fire off </item-number> or </item-bullet> or </item-text> ??

  my $content = join ' ', splice @$para, 2;
  if($content =~ m/\S/) {
    $self->whine(
      $para->[1]{'start_line'},
      "=back doesn't take any parameters, but you said =back $content"
    );
  }

  if(@$curr_open and $curr_open->[-1][0] eq '=over') {
    DEBUG > 1 and print "=back happily closes matching =over\n";
    # Expected case: we're closing the most recently opened thing
    #my $over = pop @$curr_open;
    $self->{'content_seen'} ||= 1;
    $self->_handle_element_end( my $scratch =
      'over-' . ( (pop @$curr_open)->[1]{'~type'} )
    );
  } else {
    DEBUG > 1 and print "=back found without a matching =over.  Stack: (",
        join(', ', map $_->[0], @$curr_open), ").\n";
    $self->whine(
      $para->[1]{'start_line'},
      '=back without =over'
    );
    return 1; # and ignore it
  }
}

sub _ponder_item {
  my ($self,$para,$curr_open,$paras) = @_;
  my $over;
  unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
    $self->whine(
      $para->[1]{'start_line'},
      "'=item' outside of any '=over'"
    );
    unshift @$paras,
      ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
      $para
    ;
    return 1;
  }
  
  
  my $over_type = $over->[1]{'~type'};
  
  if(!$over_type) {
    # Shouldn't happen1
    die "Typeless over in stack, starting at line "
     . $over->[1]{'start_line'};

  } elsif($over_type eq 'block') {
    unless($curr_open->[-1][1]{'~bitched_about'}) {
      $curr_open->[-1][1]{'~bitched_about'} = 1;
      $self->whine(
        $curr_open->[-1][1]{'start_line'},
        "You can't have =items (as at line "
        . $para->[1]{'start_line'}
        . ") unless the first thing after the =over is an =item"
      );
    }
    # Just turn it into a paragraph and reconsider it
    $para->[0] = '~Para';
    unshift @$paras, $para;
    return 1;

  } elsif($over_type eq 'text') {
    my $item_type = $self->_get_item_type($para);
      # That kills the content of the item if it's a number or bullet.
    DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
    
    if($item_type eq 'text') {
      # Nothing special needs doing for 'text'
    } elsif($item_type eq 'number' or $item_type eq 'bullet') {
      die "Unknown item type $item_type"
       unless $item_type eq 'number' or $item_type eq 'bullet';
      # Undo our clobbering:
      push @$para, $para->[1]{'~orig_content'};
      delete $para->[1]{'number'};
       # Only a PROPER item-number element is allowed
       #  to have a number attribute.
    } else {
      die "Unhandled item type $item_type"; # should never happen
    }
    
    # =item-text thingies don't need any assimilation, it seems.

  } elsif($over_type eq 'number') {
    my $item_type = $self->_get_item_type($para);
      # That kills the content of the item if it's a number or bullet.
    DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
    
    my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
    
    if($item_type eq 'bullet') {
      # Hm, it's not numeric.  Correct for this.
      $para->[1]{'number'} = $expected_value;
      $self->whine(
        $para->[1]{'start_line'},
        "Expected '=item $expected_value'"
      );
      push @$para, $para->[1]{'~orig_content'};
        # restore the bullet, blocking the assimilation of next para

    } elsif($item_type eq 'text') {
      # Hm, it's not numeric.  Correct for this.
      $para->[1]{'number'} = $expected_value;
      $self->whine(
        $para->[1]{'start_line'},
        "Expected '=item $expected_value'"
      );
      # Text content will still be there and will block next ~Para

    } elsif($item_type ne 'number') {
      die "Unknown item type $item_type"; # should never happen

    } elsif($expected_value == $para->[1]{'number'}) {
      DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
      
    } else {
      DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
       " instead of the expected value of $expected_value\n";
      $self->whine(
        $para->[1]{'start_line'},
        "You have '=item " . $para->[1]{'number'} .
        "' instead of the expected '=item $expected_value'"
      );
      $para->[1]{'number'} = $expected_value;  # correcting!!
    }
      
    if(@$para == 2) {
      # For the cases where we /didn't/ push to @$para
      if($paras->[0][0] eq '~Para') {
        DEBUG and print "Assimilating following ~Para content into $over_type item\n";
        push @$para, splice @{shift @$paras},2;
      } else {
        DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
        push @$para, '';  # Just so it's not contentless
      }
    }


  } elsif($over_type eq 'bullet') {
    my $item_type = $self->_get_item_type($para);
      # That kills the content of the item if it's a number or bullet.
    DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
    
    if($item_type eq 'bullet') {
      # as expected!

      if( $para->[1]{'~_freaky_para_hack'} ) {
        DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
        push @$para, delete $para->[1]{'~_freaky_para_hack'};
      }

    } elsif($item_type eq 'number') {
      $self->whine(
        $para->[1]{'start_line'},
        "Expected '=item *'"
      );
      push @$para, $para->[1]{'~orig_content'};
       # and block assimilation of the next paragraph
      delete $para->[1]{'number'};
       # Only a PROPER item-number element is allowed
       #  to have a number attribute.
    } elsif($item_type eq 'text') {
      $self->whine(
        $para->[1]{'start_line'},
        "Expected '=item *'"
      );
       # But doesn't need processing.  But it'll block assimilation
       #  of the next para.
    } else {
      die "Unhandled item type $item_type"; # should never happen
    }

    if(@$para == 2) {
      # For the cases where we /didn't/ push to @$para
      if($paras->[0][0] eq '~Para') {
        DEBUG and print "Assimilating following ~Para content into $over_type item\n";
        push @$para, splice @{shift @$paras},2;
      } else {
        DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
        push @$para, '';  # Just so it's not contentless
      }
    }

  } else {
    die "Unhandled =over type \"$over_type\"?";
    # Shouldn't happen!
  }
  $para->[0] .= '-' . $over_type;

  return;
}

sub _ponder_Plain {
  my ($self,$para) = @_;
  DEBUG and print " giving plain treatment...\n";
  unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' )
    or $para->[1]{'~cooked'}
  ) {
    push @$para,
    @{$self->_make_treelet(
      join("\n", splice(@$para, 2)),
      $para->[1]{'start_line'}
    )};
  }
  # Empty paragraphs don't need a treelet for any reason I can see.
  # And precooked paragraphs already have a treelet.
  return;
}

sub _ponder_Verbatim {
  my ($self,$para) = @_;
  DEBUG and print " giving verbatim treatment...\n";

  $para->[1]{'xml:space'} = 'preserve';
  for(my $i = 2; $i < @$para; $i++) {
    foreach my $line ($para->[$i]) { # just for aliasing
      while( $line =~
        # Sort of adapted from Text::Tabs -- yes, it's hardwired in that
        # tabs are at every EIGHTH column.  For portability, it has to be
        # one setting everywhere, and 8th wins.
        s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e
      ) {}

      # TODO: whinge about (or otherwise treat) unindented or overlong lines

    }
  }
  
  # Now the VerbatimFormatted hoodoo...
  if( $self->{'accept_codes'} and
      $self->{'accept_codes'}{'VerbatimFormatted'}
  ) {
    while(@$para > 3 and $para->[-1] !~ m/\S/) { pop @$para }
     # Kill any number of terminal newlines
    $self->_verbatim_format($para);
  } elsif ($self->{'codes_in_verbatim'}) {
    push @$para,
    @{$self->_make_treelet(
      join("\n", splice(@$para, 2)),
      $para->[1]{'start_line'}, $para->[1]{'xml:space'}
    )};
    $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
  } else {
    push @$para, join "\n", splice(@$para, 2) if @$para > 3;
    $para->[-1] =~ s/\n+$//s; # Kill any number of terminal newlines
  }
  return;
}

sub _ponder_Data {
  my ($self,$para) = @_;
  DEBUG and print " giving data treatment...\n";
  $para->[1]{'xml:space'} = 'preserve';
  push @$para, join "\n", splice(@$para, 2) if @$para > 3;
  return;
}




###########################################################################

sub _traverse_treelet_bit {  # for use only by the routine above
  my($self, $name) = splice @_,0,2;

  my $scratch;
  $self->_handle_element_start(($scratch=$name), shift @_);
  
  foreach my $x (@_) {
    if(ref($x)) {
      &_traverse_treelet_bit($self, @$x);
    } else {
      $self->_handle_text($x);
    }
  }
  
  $self->_handle_element_end($scratch=$name);
  return;
}

#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

sub _closers_for_all_curr_open {
  my $self = $_[0];
  my @closers;
  foreach my $still_open (@{  $self->{'curr_open'} || return  }) {
    my @copy = @$still_open;
    $copy[1] = {%{ $copy[1] }};
    #$copy[1]{'start_line'} = -1;
    if($copy[0] eq '=for') {
      $copy[0] = '=end';
    } elsif($copy[0] eq '=over') {
      $copy[0] = '=back';
    } else {
      die "I don't know how to auto-close an open $copy[0] region";
    }

    unless( @copy > 2 ) {
      push @copy, $copy[1]{'target'};
      $copy[-1] = '' unless defined $copy[-1];
       # since =over's don't have targets
    }
    
    DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n";
    unshift @closers, \@copy;
  }
  return @closers;
}

#--------------------------------------------------------------------------

sub _verbatim_format {
  my($it, $p) = @_;
  
  my $formatting;

  for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines
    DEBUG and print "_verbatim_format appends a newline to $i: $p->[$i]\n";
    $p->[$i] .= "\n";
     # Unlike with simple Verbatim blocks, we don't end up just doing
     # a join("\n", ...) on the contents, so we have to append a
     # newline to ever line, and then nix the last one later.
  }

  if( DEBUG > 4 ) {
    print "<<\n";
    for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines
      print "_verbatim_format $i: $p->[$i]";
    }
    print ">>\n";
  }

  for(my $i = $#$p; $i > 2; $i--) {
    # work backwards over the lines, except the first (#2)
    
    #next unless $p->[$i]   =~ m{^#:([ \^\/\%]*)\n?$}s
    #        and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s;
     # look at a formatty line preceding a nonformatty one
    DEBUG > 5 and print "Scrutinizing line $i: $$p[$i]\n";
    if($p->[$i]   =~ m{^#:([ \^\/\%]*)\n?$}s) {
      DEBUG > 5 and print "  It's a formatty line.  ",
       "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n";
      
      if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) {
        DEBUG > 5 and print "  Previous line is formatty!  Skipping this one.\n";
        next;
      } else {
        DEBUG > 5 and print "  Previous line is non-formatty!  Yay!\n";
      }
    } else {
      DEBUG > 5 and print "  It's not a formatty line.  Ignoring\n";
      next;
    }

    # A formatty line has to have #: in the first two columns, and uses
    # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic.
    # Example:
    #   What do you want?  i like pie. [or whatever]
    # #:^^^^^^^^^^^^^^^^^              /////////////         
    

    DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n";
    
    $formatting = '  ' . $1;
    $formatting =~ s/\s+$//s; # nix trailing whitespace
    unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op
      splice @$p,$i,1; # remove this line
      $i--; # don't consider next line
      next;
    }

    if( length($formatting) >= length($p->[$i-1]) ) {
      $formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' ';
    } else {
      $formatting .= ' ' x (length($p->[$i-1]) - length($formatting));
    }