github-keygen

#!/usr/bin/env perl

# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;

$fatpacked{"Algorithm/Diff.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_DIFF';
  package Algorithm::Diff;
  # Skip to first "=head" line for documentation.
  use strict;
  
  use integer;    # see below in _replaceNextLargerWith() for mod to make
                  # if you don't use this
  use vars qw( $VERSION @EXPORT_OK );
  $VERSION = '1.201';
  
  require Exporter;
  *import    = \&Exporter::import;
  @EXPORT_OK = qw(
      prepare LCS LCSidx LCS_length
      diff sdiff compact_diff
      traverse_sequences traverse_balanced
  );
  
  # McIlroy-Hunt diff algorithm
  # Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
  # by Ned Konz, perl@bike-nomad.com
  # Updates by Tye McQueen, http://perlmonks.org/?node=tye
  
  # Create a hash that maps each element of $aCollection to the set of
  # positions it occupies in $aCollection, restricted to the elements
  # within the range of indexes specified by $start and $end.
  # The fourth parameter is a subroutine reference that will be called to
  # generate a string to use as a key.
  # Additional parameters, if any, will be passed to this subroutine.
  #
  # my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
  
  sub _withPositionsOfInInterval
  {
      my $aCollection = shift;    # array ref
      my $start       = shift;
      my $end         = shift;
      my $keyGen      = shift;
      my %d;
      my $index;
      for ( $index = $start ; $index <= $end ; $index++ )
      {
          my $element = $aCollection->[$index];
          my $key = $keyGen ? &$keyGen( $element, @_ ) : $element;
          if ( exists( $d{$key} ) )
          {
              unshift ( @{ $d{$key} }, $index );
          }
          else
          {
              $d{$key} = [$index];
          }
      }
      return wantarray ? %d : \%d;
  }
  
  # Find the place at which aValue would normally be inserted into the
  # array. If that place is already occupied by aValue, do nothing, and
  # return undef. If the place does not exist (i.e., it is off the end of
  # the array), add it to the end, otherwise replace the element at that
  # point with aValue.  It is assumed that the array's values are numeric.
  # This is where the bulk (75%) of the time is spent in this module, so
  # try to make it fast!
  
  sub _replaceNextLargerWith
  {
      my ( $array, $aValue, $high ) = @_;
      $high ||= $#$array;
  
      # off the end?
      if ( $high == -1 || $aValue > $array->[-1] )
      {
          push ( @$array, $aValue );
          return $high + 1;
      }
  
      # binary search for insertion point...
      my $low = 0;
      my $index;
      my $found;
      while ( $low <= $high )
      {
          $index = ( $high + $low ) / 2;
  
          # $index = int(( $high + $low ) / 2);  # without 'use integer'
          $found = $array->[$index];
  
          if ( $aValue == $found )
          {
              return undef;
          }
          elsif ( $aValue > $found )
          {
              $low = $index + 1;
          }
          else
          {
              $high = $index - 1;
          }
      }
  
      # now insertion point is in $low.
      $array->[$low] = $aValue;    # overwrite next larger
      return $low;
  }
  
  # This method computes the longest common subsequence in $a and $b.
  
  # Result is array or ref, whose contents is such that
  #   $a->[ $i ] == $b->[ $result[ $i ] ]
  # foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
  
  # An additional argument may be passed; this is a hash or key generating
  # function that should return a string that uniquely identifies the given
  # element.  It should be the case that if the key is the same, the elements
  # will compare the same. If this parameter is undef or missing, the key
  # will be the element as a string.
  
  # By default, comparisons will use "eq" and elements will be turned into keys
  # using the default stringizing operator '""'.
  
  # Additional parameters, if any, will be passed to the key generation
  # routine.
  
  sub _longestCommonSubsequence
  {
      my $a        = shift;    # array ref or hash ref
      my $b        = shift;    # array ref or hash ref
      my $counting = shift;    # scalar
      my $keyGen   = shift;    # code ref
      my $compare;             # code ref
  
      if ( ref($a) eq 'HASH' )
      {                        # prepared hash must be in $b
          my $tmp = $b;
          $b = $a;
          $a = $tmp;
      }
  
      # Check for bogus (non-ref) argument values
      if ( !ref($a) || !ref($b) )
      {
          my @callerInfo = caller(1);
          die 'error: must pass array or hash references to ' . $callerInfo[3];
      }
  
      # set up code refs
      # Note that these are optimized.
      if ( $keyGen )    # optimize for strings
      {
          $compare = sub {
              my $a = shift;
              my $b = shift;
              &$keyGen( $a, @_ ) eq &$keyGen( $b, @_ );
          };
      }
  
      my ( $aStart, $aFinish, $matchVector ) = ( 0, $#$a, [] );
      my ( $prunedCount, $bMatches ) = ( 0, {} );
  
      if ( ref($b) eq 'HASH' )    # was $bMatches prepared for us?
      {
          $bMatches = $b;
      }
      else
      {
          my ( $bStart, $bFinish ) = ( 0, $#$b );
  
          # First we prune off any common elements at the beginning
          while ( $aStart <= $aFinish
              and $bStart <= $bFinish
              and ( $keyGen ? &$compare( $a->[$aStart], $b->[$bStart], @_ )
                            : ( $a->[$aStart] eq $b->[$bStart] ) ) )
          {
              $matchVector->[ $aStart++ ] = $bStart++;
              $prunedCount++;
          }
  
          # now the end
          while ( $aStart <= $aFinish
              and $bStart <= $bFinish
              and ( $keyGen ? &$compare( $a->[$aFinish], $b->[$bFinish], @_ )
                            : ( $a->[$aFinish] eq $b->[$bFinish] ) ) )
          {
              $matchVector->[ $aFinish-- ] = $bFinish--;
              $prunedCount++;
          }
  
          # Now compute the equivalence classes of positions of elements
          $bMatches =
            _withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
      }
      my $thresh = [];
      my $links  = [];
  
      my ( $i, $ai, $j, $k );
      for ( $i = $aStart ; $i <= $aFinish ; $i++ )
      {
          $ai = $keyGen ? &$keyGen( $a->[$i], @_ ) : $a->[$i];
          if ( exists( $bMatches->{$ai} ) )
          {
              $k = 0;
              for $j ( @{ $bMatches->{$ai} } )
              {
  
                  # optimization: most of the time this will be true
                  if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j )
                  {
                      $thresh->[$k] = $j;
                  }
                  else
                  {
                      $k = _replaceNextLargerWith( $thresh, $j, $k );
                  }
  
                  # oddly, it's faster to always test this (CPU cache?).
                  if ( defined($k) )
                  {
                      $links->[$k] =
                        [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
                  }
              }
          }
      }
  
      if (@$thresh)
      {
          return $prunedCount + @$thresh if $counting;
          for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] )
          {
              $matchVector->[ $link->[1] ] = $link->[2];
          }
      }
      elsif ($counting)
      {
          return $prunedCount;
      }
  
      return wantarray ? @$matchVector : $matchVector;
  }
  
  sub traverse_sequences
  {
      my $a                 = shift;          # array ref
      my $b                 = shift;          # array ref
      my $callbacks         = shift || {};
      my $keyGen            = shift;
      my $matchCallback     = $callbacks->{'MATCH'} || sub { };
      my $discardACallback  = $callbacks->{'DISCARD_A'} || sub { };
      my $finishedACallback = $callbacks->{'A_FINISHED'};
      my $discardBCallback  = $callbacks->{'DISCARD_B'} || sub { };
      my $finishedBCallback = $callbacks->{'B_FINISHED'};
      my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
  
      # Process all the lines in @$matchVector
      my $lastA = $#$a;
      my $lastB = $#$b;
      my $bi    = 0;
      my $ai;
  
      for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ )
      {
          my $bLine = $matchVector->[$ai];
          if ( defined($bLine) )    # matched
          {
              &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
              &$matchCallback( $ai,    $bi++, @_ );
          }
          else
          {
              &$discardACallback( $ai, $bi, @_ );
          }
      }
  
      # The last entry (if any) processed was a match.
      # $ai and $bi point just past the last matching lines in their sequences.
  
      while ( $ai <= $lastA or $bi <= $lastB )
      {
  
          # last A?
          if ( $ai == $lastA + 1 and $bi <= $lastB )
          {
              if ( defined($finishedACallback) )
              {
                  &$finishedACallback( $lastA, @_ );
                  $finishedACallback = undef;
              }
              else
              {
                  &$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB;
              }
          }
  
          # last B?
          if ( $bi == $lastB + 1 and $ai <= $lastA )
          {
              if ( defined($finishedBCallback) )
              {
                  &$finishedBCallback( $lastB, @_ );
                  $finishedBCallback = undef;
              }
              else
              {
                  &$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA;
              }
          }
  
          &$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA;
          &$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB;
      }
  
      return 1;
  }
  
  sub traverse_balanced
  {
      my $a                 = shift;              # array ref
      my $b                 = shift;              # array ref
      my $callbacks         = shift || {};
      my $keyGen            = shift;
      my $matchCallback     = $callbacks->{'MATCH'} || sub { };
      my $discardACallback  = $callbacks->{'DISCARD_A'} || sub { };
      my $discardBCallback  = $callbacks->{'DISCARD_B'} || sub { };
      my $changeCallback    = $callbacks->{'CHANGE'};
      my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
  
      # Process all the lines in match vector
      my $lastA = $#$a;
      my $lastB = $#$b;
      my $bi    = 0;
      my $ai    = 0;
      my $ma    = -1;
      my $mb;
  
      while (1)
      {
  
          # Find next match indices $ma and $mb
          do {
              $ma++;
          } while(
                  $ma <= $#$matchVector
              &&  !defined $matchVector->[$ma]
          );
  
          last if $ma > $#$matchVector;    # end of matchVector?
          $mb = $matchVector->[$ma];
  
          # Proceed with discard a/b or change events until
          # next match
          while ( $ai < $ma || $bi < $mb )
          {
  
              if ( $ai < $ma && $bi < $mb )
              {
  
                  # Change
                  if ( defined $changeCallback )
                  {
                      &$changeCallback( $ai++, $bi++, @_ );
                  }
                  else
                  {
                      &$discardACallback( $ai++, $bi, @_ );
                      &$discardBCallback( $ai, $bi++, @_ );
                  }
              }
              elsif ( $ai < $ma )
              {
                  &$discardACallback( $ai++, $bi, @_ );
              }
              else
              {
  
                  # $bi < $mb
                  &$discardBCallback( $ai, $bi++, @_ );
              }
          }
  
          # Match
          &$matchCallback( $ai++, $bi++, @_ );
      }
  
      while ( $ai <= $lastA || $bi <= $lastB )
      {
          if ( $ai <= $lastA && $bi <= $lastB )
          {
  
              # Change
              if ( defined $changeCallback )
              {
                  &$changeCallback( $ai++, $bi++, @_ );
              }
              else
              {
                  &$discardACallback( $ai++, $bi, @_ );
                  &$discardBCallback( $ai, $bi++, @_ );
              }
          }
          elsif ( $ai <= $lastA )
          {
              &$discardACallback( $ai++, $bi, @_ );
          }
          else
          {
  
              # $bi <= $lastB
              &$discardBCallback( $ai, $bi++, @_ );
          }
      }
  
      return 1;
  }
  
  sub prepare
  {
      my $a       = shift;    # array ref
      my $keyGen  = shift;    # code ref
  
      # set up code ref
      $keyGen = sub { $_[0] } unless defined($keyGen);
  
      return scalar _withPositionsOfInInterval( $a, 0, $#$a, $keyGen, @_ );
  }
  
  sub LCS
  {
      my $a = shift;                  # array ref
      my $b = shift;                  # array ref or hash ref
      my $matchVector = _longestCommonSubsequence( $a, $b, 0, @_ );
      my @retval;
      my $i;
      for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
      {
          if ( defined( $matchVector->[$i] ) )
          {
              push ( @retval, $a->[$i] );
          }
      }
      return wantarray ? @retval : \@retval;
  }
  
  sub LCS_length
  {
      my $a = shift;                          # array ref
      my $b = shift;                          # array ref or hash ref
      return _longestCommonSubsequence( $a, $b, 1, @_ );
  }
  
  sub LCSidx
  {
      my $a= shift @_;
      my $b= shift @_;
      my $match= _longestCommonSubsequence( $a, $b, 0, @_ );
      my @am= grep defined $match->[$_], 0..$#$match;
      my @bm= @{$match}[@am];
      return \@am, \@bm;
  }
  
  sub compact_diff
  {
      my $a= shift @_;
      my $b= shift @_;
      my( $am, $bm )= LCSidx( $a, $b, @_ );
      my @cdiff;
      my( $ai, $bi )= ( 0, 0 );
      push @cdiff, $ai, $bi;
      while( 1 ) {
          while(  @$am  &&  $ai == $am->[0]  &&  $bi == $bm->[0]  ) {
              shift @$am;
              shift @$bm;
              ++$ai, ++$bi;
          }
          push @cdiff, $ai, $bi;
          last   if  ! @$am;
          $ai = $am->[0];
          $bi = $bm->[0];
          push @cdiff, $ai, $bi;
      }
      push @cdiff, 0+@$a, 0+@$b
          if  $ai < @$a || $bi < @$b;
      return wantarray ? @cdiff : \@cdiff;
  }
  
  sub diff
  {
      my $a      = shift;    # array ref
      my $b      = shift;    # array ref
      my $retval = [];
      my $hunk   = [];
      my $discard = sub {
          push @$hunk, [ '-', $_[0], $a->[ $_[0] ] ];
      };
      my $add = sub {
          push @$hunk, [ '+', $_[1], $b->[ $_[1] ] ];
      };
      my $match = sub {
          push @$retval, $hunk
              if 0 < @$hunk;
          $hunk = []
      };
      traverse_sequences( $a, $b,
          { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
      &$match();
      return wantarray ? @$retval : $retval;
  }
  
  sub sdiff
  {
      my $a      = shift;    # array ref
      my $b      = shift;    # array ref
      my $retval = [];
      my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) };
      my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) };
      my $change = sub {
          push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] );
      };
      my $match = sub {
          push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] );
      };
      traverse_balanced(
          $a,
          $b,
          {
              MATCH     => $match,
              DISCARD_A => $discard,
              DISCARD_B => $add,
              CHANGE    => $change,
          },
          @_
      );
      return wantarray ? @$retval : $retval;
  }
  
  ########################################
  my $Root= __PACKAGE__;
  package Algorithm::Diff::_impl;
  use strict;
  
  sub _Idx()  { 0 } # $me->[_Idx]: Ref to array of hunk indices
              # 1   # $me->[1]: Ref to first sequence
              # 2   # $me->[2]: Ref to second sequence
  sub _End()  { 3 } # $me->[_End]: Diff between forward and reverse pos
  sub _Same() { 4 } # $me->[_Same]: 1 if pos 1 contains unchanged items
  sub _Base() { 5 } # $me->[_Base]: Added to range's min and max
  sub _Pos()  { 6 } # $me->[_Pos]: Which hunk is currently selected
  sub _Off()  { 7 } # $me->[_Off]: Offset into _Idx for current position
  sub _Min() { -2 } # Added to _Off to get min instead of max+1
  
  sub Die
  {
      require Carp;
      Carp::confess( @_ );
  }
  
  sub _ChkPos
  {
      my( $me )= @_;
      return   if  $me->[_Pos];
      my $meth= ( caller(1) )[3];
      Die( "Called $meth on 'reset' object" );
  }
  
  sub _ChkSeq
  {
      my( $me, $seq )= @_;
      return $seq + $me->[_Off]
          if  1 == $seq  ||  2 == $seq;
      my $meth= ( caller(1) )[3];
      Die( "$meth: Invalid sequence number ($seq); must be 1 or 2" );
  }
  
  sub getObjPkg
  {
      my( $us )= @_;
      return ref $us   if  ref $us;
      return $us . "::_obj";
  }
  
  sub new
  {
      my( $us, $seq1, $seq2, $opts ) = @_;
      my @args;
      for( $opts->{keyGen} ) {
          push @args, $_   if  $_;
      }
      for( $opts->{keyGenArgs} ) {
          push @args, @$_   if  $_;
      }
      my $cdif= Algorithm::Diff::compact_diff( $seq1, $seq2, @args );
      my $same= 1;
      if(  0 == $cdif->[2]  &&  0 == $cdif->[3]  ) {
          $same= 0;
          splice @$cdif, 0, 2;
      }
      my @obj= ( $cdif, $seq1, $seq2 );
      $obj[_End] = (1+@$cdif)/2;
      $obj[_Same] = $same;
      $obj[_Base] = 0;
      my $me = bless \@obj, $us->getObjPkg();
      $me->Reset( 0 );
      return $me;
  }
  
  sub Reset
  {
      my( $me, $pos )= @_;
      $pos= int( $pos || 0 );
      $pos += $me->[_End]
          if  $pos < 0;
      $pos= 0
          if  $pos < 0  ||  $me->[_End] <= $pos;
      $me->[_Pos]= $pos || !1;
      $me->[_Off]= 2*$pos - 1;
      return $me;
  }
  
  sub Base
  {
      my( $me, $base )= @_;
      my $oldBase= $me->[_Base];
      $me->[_Base]= 0+$base   if  defined $base;
      return $oldBase;
  }
  
  sub Copy
  {
      my( $me, $pos, $base )= @_;
      my @obj= @$me;
      my $you= bless \@obj, ref($me);
      $you->Reset( $pos )   if  defined $pos;
      $you->Base( $base );
      return $you;
  }
  
  sub Next {
      my( $me, $steps )= @_;
      $steps= 1   if  ! defined $steps;
      if( $steps ) {
          my $pos= $me->[_Pos];
          my $new= $pos + $steps;
          $new= 0   if  $pos  &&  $new < 0;
          $me->Reset( $new )
      }
      return $me->[_Pos];
  }
  
  sub Prev {
      my( $me, $steps )= @_;
      $steps= 1   if  ! defined $steps;
      my $pos= $me->Next(-$steps);
      $pos -= $me->[_End]   if  $pos;
      return $pos;
  }
  
  sub Diff {
      my( $me )= @_;
      $me->_ChkPos();
      return 0   if  $me->[_Same] == ( 1 & $me->[_Pos] );
      my $ret= 0;
      my $off= $me->[_Off];
      for my $seq ( 1, 2 ) {
          $ret |= $seq
              if  $me->[_Idx][ $off + $seq + _Min ]
              <   $me->[_Idx][ $off + $seq ];
      }
      return $ret;
  }
  
  sub Min {
      my( $me, $seq, $base )= @_;
      $me->_ChkPos();
      my $off= $me->_ChkSeq($seq);
      $base= $me->[_Base] if !defined $base;
      return $base + $me->[_Idx][ $off + _Min ];
  }
  
  sub Max {
      my( $me, $seq, $base )= @_;
      $me->_ChkPos();
      my $off= $me->_ChkSeq($seq);
      $base= $me->[_Base] if !defined $base;
      return $base + $me->[_Idx][ $off ] -1;
  }
  
  sub Range {
      my( $me, $seq, $base )= @_;
      $me->_ChkPos();
      my $off = $me->_ChkSeq($seq);
      if( !wantarray ) {
          return  $me->[_Idx][ $off ]
              -   $me->[_Idx][ $off + _Min ];
      }
      $base= $me->[_Base] if !defined $base;
      return  ( $base + $me->[_Idx][ $off + _Min ] )
          ..  ( $base + $me->[_Idx][ $off ] - 1 );
  }
  
  sub Items {
      my( $me, $seq )= @_;
      $me->_ChkPos();
      my $off = $me->_ChkSeq($seq);
      if( !wantarray ) {
          return  $me->[_Idx][ $off ]
              -   $me->[_Idx][ $off + _Min ];
      }
      return
          @{$me->[$seq]}[
                  $me->[_Idx][ $off + _Min ]
              ..  ( $me->[_Idx][ $off ] - 1 )
          ];
  }
  
  sub Same {
      my( $me )= @_;
      $me->_ChkPos();
      return wantarray ? () : 0
          if  $me->[_Same] != ( 1 & $me->[_Pos] );
      return $me->Items(1);
  }
  
  my %getName;
  BEGIN {
      %getName= (
          same => \&Same,
          diff => \&Diff,
          base => \&Base,
          min  => \&Min,
          max  => \&Max,
          range=> \&Range,
          items=> \&Items, # same thing
      );
  }
  
  sub Get
  {
      my $me= shift @_;
      $me->_ChkPos();
      my @value;
      for my $arg (  @_  ) {
          for my $word (  split ' ', $arg  ) {
              my $meth;
              if(     $word !~ /^(-?\d+)?([a-zA-Z]+)([12])?$/
                  ||  not  $meth= $getName{ lc $2 }
              ) {
                  Die( $Root, ", Get: Invalid request ($word)" );
              }
              my( $base, $name, $seq )= ( $1, $2, $3 );
              push @value, scalar(
                  4 == length($name)
                      ? $meth->( $me )
                      : $meth->( $me, $seq, $base )
              );
          }
      }
      if(  wantarray  ) {
          return @value;
      } elsif(  1 == @value  ) {
          return $value[0];
      }
      Die( 0+@value, " values requested from ",
          $Root, "'s Get in scalar context" );
  }
  
  
  my $Obj= getObjPkg($Root);
  no strict 'refs';
  
  for my $meth (  qw( new getObjPkg )  ) {
      *{$Root."::".$meth} = \&{$meth};
      *{$Obj ."::".$meth} = \&{$meth};
  }
  for my $meth (  qw(
      Next Prev Reset Copy Base Diff
      Same Items Range Min Max Get
      _ChkPos _ChkSeq
  )  ) {
      *{$Obj."::".$meth} = \&{$meth};
  }
  
  1;
  __END__
  
  =head1 NAME
  
  Algorithm::Diff - Compute `intelligent' differences between two files / lists
  
  =head1 SYNOPSIS
  
      require Algorithm::Diff;
  
      # This example produces traditional 'diff' output:
  
      my $diff = Algorithm::Diff->new( \@seq1, \@seq2 );
  
      $diff->Base( 1 );   # Return line numbers, not indices
      while(  $diff->Next()  ) {
          next   if  $diff->Same();
          my $sep = '';
          if(  ! $diff->Items(2)  ) {
              printf "%d,%dd%d\n",
                  $diff->Get(qw( Min1 Max1 Max2 ));
          } elsif(  ! $diff->Items(1)  ) {
              printf "%da%d,%d\n",
                  $diff->Get(qw( Max1 Min2 Max2 ));
          } else {
              $sep = "---\n";
              printf "%d,%dc%d,%d\n",
                  $diff->Get(qw( Min1 Max1 Min2 Max2 ));
          }
          print "< $_"   for  $diff->Items(1);
          print $sep;
          print "> $_"   for  $diff->Items(2);
      }
  
  
      # Alternate interfaces:
  
      use Algorithm::Diff qw(
          LCS LCS_length LCSidx
          diff sdiff compact_diff
          traverse_sequences traverse_balanced );
  
      @lcs    = LCS( \@seq1, \@seq2 );
      $lcsref = LCS( \@seq1, \@seq2 );
      $count  = LCS_length( \@seq1, \@seq2 );
  
      ( $seq1idxref, $seq2idxref ) = LCSidx( \@seq1, \@seq2 );
  
  
      # Complicated interfaces:
  
      @diffs  = diff( \@seq1, \@seq2 );
  
      @sdiffs = sdiff( \@seq1, \@seq2 );
  
      @cdiffs = compact_diff( \@seq1, \@seq2 );
  
      traverse_sequences(
          \@seq1,
          \@seq2,
          {   MATCH     => \&callback1,
              DISCARD_A => \&callback2,
              DISCARD_B => \&callback3,
          },
          \&key_generator,
          @extra_args,
      );
  
      traverse_balanced(
          \@seq1,
          \@seq2,
          {   MATCH     => \&callback1,
              DISCARD_A => \&callback2,
              DISCARD_B => \&callback3,
              CHANGE    => \&callback4,
          },
          \&key_generator,
          @extra_args,
      );
  
  
  =head1 INTRODUCTION
  
  (by Mark-Jason Dominus)
  
  I once read an article written by the authors of C<diff>; they said
  that they worked very hard on the algorithm until they found the
  right one.
  
  I think what they ended up using (and I hope someone will correct me,
  because I am not very confident about this) was the `longest common
  subsequence' method.  In the LCS problem, you have two sequences of
  items:
  
      a b c d f g h j q z
  
      a b c d e f g i j k r x y z
  
  and you want to find the longest sequence of items that is present in
  both original sequences in the same order.  That is, you want to find
  a new sequence I<S> which can be obtained from the first sequence by
  deleting some items, and from the second sequence by deleting other
  items.  You also want I<S> to be as long as possible.  In this case I<S>
  is
  
      a b c d f g j z
  
  From there it's only a small step to get diff-like output:
  
      e   h i   k   q r x y
      +   - +   +   - + + +
  
  This module solves the LCS problem.  It also includes a canned function
  to generate C<diff>-like output.
  
  It might seem from the example above that the LCS of two sequences is
  always pretty obvious, but that's not always the case, especially when
  the two sequences have many repeated elements.  For example, consider
  
      a x b y c z p d q
      a b c a x b y c z
  
  A naive approach might start by matching up the C<a> and C<b> that
  appear at the beginning of each sequence, like this:
  
      a x b y c         z p d q
      a   b   c a b y c z
  
  This finds the common subsequence C<a b c z>.  But actually, the LCS
  is C<a x b y c z>:
  
            a x b y c z p d q
      a b c a x b y c z
  
  or
  
      a       x b y c z p d q
      a b c a x b y c z
  
  =head1 USAGE
  
  (See also the README file and several example
  scripts include with this module.)
  
  This module now provides an object-oriented interface that uses less
  memory and is easier to use than most of the previous procedural
  interfaces.  It also still provides several exportable functions.  We'll
  deal with these in ascending order of difficulty:  C<LCS>,
  C<LCS_length>, C<LCSidx>, OO interface, C<prepare>, C<diff>, C<sdiff>,
  C<traverse_sequences>, and C<traverse_balanced>.
  
  =head2 C<LCS>
  
  Given references to two lists of items, LCS returns an array containing
  their longest common subsequence.  In scalar context, it returns a
  reference to such a list.
  
      @lcs    = LCS( \@seq1, \@seq2 );
      $lcsref = LCS( \@seq1, \@seq2 );
  
  C<LCS> may be passed an optional third parameter; this is a CODE
  reference to a key generation function.  See L</KEY GENERATION
  FUNCTIONS>.
  
      @lcs    = LCS( \@seq1, \@seq2, \&keyGen, @args );
      $lcsref = LCS( \@seq1, \@seq2, \&keyGen, @args );
  
  Additional parameters, if any, will be passed to the key generation
  routine.
  
  =head2 C<LCS_length>
  
  This is just like C<LCS> except it only returns the length of the
  longest common subsequence.  This provides a performance gain of about
  9% compared to C<LCS>.
  
  =head2 C<LCSidx>
  
  Like C<LCS> except it returns references to two arrays.  The first array
  contains the indices into @seq1 where the LCS items are located.  The
  second array contains the indices into @seq2 where the LCS items are located.
  
  Therefore, the following three lists will contain the same values:
  
      my( $idx1, $idx2 ) = LCSidx( \@seq1, \@seq2 );
      my @list1 = @seq1[ @$idx1 ];
      my @list2 = @seq2[ @$idx2 ];
      my @list3 = LCS( \@seq1, \@seq2 );
  
  =head2 C<new>
  
      $diff = Algorithm::Diff->new( \@seq1, \@seq2 );
      $diff = Algorithm::Diff->new( \@seq1, \@seq2, \%opts );
  
  C<new> computes the smallest set of additions and deletions necessary
  to turn the first sequence into the second and compactly records them
  in the object.
  
  You use the object to iterate over I<hunks>, where each hunk represents
  a contiguous section of items which should be added, deleted, replaced,
  or left unchanged.
  
  The following summary of all of the methods looks a lot like Perl code
  but some of the symbols have different meanings:
  
      [ ]     Encloses optional arguments
      :       Is followed by the default value for an optional argument
      |       Separates alternate return results
  
  Method summary:
  
      $obj        = Algorithm::Diff->new( \@seq1, \@seq2, [ \%opts ] );
      $pos        = $obj->Next(  [ $count : 1 ] );
      $revPos     = $obj->Prev(  [ $count : 1 ] );
      $obj        = $obj->Reset( [ $pos : 0 ] );
      $copy       = $obj->Copy(  [ $pos, [ $newBase ] ] );
      $oldBase    = $obj->Base(  [ $newBase ] );
  
  Note that all of the following methods C<die> if used on an object that
  is "reset" (not currently pointing at any hunk).
  
      $bits       = $obj->Diff(  );
      @items|$cnt = $obj->Same(  );
      @items|$cnt = $obj->Items( $seqNum );
      @idxs |$cnt = $obj->Range( $seqNum, [ $base ] );
      $minIdx     = $obj->Min(   $seqNum, [ $base ] );
      $maxIdx     = $obj->Max(   $seqNum, [ $base ] );
      @values     = $obj->Get(   @names );
  
  Passing in C<undef> for an optional argument is always treated the same
  as if no argument were passed in.
  
  =over 4
  
  =item C<Next>
  
      $pos = $diff->Next();    # Move forward 1 hunk
      $pos = $diff->Next( 2 ); # Move forward 2 hunks
      $pos = $diff->Next(-5);  # Move backward 5 hunks
  
  C<Next> moves the object to point at the next hunk.  The object starts
  out "reset", which means it isn't pointing at any hunk.  If the object
  is reset, then C<Next()> moves to the first hunk.
  
  C<Next> returns a true value iff the move didn't go past the last hunk.
  So C<Next(0)> will return true iff the object is not reset.
  
  Actually, C<Next> returns the object's new position, which is a number
  between 1 and the number of hunks (inclusive), or returns a false value.
  
  =item C<Prev>
  
  C<Prev($N)> is almost identical to C<Next(-$N)>; it moves to the $Nth
  previous hunk.  On a 'reset' object, C<Prev()> [and C<Next(-1)>] move
  to the last hunk.
  
  The position returned by C<Prev> is relative to the I<end> of the
  hunks; -1 for the last hunk, -2 for the second-to-last, etc.
  
  =item C<Reset>
  
      $diff->Reset();     # Reset the object's position
      $diff->Reset($pos); # Move to the specified hunk
      $diff->Reset(1);    # Move to the first hunk
      $diff->Reset(-1);   # Move to the last hunk
  
  C<Reset> returns the object, so, for example, you could use
  C<< $diff->Reset()->Next(-1) >> to get the number of hunks.
  
  =item C<Copy>
  
      $copy = $diff->Copy( $newPos, $newBase );
  
  C<Copy> returns a copy of the object.  The copy and the original object
  share most of their data, so making copies takes very little memory.
  The copy maintains its own position (separate from the original), which
  is the main purpose of copies.  It also maintains its own base.
  
  By default, the copy's position starts out the same as the original
  object's position.  But C<Copy> takes an optional first argument to set the
  new position, so the following three snippets are equivalent:
  
      $copy = $diff->Copy($pos);
  
      $copy = $diff->Copy();
      $copy->Reset($pos);
  
      $copy = $diff->Copy()->Reset($pos);
  
  C<Copy> takes an optional second argument to set the base for
  the copy.  If you wish to change the base of the copy but leave
  the position the same as in the original, here are two
  equivalent ways:
  
      $copy = $diff->Copy();
      $copy->Base( 0 );
  
      $copy = $diff->Copy(undef,0);
  
  Here are two equivalent way to get a "reset" copy:
  
      $copy = $diff->Copy(0);
  
      $copy = $diff->Copy()->Reset();
  
  =item C<Diff>
  
      $bits = $obj->Diff();
  
  C<Diff> returns a true value iff the current hunk contains items that are
  different between the two sequences.  It actually returns one of the
  follow 4 values:
  
  =over 4
  
  =item Z<>3
  
  C<3==(1|2)>.  This hunk contains items from @seq1 and the items
  from @seq2 that should replace them.  Both sequence 1 and 2
  contain changed items so both the 1 and 2 bits are set.
  
  =item Z<>2
  
  This hunk only contains items from @seq2 that should be inserted (not
  items from @seq1).  Only sequence 2 contains changed items so only the 2
  bit is set.
  
  =item Z<>1
  
  This hunk only contains items from @seq1 that should be deleted (not
  items from @seq2).  Only sequence 1 contains changed items so only the 1
  bit is set.
  
  =item Z<>0
  
  This means that the items in this hunk are the same in both sequences.
  Neither sequence 1 nor 2 contain changed items so neither the 1 nor the
  2 bits are set.
  
  =back
  
  =item C<Same>
  
  C<Same> returns a true value iff the current hunk contains items that
  are the same in both sequences.  It actually returns the list of items
  if they are the same or an empty list if they aren't.  In a scalar
  context, it returns the size of the list.
  
  =item C<Items>
  
      $count = $diff->Items(2);
      @items = $diff->Items($seqNum);
  
  C<Items> returns the (number of) items from the specified sequence that
  are part of the current hunk.
  
  If the current hunk contains only insertions, then
  C<< $diff->Items(1) >> will return an empty list (0 in a scalar context).
  If the current hunk contains only deletions, then C<< $diff->Items(2) >>
  will return an empty list (0 in a scalar context).
  
  If the hunk contains replacements, then both C<< $diff->Items(1) >> and
  C<< $diff->Items(2) >> will return different, non-empty lists.
  
  Otherwise, the hunk contains identical items and all of the following
  will return the same lists:
  
      @items = $diff->Items(1);
      @items = $diff->Items(2);
      @items = $diff->Same();
  
  =item C<Range>
  
      $count = $diff->Range( $seqNum );
      @indices = $diff->Range( $seqNum );
      @indices = $diff->Range( $seqNum, $base );
  
  C<Range> is like C<Items> except that it returns a list of I<indices> to
  the items rather than the items themselves.  By default, the index of
  the first item (in each sequence) is 0 but this can be changed by
  calling the C<Base> method.  So, by default, the following two snippets
  return the same lists:
  
      @list = $diff->Items(2);
      @list = @seq2[ $diff->Range(2) ];
  
  You can also specify the base to use as the second argument.  So the
  following two snippets I<always> return the same lists:
  
      @list = $diff->Items(1);
      @list = @seq1[ $diff->Range(1,0) ];
  
  =item C<Base>
  
      $curBase = $diff->Base();
      $oldBase = $diff->Base($newBase);
  
  C<Base> sets and/or returns the current base (usually 0 or 1) that is
  used when you request range information.  The base defaults to 0 so
  that range information is returned as array indices.  You can set the
  base to 1 if you want to report traditional line numbers instead.
  
  =item C<Min>
  
      $min1 = $diff->Min(1);
      $min = $diff->Min( $seqNum, $base );
  
  C<Min> returns the first value that C<Range> would return (given the
  same arguments) or returns C<undef> if C<Range> would return an empty
  list.
  
  =item C<Max>
  
  C<Max> returns the last value that C<Range> would return or C<undef>.
  
  =item C<Get>
  
      ( $n, $x, $r ) = $diff->Get(qw( min1 max1 range1 ));
      @values = $diff->Get(qw( 0min2 1max2 range2 same base ));
  
  C<Get> returns one or more scalar values.  You pass in a list of the
  names of the values you want returned.  Each name must match one of the
  following regexes:
  
      /^(-?\d+)?(min|max)[12]$/i
      /^(range[12]|same|diff|base)$/i
  
  The 1 or 2 after a name says which sequence you want the information
  for (and where allowed, it is required).  The optional number before
  "min" or "max" is the base to use.  So the following equalities hold:
  
      $diff->Get('min1') == $diff->Min(1)
      $diff->Get('0min2') == $diff->Min(2,0)
  
  Using C<Get> in a scalar context when you've passed in more than one
  name is a fatal error (C<die> is called).
  
  =back
  
  =head2 C<prepare>
  
  Given a reference to a list of items, C<prepare> returns a reference
  to a hash which can be used when comparing this sequence to other
  sequences with C<LCS> or C<LCS_length>.
  
      $prep = prepare( \@seq1 );
      for $i ( 0 .. 10_000 )
      {
          @lcs = LCS( $prep, $seq[$i] );
          # do something useful with @lcs
      }
  
  C<prepare> may be passed an optional third parameter; this is a CODE
  reference to a key generation function.  See L</KEY GENERATION
  FUNCTIONS>.
  
      $prep = prepare( \@seq1, \&keyGen );
      for $i ( 0 .. 10_000 )
      {
          @lcs = LCS( $seq[$i], $prep, \&keyGen );
          # do something useful with @lcs
      }
  
  Using C<prepare> provides a performance gain of about 50% when calling LCS
  many times compared with not preparing.
  
  =head2 C<diff>
  
      @diffs     = diff( \@seq1, \@seq2 );
      $diffs_ref = diff( \@seq1, \@seq2 );
  
  C<diff> computes the smallest set of additions and deletions necessary
  to turn the first sequence into the second, and returns a description
  of these changes.  The description is a list of I<hunks>; each hunk
  represents a contiguous section of items which should be added,
  deleted, or replaced.  (Hunks containing unchanged items are not
  included.)
  
  The return value of C<diff> is a list of hunks, or, in scalar context, a
  reference to such a list.  If there are no differences, the list will be
  empty.
  
  Here is an example.  Calling C<diff> for the following two sequences:
  
      a b c e h j l m n p
      b c d e f j k l m r s t
  
  would produce the following list:
  
      (
        [ [ '-', 0, 'a' ] ],
  
        [ [ '+', 2, 'd' ] ],
  
        [ [ '-', 4, 'h' ],
          [ '+', 4, 'f' ] ],
  
        [ [ '+', 6, 'k' ] ],
  
        [ [ '-',  8, 'n' ],
          [ '-',  9, 'p' ],
          [ '+',  9, 'r' ],
          [ '+', 10, 's' ],
          [ '+', 11, 't' ] ],
      )
  
  There are five hunks here.  The first hunk says that the C<a> at
  position 0 of the first sequence should be deleted (C<->).  The second
  hunk says that the C<d> at position 2 of the second sequence should
  be inserted (C<+>).  The third hunk says that the C<h> at position 4
  of the first sequence should be removed and replaced with the C<f>
  from position 4 of the second sequence.  And so on.
  
  C<diff> may be passed an optional third parameter; this is a CODE
  reference to a key generation function.  See L</KEY GENERATION
  FUNCTIONS>.
  
  Additional parameters, if any, will be passed to the key generation
  routine.
  
  =head2 C<sdiff>
  
      @sdiffs     = sdiff( \@seq1, \@seq2 );
      $sdiffs_ref = sdiff( \@seq1, \@seq2 );
  
  C<sdiff> computes all necessary components to show two sequences
  and their minimized differences side by side, just like the
  Unix-utility I<sdiff> does:
  
      same             same
      before     |     after
      old        <     -
      -          >     new
  
  It returns a list of array refs, each pointing to an array of
  display instructions. In scalar context it returns a reference
  to such a list. If there are no differences, the list will have one
  entry per item, each indicating that the item was unchanged.
  
  Display instructions consist of three elements: A modifier indicator
  (C<+>: Element added, C<->: Element removed, C<u>: Element unmodified,
  C<c>: Element changed) and the value of the old and new elements, to
  be displayed side-by-side.
  
  An C<sdiff> of the following two sequences:
  
      a b c e h j l m n p
      b c d e f j k l m r s t
  
  results in
  
      ( [ '-', 'a', ''  ],
        [ 'u', 'b', 'b' ],
        [ 'u', 'c', 'c' ],
        [ '+', '',  'd' ],
        [ 'u', 'e', 'e' ],
        [ 'c', 'h', 'f' ],
        [ 'u', 'j', 'j' ],
        [ '+', '',  'k' ],
        [ 'u', 'l', 'l' ],
        [ 'u', 'm', 'm' ],
        [ 'c', 'n', 'r' ],
        [ 'c', 'p', 's' ],
        [ '+', '',  't' ],
      )
  
  C<sdiff> may be passed an optional third parameter; this is a CODE
  reference to a key generation function.  See L</KEY GENERATION
  FUNCTIONS>.
  
  Additional parameters, if any, will be passed to the key generation
  routine.
  
  =head2 C<compact_diff>
  
  C<compact_diff> is much like C<sdiff> except it returns a much more
  compact description consisting of just one flat list of indices.  An
  example helps explain the format:
  
      my @a = qw( a b c   e  h j   l m n p      );
      my @b = qw(   b c d e f  j k l m    r s t );
      @cdiff = compact_diff( \@a, \@b );
      # Returns:
      #   @a      @b       @a       @b
      #  start   start   values   values
      (    0,      0,   #       =
           0,      0,   #    a  !
           1,      0,   #  b c  =  b c
           3,      2,   #       !  d
           3,      3,   #    e  =  e
           4,      4,   #    f  !  h
           5,      5,   #    j  =  j
           6,      6,   #       !  k
           6,      7,   #  l m  =  l m
           8,      9,   #  n p  !  r s t
          10,     12,   #
      );
  
  The 0th, 2nd, 4th, etc. entries are all indices into @seq1 (@a in the
  above example) indicating where a hunk begins.  The 1st, 3rd, 5th, etc.
  entries are all indices into @seq2 (@b in the above example) indicating
  where the same hunk begins.
  
  So each pair of indices (except the last pair) describes where a hunk
  begins (in each sequence).  Since each hunk must end at the item just
  before the item that starts the next hunk, the next pair of indices can
  be used to determine where the hunk ends.
  
  So, the first 4 entries (0..3) describe the first hunk.  Entries 0 and 1
  describe where the first hunk begins (and so are always both 0).
  Entries 2 and 3 describe where the next hunk begins, so subtracting 1
  from each tells us where the first hunk ends.  That is, the first hunk
  contains items C<$diff[0]> through C<$diff[2] - 1> of the first sequence
  and contains items C<$diff[1]> through C<$diff[3] - 1> of the second
  sequence.
  
  In other words, the first hunk consists of the following two lists of items:
  
                 #  1st pair     2nd pair
                 # of indices   of indices
      @list1 = @a[ $cdiff[0] .. $cdiff[2]-1 ];
      @list2 = @b[ $cdiff[1] .. $cdiff[3]-1 ];
                 # Hunk start   Hunk end
  
  Note that the hunks will always alternate between those that are part of
  the LCS (those that contain unchanged items) and those that contain
  changes.  This means that all we need to be told is whether the first
  hunk is a 'same' or 'diff' hunk and we can determine which of the other
  hunks contain 'same' items or 'diff' items.
  
  By convention, we always make the first hunk contain unchanged items.
  So the 1st, 3rd, 5th, etc. hunks (all odd-numbered hunks if you start
  counting from 1) all contain unchanged items.  And the 2nd, 4th, 6th,
  etc. hunks (all even-numbered hunks if you start counting from 1) all
  contain changed items.
  
  Since @a and @b don't begin with the same value, the first hunk in our
  example is empty (otherwise we'd violate the above convention).  Note
  that the first 4 index values in our example are all zero.  Plug these
  values into our previous code block and we get:
  
      @hunk1a = @a[ 0 .. 0-1 ];
      @hunk1b = @b[ 0 .. 0-1 ];
  
  And C<0..-1> returns the empty list.
  
  Move down one pair of indices (2..5) and we get the offset ranges for
  the second hunk, which contains changed items.
  
  Since C<@diff[2..5]> contains (0,0,1,0) in our example, the second hunk
  consists of these two lists of items:
  
          @hunk2a = @a[ $cdiff[2] .. $cdiff[4]-1 ];
          @hunk2b = @b[ $cdiff[3] .. $cdiff[5]-1 ];
      # or
          @hunk2a = @a[ 0 .. 1-1 ];
          @hunk2b = @b[ 0 .. 0-1 ];
      # or
          @hunk2a = @a[ 0 .. 0 ];
          @hunk2b = @b[ 0 .. -1 ];
      # or
          @hunk2a = ( 'a' );
          @hunk2b = ( );
  
  That is, we would delete item 0 ('a') from @a.
  
  Since C<@diff[4..7]> contains (1,0,3,2) in our example, the third hunk
  consists of these two lists of items:
  
          @hunk3a = @a[ $cdiff[4] .. $cdiff[6]-1 ];
          @hunk3a = @b[ $cdiff[5] .. $cdiff[7]-1 ];
      # or
          @hunk3a = @a[ 1 .. 3-1 ];
          @hunk3a = @b[ 0 .. 2-1 ];
      # or
          @hunk3a = @a[ 1 .. 2 ];
          @hunk3a = @b[ 0 .. 1 ];
      # or
          @hunk3a = qw( b c );
          @hunk3a = qw( b c );
  
  Note that this third hunk contains unchanged items as our convention demands.
  
  You can continue this process until you reach the last two indices,
  which will always be the number of items in each sequence.  This is
  required so that subtracting one from each will give you the indices to
  the last items in each sequence.
  
  =head2 C<traverse_sequences>
  
  C<traverse_sequences> used to be the most general facility provided by
  this module (the new OO interface is more powerful and much easier to
  use).
  
  Imagine that there are two arrows.  Arrow A points to an element of
  sequence A, and arrow B points to an element of the sequence B.
  Initially, the arrows point to the first elements of the respective
  sequences.  C<traverse_sequences> will advance the arrows through the
  sequences one element at a time, calling an appropriate user-specified
  callback function before each advance.  It will advance the arrows in
  such a way that if there are equal elements C<$A[$i]> and C<$B[$j]>
  which are equal and which are part of the LCS, there will be some moment
  during the execution of C<traverse_sequences> when arrow A is pointing
  to C<$A[$i]> and arrow B is pointing to C<$B[$j]>.  When this happens,
  C<traverse_sequences> will call the C<MATCH> callback function and then
  it will advance both arrows.
  
  Otherwise, one of the arrows is pointing to an element of its sequence
  that is not part of the LCS.  C<traverse_sequences> will advance that
  arrow and will call the C<DISCARD_A> or the C<DISCARD_B> callback,
  depending on which arrow it advanced.  If both arrows point to elements
  that are not part of the LCS, then C<traverse_sequences> will advance
  one of them and call the appropriate callback, but it is not specified
  which it will call.
  
  The arguments to C<traverse_sequences> are the two sequences to
  traverse, and a hash which specifies the callback functions, like this:
  
      traverse_sequences(
          \@seq1, \@seq2,
          {   MATCH => $callback_1,
              DISCARD_A => $callback_2,
              DISCARD_B => $callback_3,
          }
      );
  
  Callbacks for MATCH, DISCARD_A, and DISCARD_B are invoked with at least
  the indices of the two arrows as their arguments.  They are not expected
  to return any values.  If a callback is omitted from the table, it is
  not called.
  
  Callbacks for A_FINISHED and B_FINISHED are invoked with at least the
  corresponding index in A or B.
  
  If arrow A reaches the end of its sequence, before arrow B does,
  C<traverse_sequences> will call the C<A_FINISHED> callback when it
  advances arrow B, if there is such a function; if not it will call
  C<DISCARD_B> instead.  Similarly if arrow B finishes first.
  C<traverse_sequences> returns when both arrows are at the ends of their
  respective sequences.  It returns true on success and false on failure.
  At present there is no way to fail.
  
  C<traverse_sequences> may be passed an optional fourth parameter; this
  is a CODE reference to a key generation function.  See L</KEY GENERATION
  FUNCTIONS>.
  
  Additional parameters, if any, will be passed to the key generation function.
  
  If you want to pass additional parameters to your callbacks, but don't
  need a custom key generation function, you can get the default by
  passing undef:
  
      traverse_sequences(
          \@seq1, \@seq2,
          {   MATCH => $callback_1,
              DISCARD_A => $callback_2,
              DISCARD_B => $callback_3,
          },
          undef,     # default key-gen
          $myArgument1,
          $myArgument2,
          $myArgument3,
      );
  
  C<traverse_sequences> does not have a useful return value; you are
  expected to plug in the appropriate behavior with the callback
  functions.
  
  =head2 C<traverse_balanced>
  
  C<traverse_balanced> is an alternative to C<traverse_sequences>. It
  uses a different algorithm to iterate through the entries in the
  computed LCS. Instead of sticking to one side and showing element changes
  as insertions and deletions only, it will jump back and forth between
  the two sequences and report I<changes> occurring as deletions on one
  side followed immediately by an insertion on the other side.
  
  In addition to the C<DISCARD_A>, C<DISCARD_B>, and C<MATCH> callbacks
  supported by C<traverse_sequences>, C<traverse_balanced> supports
  a C<CHANGE> callback indicating that one element got C<replaced> by another:
  
      traverse_balanced(
          \@seq1, \@seq2,
          {   MATCH => $callback_1,
              DISCARD_A => $callback_2,
              DISCARD_B => $callback_3,
              CHANGE    => $callback_4,
          }
      );
  
  If no C<CHANGE> callback is specified, C<traverse_balanced>
  will map C<CHANGE> events to C<DISCARD_A> and C<DISCARD_B> actions,
  therefore resulting in a similar behaviour as C<traverse_sequences>
  with different order of events.
  
  C<traverse_balanced> might be a bit slower than C<traverse_sequences>,
  noticeable only while processing huge amounts of data.
  
  The C<sdiff> function of this module is implemented as call to
  C<traverse_balanced>.
  
  C<traverse_balanced> does not have a useful return value; you are expected to
  plug in the appropriate behavior with the callback functions.
  
  =head1 KEY GENERATION FUNCTIONS
  
  Most of the functions accept an optional extra parameter.  This is a
  CODE reference to a key generating (hashing) function that should return
  a string that uniquely identifies a given element.  It should be the
  case that if two elements are to be considered equal, their keys should
  be the same (and the other way around).  If no key generation function
  is provided, the key will be the element as a string.
  
  By default, comparisons will use "eq" and elements will be turned into keys
  using the default stringizing operator '""'.
  
  Where this is important is when you're comparing something other than
  strings.  If it is the case that you have multiple different objects
  that should be considered to be equal, you should supply a key
  generation function. Otherwise, you have to make sure that your arrays
  contain unique references.
  
  For instance, consider this example:
  
      package Person;
  
      sub new
      {
          my $package = shift;
          return bless { name => '', ssn => '', @_ }, $package;
      }
  
      sub clone
      {
          my $old = shift;
          my $new = bless { %$old }, ref($old);
      }
  
      sub hash
      {
          return shift()->{'ssn'};
      }
  
      my $person1 = Person->new( name => 'Joe', ssn => '123-45-6789' );
      my $person2 = Person->new( name => 'Mary', ssn => '123-47-0000' );
      my $person3 = Person->new( name => 'Pete', ssn => '999-45-2222' );
      my $person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' );
      my $person5 = Person->new( name => 'Frank', ssn => '000-45-9999' );
  
  If you did this:
  
      my $array1 = [ $person1, $person2, $person4 ];
      my $array2 = [ $person1, $person3, $person4, $person5 ];
      Algorithm::Diff::diff( $array1, $array2 );
  
  everything would work out OK (each of the objects would be converted
  into a string like "Person=HASH(0x82425b0)" for comparison).
  
  But if you did this:
  
      my $array1 = [ $person1, $person2, $person4 ];
      my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
      Algorithm::Diff::diff( $array1, $array2 );
  
  $person4 and $person4->clone() (which have the same name and SSN)
  would be seen as different objects. If you wanted them to be considered
  equivalent, you would have to pass in a key generation function:
  
      my $array1 = [ $person1, $person2, $person4 ];
      my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
      Algorithm::Diff::diff( $array1, $array2, \&Person::hash );
  
  This would use the 'ssn' field in each Person as a comparison key, and
  so would consider $person4 and $person4->clone() as equal.
  
  You may also pass additional parameters to the key generation function
  if you wish.
  
  =head1 ERROR CHECKING
  
  If you pass these routines a non-reference and they expect a reference,
  they will die with a message.
  
  =head1 AUTHOR
  
  This version released by Tye McQueen (http://perlmonks.org/?node=tye).
  
  =head1 LICENSE
  
  Parts Copyright (c) 2000-2004 Ned Konz.  All rights reserved.
  Parts by Tye McQueen.
  
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl.
  
  =head1 MAILING LIST
  
  Mark-Jason still maintains a mailing list.  To join a low-volume mailing
  list for announcements related to diff and Algorithm::Diff, send an
  empty mail message to mjd-perl-diff-request@plover.com.
  
  =head1 CREDITS
  
  Versions through 0.59 (and much of this documentation) were written by:
  
  Mark-Jason Dominus
  
  This version borrows some documentation and routine names from
  Mark-Jason's, but Diff.pm's code was completely replaced.
  
  This code was adapted from the Smalltalk code of Mario Wolczko
  <mario@wolczko.com>, which is available at
  ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st
  
  C<sdiff> and C<traverse_balanced> were written by Mike Schilli
  <m@perlmeister.com>.
  
  The algorithm is that described in
  I<A Fast Algorithm for Computing Longest Common Subsequences>,
  CACM, vol.20, no.5, pp.350-353, May 1977, with a few
  minor improvements to improve the speed.
  
  Much work was done by Ned Konz (perl@bike-nomad.com).
  
  The OO interface and some other changes are by Tye McQueen.
  
  =cut
ALGORITHM_DIFF

$fatpacked{"Pod/Escapes.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'POD_ESCAPES';
  package Pod::Escapes;
  use strict;
  use warnings;
  use 5.006;
  
  use vars qw(
    %Code2USASCII
    %Name2character
    %Name2character_number
    %Latin1Code_to_fallback
    %Latin1Char_to_fallback
    $FAR_CHAR
    $FAR_CHAR_NUMBER
    $NOT_ASCII
    @ISA $VERSION @EXPORT_OK %EXPORT_TAGS
  );
  
  require Exporter;
  @ISA = ('Exporter');
  $VERSION = '1.07';
  @EXPORT_OK = qw(
    %Code2USASCII
    %Name2character
    %Name2character_number
    %Latin1Code_to_fallback
    %Latin1Char_to_fallback
    e2char
    e2charnum
  );
  %EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
  
  #==========================================================================
  
  $FAR_CHAR = "?" unless defined $FAR_CHAR;
  $FAR_CHAR_NUMBER = ord($FAR_CHAR) unless defined $FAR_CHAR_NUMBER;
  
  $NOT_ASCII = 'A' ne chr(65) unless defined $NOT_ASCII;
  
  #--------------------------------------------------------------------------
  sub e2char {
    my $in = $_[0];
    return undef unless defined $in and length $in;
    
    # Convert to decimal:
    if($in =~ m/^(0[0-7]*)$/s ) {
      $in = oct $in;
    } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
      $in = hex $1;
    } # else it's decimal, or named
  
    if($in =~ m/^\d+$/s) {
      if($] < 5.007  and  $in > 255) { # can't be trusted with Unicode
        return $FAR_CHAR;
      } elsif ($] >= 5.007003) {
        return chr(utf8::unicode_to_native($in));
      } elsif ($NOT_ASCII) {
        return $Code2USASCII{$in} # so "65" => "A" everywhere
               || $Latin1Code_to_fallback{$in} # Fallback.
               || $FAR_CHAR; # Fall further back
      } else {
        return chr($in);
      }
    } else {
      return $Name2character{$in}; # returns undef if unknown
    }
  }
  
  #--------------------------------------------------------------------------
  sub e2charnum {
    my $in = $_[0];
    return undef unless defined $in and length $in;
    
    # Convert to decimal:
    if($in =~ m/^(0[0-7]*)$/s ) {
      $in = oct $in;
    } elsif($in =~ m/^0?x([0-9a-fA-F]+)$/s ) {
      $in = hex $1;
    } # else it's decimal, or named
  
    if($in =~ m/^[0-9]+$/s) {
      return 0 + $in;
    } else {
      return $Name2character_number{$in}; # returns undef if unknown
    }
  }
  
  #--------------------------------------------------------------------------
  
  %Code2USASCII = (
  # mostly generated by
  #  perl -e "printf qq{  \x25 3s, '\x25s',\n}, $_, chr($_) foreach (32 .. 126)"
     32, ' ',
     33, '!',
     34, '"',
     35, '#',
     36, '$',
     37, '%',
     38, '&',
     39, "'", #!
     40, '(',
     41, ')',
     42, '*',
     43, '+',
     44, ',',
     45, '-',
     46, '.',
     47, '/',
     48, '0',
     49, '1',
     50, '2',
     51, '3',
     52, '4',
     53, '5',
     54, '6',
     55, '7',
     56, '8',
     57, '9',
     58, ':',
     59, ';',
     60, '<',
     61, '=',
     62, '>',
     63, '?',
     64, '@',
     65, 'A',
     66, 'B',
     67, 'C',
     68, 'D',
     69, 'E',
     70, 'F',
     71, 'G',
     72, 'H',
     73, 'I',
     74, 'J',
     75, 'K',
     76, 'L',
     77, 'M',
     78, 'N',
     79, 'O',
     80, 'P',
     81, 'Q',
     82, 'R',
     83, 'S',
     84, 'T',
     85, 'U',
     86, 'V',
     87, 'W',
     88, 'X',
     89, 'Y',
     90, 'Z',
     91, '[',
     92, "\\", #!
     93, ']',
     94, '^',
     95, '_',
     96, '`',
     97, 'a',
     98, 'b',
     99, 'c',
    100, 'd',
    101, 'e',
    102, 'f',
    103, 'g',
    104, 'h',
    105, 'i',
    106, 'j',
    107, 'k',
    108, 'l',
    109, 'm',
    110, 'n',
    111, 'o',
    112, 'p',
    113, 'q',
    114, 'r',
    115, 's',
    116, 't',
    117, 'u',
    118, 'v',
    119, 'w',
    120, 'x',
    121, 'y',
    122, 'z',
    123, '{',
    124, '|',
    125, '}',
    126, '~',
  );
  
  #--------------------------------------------------------------------------
  
  %Latin1Code_to_fallback = ();
  @Latin1Code_to_fallback{0xA0 .. 0xFF} = (
  # Copied from Text/Unidecode/x00.pm:
  
  ' ', qq{!}, qq{C/}, 'PS', qq{\$?}, qq{Y=}, qq{|}, 'SS', qq{"}, qq{(c)}, 'a', qq{<<}, qq{!}, "", qq{(r)}, qq{-},
  'deg', qq{+-}, '2', '3', qq{'}, 'u', 'P', qq{*}, qq{,}, '1', 'o', qq{>>}, qq{1/4}, qq{1/2}, qq{3/4}, qq{?},
  'A', 'A', 'A', 'A', 'A', 'A', 'AE', 'C', 'E', 'E', 'E', 'E', 'I', 'I', 'I', 'I',
  'D', 'N', 'O', 'O', 'O', 'O', 'O', 'x', 'O', 'U', 'U', 'U', 'U', 'U', 'Th', 'ss',
  'a', 'a', 'a', 'a', 'a', 'a', 'ae', 'c', 'e', 'e', 'e', 'e', 'i', 'i', 'i', 'i',
  'd', 'n', 'o', 'o', 'o', 'o', 'o', qq{/}, 'o', 'u', 'u', 'u', 'u', 'y', 'th', 'y',
  
  );
  
  {
    # Now stuff %Latin1Char_to_fallback:
    %Latin1Char_to_fallback = ();
    my($k,$v);
    while( ($k,$v) = each %Latin1Code_to_fallback) {
      $Latin1Char_to_fallback{chr $k} = $v;
      #print chr($k), ' => ', $v, "\n";
    }
  }
  
  #--------------------------------------------------------------------------
  
  %Name2character_number = (
   # General XML/XHTML:
   'lt'   => 60,
   'gt'   => 62,
   'quot' => 34,
   'amp'  => 38,
   'apos' => 39,
  
   # POD-specific:
   'sol'    => 47,
   'verbar' => 124,
  
   'lchevron' => 171, # legacy for laquo
   'rchevron' => 187, # legacy for raquo
  
   # Remember, grave looks like \ (as in virtu\)
   #           acute looks like / (as in re/sume/)
   #           circumflex looks like ^ (as in papier ma^che/)
   #           umlaut/dieresis looks like " (as in nai"ve, Chloe")
  
   # From the XHTML 1 .ent files:
   'nbsp'     , 160,
   'iexcl'    , 161,
   'cent'     , 162,
   'pound'    , 163,
   'curren'   , 164,
   'yen'      , 165,
   'brvbar'   , 166,
   'sect'     , 167,
   'uml'      , 168,
   'copy'     , 169,
   'ordf'     , 170,
   'laquo'    , 171,
   'not'      , 172,
   'shy'      , 173,
   'reg'      , 174,
   'macr'     , 175,
   'deg'      , 176,
   'plusmn'   , 177,
   'sup2'     , 178,
   'sup3'     , 179,
   'acute'    , 180,
   'micro'    , 181,
   'para'     , 182,
   'middot'   , 183,
   'cedil'    , 184,
   'sup1'     , 185,
   'ordm'     , 186,
   'raquo'    , 187,
   'frac14'   , 188,
   'frac12'   , 189,
   'frac34'   , 190,
   'iquest'   , 191,
   'Agrave'   , 192,
   'Aacute'   , 193,
   'Acirc'    , 194,
   'Atilde'   , 195,
   'Auml'     , 196,
   'Aring'    , 197,
   'AElig'    , 198,
   'Ccedil'   , 199,
   'Egrave'   , 200,
   'Eacute'   , 201,
   'Ecirc'    , 202,
   'Euml'     , 203,
   'Igrave'   , 204,
   'Iacute'   , 205,
   'Icirc'    , 206,
   'Iuml'     , 207,
   'ETH'      , 208,
   'Ntilde'   , 209,
   'Ograve'   , 210,
   'Oacute'   , 211,
   'Ocirc'    , 212,
   'Otilde'   , 213,
   'Ouml'     , 214,
   'times'    , 215,
   'Oslash'   , 216,
   'Ugrave'   , 217,
   'Uacute'   , 218,
   'Ucirc'    , 219,
   'Uuml'     , 220,
   'Yacute'   , 221,
   'THORN'    , 222,
   'szlig'    , 223,
   'agrave'   , 224,
   'aacute'   , 225,
   'acirc'    , 226,
   'atilde'   , 227,
   'auml'     , 228,
   'aring'    , 229,
   'aelig'    , 230,
   'ccedil'   , 231,
   'egrave'   , 232,
   'eacute'   , 233,
   'ecirc'    , 234,
   'euml'     , 235,
   'igrave'   , 236,
   'iacute'   , 237,
   'icirc'    , 238,
   'iuml'     , 239,
   'eth'      , 240,
   'ntilde'   , 241,
   'ograve'   , 242,
   'oacute'   , 243,
   'ocirc'    , 244,
   'otilde'   , 245,
   'ouml'     , 246,
   'divide'   , 247,
   'oslash'   , 248,
   'ugrave'   , 249,
   'uacute'   , 250,
   'ucirc'    , 251,
   'uuml'     , 252,
   'yacute'   , 253,
   'thorn'    , 254,
   'yuml'     , 255,
  
   'fnof'     , 402,
   'Alpha'    , 913,
   'Beta'     , 914,
   'Gamma'    , 915,
   'Delta'    , 916,
   'Epsilon'  , 917,
   'Zeta'     , 918,
   'Eta'      , 919,
   'Theta'    , 920,
   'Iota'     , 921,
   'Kappa'    , 922,
   'Lambda'   , 923,
   'Mu'       , 924,
   'Nu'       , 925,
   'Xi'       , 926,
   'Omicron'  , 927,
   'Pi'       , 928,
   'Rho'      , 929,
   'Sigma'    , 931,
   'Tau'      , 932,
   'Upsilon'  , 933,
   'Phi'      , 934,
   'Chi'      , 935,
   'Psi'      , 936,
   'Omega'    , 937,
   'alpha'    , 945,
   'beta'     , 946,
   'gamma'    , 947,
   'delta'    , 948,
   'epsilon'  , 949,
   'zeta'     , 950,
   'eta'      , 951,
   'theta'    , 952,
   'iota'     , 953,
   'kappa'    , 954,
   'lambda'   , 955,
   'mu'       , 956,
   'nu'       , 957,
   'xi'       , 958,
   'omicron'  , 959,
   'pi'       , 960,
   'rho'      , 961,
   'sigmaf'   , 962,
   'sigma'    , 963,
   'tau'      , 964,
   'upsilon'  , 965,
   'phi'      , 966,
   'chi'      , 967,
   'psi'      , 968,
   'omega'    , 969,
   'thetasym' , 977,
   'upsih'    , 978,
   'piv'      , 982,
   'bull'     , 8226,
   'hellip'   , 8230,
   'prime'    , 8242,
   'Prime'    , 8243,
   'oline'    , 8254,
   'frasl'    , 8260,
   'weierp'   , 8472,
   'image'    , 8465,
   'real'     , 8476,
   'trade'    , 8482,
   'alefsym'  , 8501,
   'larr'     , 8592,
   'uarr'     , 8593,
   'rarr'     , 8594,
   'darr'     , 8595,
   'harr'     , 8596,
   'crarr'    , 8629,
   'lArr'     , 8656,
   'uArr'     , 8657,
   'rArr'     , 8658,
   'dArr'     , 8659,
   'hArr'     , 8660,
   'forall'   , 8704,
   'part'     , 8706,
   'exist'    , 8707,
   'empty'    , 8709,
   'nabla'    , 8711,
   'isin'     , 8712,
   'notin'    , 8713,
   'ni'       , 8715,
   'prod'     , 8719,
   'sum'      , 8721,
   'minus'    , 8722,
   'lowast'   , 8727,
   'radic'    , 8730,
   'prop'     , 8733,
   'infin'    , 8734,
   'ang'      , 8736,
   'and'      , 8743,
   'or'       , 8744,
   'cap'      , 8745,
   'cup'      , 8746,
   'int'      , 8747,
   'there4'   , 8756,
   'sim'      , 8764,
   'cong'     , 8773,
   'asymp'    , 8776,
   'ne'       , 8800,
   'equiv'    , 8801,
   'le'       , 8804,
   'ge'       , 8805,
   'sub'      , 8834,
   'sup'      , 8835,
   'nsub'     , 8836,
   'sube'     , 8838,
   'supe'     , 8839,
   'oplus'    , 8853,
   'otimes'   , 8855,
   'perp'     , 8869,
   'sdot'     , 8901,
   'lceil'    , 8968,
   'rceil'    , 8969,
   'lfloor'   , 8970,
   'rfloor'   , 8971,
   'lang'     , 9001,
   'rang'     , 9002,
   'loz'      , 9674,
   'spades'   , 9824,
   'clubs'    , 9827,
   'hearts'   , 9829,
   'diams'    , 9830,
   'OElig'    , 338,
   'oelig'    , 339,
   'Scaron'   , 352,
   'scaron'   , 353,
   'Yuml'     , 376,
   'circ'     , 710,
   'tilde'    , 732,
   'ensp'     , 8194,
   'emsp'     , 8195,
   'thinsp'   , 8201,
   'zwnj'     , 8204,
   'zwj'      , 8205,
   'lrm'      , 8206,
   'rlm'      , 8207,
   'ndash'    , 8211,
   'mdash'    , 8212,
   'lsquo'    , 8216,
   'rsquo'    , 8217,
   'sbquo'    , 8218,
   'ldquo'    , 8220,
   'rdquo'    , 8221,
   'bdquo'    , 8222,
   'dagger'   , 8224,
   'Dagger'   , 8225,
   'permil'   , 8240,
   'lsaquo'   , 8249,
   'rsaquo'   , 8250,
   'euro'     , 8364,
  );
  
  
  # Fill out %Name2character...
  {
    %Name2character = ();
    my($name, $number);
    while( ($name, $number) = each %Name2character_number) {
      if($] < 5.007  and  $number > 255) {
        $Name2character{$name} = $FAR_CHAR;
        # substitute for Unicode characters, for perls
        #  that can't reliably handle them
      } elsif ($] >= 5.007003) {
        $Name2character{$name} = chr utf8::unicode_to_native($number);
        # normal case for more recent Perls where we can translate from Unicode
        # to the native character set.
      }
      elsif (exists $Code2USASCII{$number}) {
        $Name2character{$name} = $Code2USASCII{$number};
        # on older Perls, we can use the translations we have hard-coded in this
        # file, but these don't include the non-ASCII-range characters
      }
      elsif ($NOT_ASCII && $number > 127 && $number < 256) {
        # this range on old non-ASCII-platform perls is wrong
        if (exists $Latin1Code_to_fallback{$number})  {
          $Name2character{$name} = $Latin1Code_to_fallback{$number};
        } else {
          $Name2character{$name} = $FAR_CHAR;
        }
      } else {
        $Name2character{$name} = chr $number;
      }
    }
  }
  
  #--------------------------------------------------------------------------
  1;
  __END__
  
  =head1 NAME
  
  Pod::Escapes - for resolving Pod EE<lt>...E<gt> sequences
  
  =head1 SYNOPSIS
  
    use Pod::Escapes qw(e2char);
    ...la la la, parsing POD, la la la...
    $text = e2char($e_node->label);
    unless(defined $text) {
      print "Unknown E sequence \"", $e_node->label, "\"!";
    }
    ...else print/interpolate $text...
  
  =head1 DESCRIPTION
  
  This module provides things that are useful in decoding
  Pod EE<lt>...E<gt> sequences.  Presumably, it should be used
  only by Pod parsers and/or formatters.
  
  By default, Pod::Escapes exports none of its symbols.  But
  you can request any of them to be exported.
  Either request them individually, as with
  C<use Pod::Escapes qw(symbolname symbolname2...);>,
  or you can do C<use Pod::Escapes qw(:ALL);> to get all
  exportable symbols.
  
  =head1 GOODIES
  
  =over
  
  =item e2char($e_content)
  
  Given a name or number that could appear in a
  C<EE<lt>name_or_numE<gt>> sequence, this returns the string that
  it stands for.  For example, C<e2char('sol')>, C<e2char('47')>,
  C<e2char('0x2F')>, and C<e2char('057')> all return "/",
  because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
  and C<EE<lt>057E<gt>>, all mean "/".  If
  the name has no known value (as with a name of "qacute") or is
  syntactically invalid (as with a name of "1/4"), this returns undef.
  
  =item e2charnum($e_content)
  
  Given a name or number that could appear in a
  C<EE<lt>name_or_numE<gt>> sequence, this returns the number of
  the Unicode character that this stands for.  For example,
  C<e2char('sol')>, C<e2char('47')>,
  C<e2char('0x2F')>, and C<e2char('057')> all return 47,
  because C<EE<lt>solE<gt>>, C<EE<lt>47E<gt>>, C<EE<lt>0x2fE<gt>>,
  and C<EE<lt>057E<gt>>, all mean "/", whose Unicode number is 47.  If
  the name has no known value (as with a name of "qacute") or is
  syntactically invalid (as with a name of "1/4"), this returns undef.
  
  =item $Name2character{I<name>}
  
  Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
  to the string that each stands for.  Note that this does not
  include numerics (like "64" or "x981c").  Under old Perl versions
  (before 5.7) you get a "?" in place of characters whose Unicode
  value is over 255.
  
  =item $Name2character_number{I<name>}
  
  Maps from names (as in C<EE<lt>I<name>E<gt>>) like "eacute" or "sol"
  to the Unicode value that each stands for.  For example,
  C<$Name2character_number{'eacute'}> is 201, and
  C<$Name2character_number{'eacute'}> is 8364.  You get the correct
  Unicode value, regardless of the version of Perl you're using --
  which differs from C<%Name2character>'s behavior under pre-5.7 Perls.
  
  Note that this hash does not
  include numerics (like "64" or "x981c").
  
  =item $Latin1Code_to_fallback{I<integer>}
  
  For numbers in the range 160 (0x00A0) to 255 (0x00FF), this maps
  from the character code for a Latin-1 character (like 233 for
  lowercase e-acute) to the US-ASCII character that best aproximates
  it (like "e").  You may find this useful if you are rendering
  POD in a format that you think deals well only with US-ASCII
  characters.
  
  =item $Latin1Char_to_fallback{I<character>}
  
  Just as above, but maps from characters (like "\xE9", 
  lowercase e-acute) to characters (like "e").
  
  =item $Code2USASCII{I<integer>}
  
  This maps from US-ASCII codes (like 32) to the corresponding
  character (like space, for 32).  Only characters 32 to 126 are
  defined.  This is meant for use by C<e2char($x)> when it senses
  that it's running on a non-ASCII platform (where chr(32) doesn't
  get you a space -- but $Code2USASCII{32} will).  It's
  documented here just in case you might find it useful.
  
  =back
  
  =head1 CAVEATS
  
  On Perl versions before 5.7, Unicode characters with a value
  over 255 (like lambda or emdash) can't be conveyed.  This
  module does work under such early Perl versions, but in the
  place of each such character, you get a "?".  Latin-1
  characters (characters 160-255) are unaffected.
  
  Under EBCDIC platforms, C<e2char($n)> may not always be the
  same as C<chr(e2charnum($n))>, and ditto for
  C<$Name2character{$name}> and
  C<chr($Name2character_number{$name})>, because the strings are returned as
  native, and the numbers are returned as Unicode.
  However, for Perls starting with v5.8, C<e2char($n)> is the same as
  C<chr(utf8::unicode_to_native(e2charnum($n)))>, and ditto for
  C<$Name2character{$name}> and
  C<chr(utf8::unicode_to_native($Name2character_number{$name}))>.
  
  =head1 SEE ALSO
  
  L<Pod::Browser> - a pod web server based on L<Catalyst>.
  
  L<Pod::Checker> - check pod documents for syntax errors.
  
  L<Pod::Coverage> - check if the documentation for a module is comprehensive.
  
  L<perlpod> - description of pod format (for people documenting with pod).
  
  L<perlpodspec> - specification of pod format (for people processing it).
  
  L<Text::Unidecode> - ASCII transliteration of Unicode text.
  
  =head1 REPOSITORY
  
  L<https://github.com/neilbowers/Pod-Escapes>
  
  =head1 COPYRIGHT AND DISCLAIMERS
  
  Copyright (c) 2001-2004 Sean M. Burke.  All rights reserved.
  
  This library is free software; you can redistribute it and/or modify
  it under the same terms as Perl itself.
  
  This program is distributed in the hope that it will be useful, but
  without any warranty; without even the implied warranty of
  merchantability or fitness for a particular purpose.
  
  Portions of the data tables in this module are derived from the
  entity declarations in the W3C XHTML specification.
  
  Currently (October 2001), that's these three:
  
   http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent
   http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent
   http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent
  
  =head1 AUTHOR
  
  Sean M. Burke C<sburke@cpan.org>
  
  Now being maintained by Neil Bowers E<lt>neilb@cpan.orgE<gt>
  
  =cut
  
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  # What I used for reading the XHTML .ent files:
  
  my(@norms, @good, @bad);
  my $dir = 'c:/sgml/docbook/';
  my %escapes;
  foreach my $file (qw(
    xhtml-symbol.ent
    xhtml-lat1.ent
    xhtml-special.ent
  )) {
    open(IN, "<$dir$file") or die "can't read-open $dir$file: $!";
    print "Reading $file...\n";
    while(<IN>) {
      if(m/<!ENTITY\s+(\S+)\s+"&#([^;]+);">/) {
        my($name, $value) = ($1,$2);
        next if $name eq 'quot' or $name eq 'apos' or $name eq 'gt';
      
        $value = hex $1 if $value =~ m/^x([a-fA-F0-9]+)$/s;
        print "ILLEGAL VALUE $value" unless $value =~ m/^\d+$/s;
        if($value > 255) {
          push @good , sprintf "   %-10s , chr(%s),\n", "'$name'", $value;
          push @bad  , sprintf "   %-10s , \$bad,\n", "'$name'", $value;
        } else {
          push @norms, sprintf " %-10s , chr(%s),\n", "'$name'", $value;
        }
      } elsif(m/<!ENT/) {
        print "# Skipping $_";
      }
    
    }
    close(IN);
  }
  
  print @norms;
  print "\n ( \$] .= 5.006001 ? (\n";
  print @good;
  print " ) : (\n";
  print @bad;
  print " )\n);\n";
  
  __END__
  #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  
  
POD_ESCAPES

$fatpacked{"Pod/Simple.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'POD_SIMPLE';
  
  require 5;
  package Pod::Simple;
  use strict;
  use Carp ();
  BEGIN           { *DEBUG = sub () {0} unless defined &DEBUG }
  use integer;
  use Pod::Escapes 1.04 ();
  use Pod::Simple::LinkSection ();
  use Pod::Simple::BlackBox ();
  #use utf8;
  
  use vars qw(
    $VERSION @ISA
    @Known_formatting_codes  @Known_directives
    %Known_formatting_codes  %Known_directives
    $NL
  );
  
  @ISA = ('Pod::Simple::BlackBox');
  $VERSION = '3.35';
  
  @Known_formatting_codes = qw(I B C L E F S X Z); 
  %Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
  @Known_directives       = qw(head1 head2 head3 head4 item over back); 
  %Known_directives       = map(($_=>'Plain'), @Known_directives);
  $NL = $/ unless defined $NL;
  
  #-----------------------------------------------------------------------------
  # Set up some constants:
  
  BEGIN {
    if(defined &ASCII)    { }
    elsif(chr(65) eq 'A') { *ASCII = sub () {1}  }
    else                  { *ASCII = sub () {''} }
  
    unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
    DEBUG > 4 and print STDERR "MANY_LINES is ", MANY_LINES(), "\n";
    unless(MANY_LINES() >= 1) {
      die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting";
    }
    if(defined &UNICODE) { }
    elsif($] >= 5.008)   { *UNICODE = sub() {1}  }
    else                 { *UNICODE = sub() {''} }
  }
  if(DEBUG > 2) {
    print STDERR "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
    print STDERR "# We are under a Unicode-safe Perl.\n";
  }
  
  # The NO BREAK SPACE and SOFT HYHPEN are used in several submodules.
  if ($] ge 5.007_003) {  # On sufficiently modern Perls we can handle any
                          # character set
    $Pod::Simple::nbsp = chr utf8::unicode_to_native(0xA0);
    $Pod::Simple::shy  = chr utf8::unicode_to_native(0xAD);
  }
  elsif (Pod::Simple::ASCII) {  # Hard code ASCII early Perl
    $Pod::Simple::nbsp = "\xA0";
    $Pod::Simple::shy  = "\xAD";
  }
  else { # EBCDIC on early Perl.  We know what the values are for the code
          # pages supported then.
    $Pod::Simple::nbsp = "\x41";
    $Pod::Simple::shy  = "\xCA";
  }
  
  # Design note:
  # This is a parser for Pod.  It is not a parser for the set of Pod-like
  #  languages which happens to contain Pod -- it is just for Pod, plus possibly
  #  some extensions.
  
  # @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
  #@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  __PACKAGE__->_accessorize(
    'nbsp_for_S',        # Whether to map S<...>'s to \xA0 characters
    'source_filename',   # Filename of the source, for use in warnings
    'source_dead',       # Whether to consider this parser's source dead
  
    'output_fh',         # The filehandle we're writing to, if applicable.
                         # Used only in some derived classes.
  
    'hide_line_numbers', # For some dumping subclasses: whether to pointedly
                         # suppress the start_line attribute
  
    'line_count',        # the current line number
    'pod_para_count',    # count of pod paragraphs seen so far
  
    'no_whining',        # whether to suppress whining
    'no_errata_section', # whether to suppress the errata section
    'complain_stderr',   # whether to complain to stderr
  
    'doc_has_started',   # whether we've fired the open-Document event yet
  
    'bare_output',       # For some subclasses: whether to prepend
                         #  header-code and postpend footer-code
  
    'keep_encoding_directive',  # whether to emit =encoding
    'nix_X_codes',       # whether to ignore X<...> codes
    'merge_text',        # whether to avoid breaking a single piece of
                         #  text up into several events
  
    'preserve_whitespace', # whether to try to keep whitespace as-is
    'strip_verbatim_indent', # What indent to strip from verbatim
  
    'parse_characters',  # Whether parser should expect chars rather than octets
  
   'content_seen',      # whether we've seen any real Pod content
   'errors_seen',       # TODO: document.  whether we've seen any errors (fatal or not)
  
   'codes_in_verbatim', # for PseudoPod extensions
  
   'code_handler',      # coderef to call when a code (non-pod) line is seen
   'cut_handler',       # ... when a =cut line is seen
   'pod_handler',       # ... when a =pod line is seen
   'whiteline_handler', # ... when a line with only whitespace is seen
   #Called like:
   # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
   #  $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
   #  $pod_handler->($line, $self->{'line_count'}, $self) if $pod_handler;
   #   $wl_handler->($line, $self->{'line_count'}, $self) if $wl_handler;
   'parse_empty_lists', # whether to acknowledge empty =over/=back blocks
   'raw_mode',          # to report entire raw lines instead of Pod elements
  );
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub any_errata_seen {  # good for using as an exit() value...
    return shift->{'errors_seen'} || 0;
  }
  
  sub errata_seen {
    return shift->{'all_errata'} || {};
  }
  
  # Returns the encoding only if it was recognized as being handled and set
  sub detected_encoding {
    return shift->{'detected_encoding'};
  }
  
  sub encoding {
    my $this = shift;
    return $this->{'encoding'} unless @_;  # GET.
  
    $this->_handle_encoding_line("=encoding $_[0]");
    if ($this->{'_processed_encoding'}) {
      delete $this->{'_processed_encoding'};
      if(! $this->{'encoding_command_statuses'} ) {
        DEBUG > 2 and print STDERR " CRAZY ERROR: encoding wasn't really handled?!\n";
      } elsif( $this->{'encoding_command_statuses'}[-1] ) {
        $this->scream( "=encoding $_[0]",
           sprintf "Couldn't do %s: %s",
           $this->{'encoding_command_reqs'  }[-1],
           $this->{'encoding_command_statuses'}[-1],
        );
      } else {
        DEBUG > 2 and print STDERR " (encoding successfully handled.)\n";
      }
      return $this->{'encoding'};
    } else {
      return undef;
    }
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  # Pull in some functions that, for some reason, I expect to see here too:
  BEGIN {
    *pretty        = \&Pod::Simple::BlackBox::pretty;
    *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol;
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub version_report {
    my $class = ref($_[0]) || $_[0];
    if($class eq __PACKAGE__) {
      return "$class $VERSION";
    } else {
      my $v = $class->VERSION;
      return "$class $v (" . __PACKAGE__ . " $VERSION)";
    }
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  #sub curr_open { # read-only list accessor
  #  return @{ $_[0]{'curr_open'} || return() };
  #}
  #sub _curr_open_listref { $_[0]{'curr_open'} ||= [] }
  
  
  sub output_string {
    # Works by faking out output_fh.  Simplifies our code.
    #
    my $this = shift;
    return $this->{'output_string'} unless @_;  # GET.
    
    require Pod::Simple::TiedOutFH;
    my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] );
    $$x = '' unless defined $$x;
    DEBUG > 4 and print STDERR "# Output string set to $x ($$x)\n";
    $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]);
    return
      $this->{'output_string'} = $_[0];
      #${ ${ $this->{'output_fh'} } };
  }
  
  sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} }
  sub abandon_output_fh     { $_[0]->output_fh(undef) }
  # These don't delete the string or close the FH -- they just delete our
  #  references to it/them.
  # TODO: document these
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub new {
    # takes no parameters
    my $class = ref($_[0]) || $_[0];
    #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc "
    #  . __PACKAGE__ );
    return bless {
      'accept_codes'      => { map( ($_=>$_), @Known_formatting_codes ) },
      'accept_directives' => { %Known_directives },
      'accept_targets'    => {},
    }, $class;
  }
  
  
  
  # TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub _handle_element_start {     # OVERRIDE IN DERIVED CLASS
    my($self, $element_name, $attr_hash_r) = @_;
    return;
  }
  
  sub _handle_element_end {       # OVERRIDE IN DERIVED CLASS
    my($self, $element_name) = @_;
    return;
  }
  
  sub _handle_text          {     # OVERRIDE IN DERIVED CLASS
    my($self, $text) = @_;
    return;
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  #
  # And now directives (not targets)
  
  sub accept_directive_as_verbatim  { shift->_accept_directives('Verbatim', @_) }
  sub accept_directive_as_data      { shift->_accept_directives('Data',     @_) }
  sub accept_directive_as_processed { shift->_accept_directives('Plain',    @_) }
  
  sub _accept_directives {
    my($this, $type) = splice @_,0,2;
    foreach my $d (@_) {
      next unless defined $d and length $d;
      Carp::croak "\"$d\" isn't a valid directive name"
       unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
      Carp::croak "\"$d\" is already a reserved Pod directive name"
       if exists $Known_directives{$d};
      $this->{'accept_directives'}{$d} = $type;
      DEBUG > 2 and print STDERR "Learning to accept \"=$d\" as directive of type $type\n";
    }
    DEBUG > 6 and print STDERR "$this\'s accept_directives : ",
     pretty($this->{'accept_directives'}), "\n";
    
    return sort keys %{ $this->{'accept_directives'} } if wantarray;
    return;
  }
  
  #--------------------------------------------------------------------------
  # TODO: document these:
  
  sub unaccept_directive { shift->unaccept_directives(@_) };
  
  sub unaccept_directives {
    my $this = shift;
    foreach my $d (@_) {
      next unless defined $d and length $d;
      Carp::croak "\"$d\" isn't a valid directive name"
       unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
      Carp::croak "But you must accept \"$d\" directives -- it's a builtin!"
       if exists $Known_directives{$d};
      delete $this->{'accept_directives'}{$d};
      DEBUG > 2 and print STDERR "OK, won't accept \"=$d\" as directive.\n";
    }
    return sort keys %{ $this->{'accept_directives'} } if wantarray;
    return
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  #
  # And now targets (not directives)
  
  sub accept_target         { shift->accept_targets(@_)         } # alias
  sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias
  
  
  sub accept_targets         { shift->_accept_targets('1', @_) }
  
  sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) }
   # forces them to be processed, even when there's no ":".
  
  sub _accept_targets {
    my($this, $type) = splice @_,0,2;
    foreach my $t (@_) {
      next unless defined $t and length $t;
      # TODO: enforce some limitations on what a target name can be?
      $this->{'accept_targets'}{$t} = $type;
      DEBUG > 2 and print STDERR "Learning to accept \"$t\" as target of type $type\n";
    }    
    return sort keys %{ $this->{'accept_targets'} } if wantarray;
    return;
  }
  
  #--------------------------------------------------------------------------
  sub unaccept_target         { shift->unaccept_targets(@_) }
  
  sub unaccept_targets {
    my $this = shift;
    foreach my $t (@_) {
      next unless defined $t and length $t;
      # TODO: enforce some limitations on what a target name can be?
      delete $this->{'accept_targets'}{$t};
      DEBUG > 2 and print STDERR "OK, won't accept \"$t\" as target.\n";
    }    
    return sort keys %{ $this->{'accept_targets'} } if wantarray;
    return;
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  #
  # And now codes (not targets or directives)
  
  # XXX Probably it is an error that the digit '9' is excluded from these re's.
  # Broken for early Perls on EBCDIC
  my $xml_name_re = eval "qr/[^-.0-8:A-Z_a-z[:^ascii:]]/";
  if (! defined $xml_name_re) {
      $xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/;
  }
  
  sub accept_code { shift->accept_codes(@_) } # alias
  
  sub accept_codes {  # Add some codes
    my $this = shift;
    
    foreach my $new_code (@_) {
      next unless defined $new_code and length $new_code;
      # A good-enough check that it's good as an XML Name symbol:
      Carp::croak "\"$new_code\" isn't a valid element name"
        if $new_code =~ $xml_name_re
            # Characters under 0x80 that aren't legal in an XML Name.
        or $new_code =~ m/^[-\.0-9]/s
        or $new_code =~ m/:[-\.0-9]/s;
            # The legal under-0x80 Name characters that
            #  an XML Name still can't start with.
  
      $this->{'accept_codes'}{$new_code} = $new_code;
  
      # Yes, map to itself -- just so that when we
      #  see "=extend W [whatever] thatelementname", we say that W maps
      #  to whatever $this->{accept_codes}{thatelementname} is,
      #  i.e., "thatelementname".  Then when we go re-mapping,
      #  a "W" in the treelet turns into "thatelementname".  We only
      #  remap once.
      # If we say we accept "W", then a "W" in the treelet simply turns
      #  into "W".
    }
    
    return;
  }
  
  #--------------------------------------------------------------------------
  sub unaccept_code { shift->unaccept_codes(@_) }
  
  sub unaccept_codes { # remove some codes
    my $this = shift;
    
    foreach my $new_code (@_) {
      next unless defined $new_code and length $new_code;
      # A good-enough check that it's good as an XML Name symbol:
      Carp::croak "\"$new_code\" isn't a valid element name"
        if $new_code =~ $xml_name_re
            # Characters under 0x80 that aren't legal in an XML Name.
        or $new_code =~ m/^[-\.0-9]/s
        or $new_code =~ m/:[-\.0-9]/s;
            # The legal under-0x80 Name characters that
            #  an XML Name still can't start with.
  
      Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!"
       if grep $new_code eq $_, @Known_formatting_codes;
  
      delete $this->{'accept_codes'}{$new_code};
  
      DEBUG > 2 and print STDERR "OK, won't accept the code $new_code<...>.\n";
    }
    
    return;
  }
  
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub parse_string_document {
    my $self = shift;
    my @lines;
    foreach my $line_group (@_) {
      next unless defined $line_group and length $line_group;
      pos($line_group) = 0;
      while($line_group =~
        m/([^\n\r]*)(\r?\n?)/g # supports \r, \n ,\r\n
        #m/([^\n\r]*)((?:\r?\n)?)/g
      ) {
        #print(">> $1\n"),
        $self->parse_lines($1)
         if length($1) or length($2)
          or pos($line_group) != length($line_group);
         # I.e., unless it's a zero-length "empty line" at the very
         #  end of "foo\nbar\n" (i.e., between the \n and the EOS).
      }
    }
    $self->parse_lines(undef); # to signal EOF
    return $self;
  }
  
  sub _init_fh_source {
    my($self, $source) = @_;
  
    #DEBUG > 1 and print STDERR "Declaring $source as :raw for starters\n";
    #$self->_apply_binmode($source, ':raw');
    #binmode($source, ":raw");
  
    return;
  }
  
  #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
  #
  
  sub parse_file {
    my($self, $source) = (@_);
  
    if(!defined $source) {
      Carp::croak("Can't use empty-string as a source for parse_file");
    } elsif(ref(\$source) eq 'GLOB') {
      $self->{'source_filename'} = '' . ($source);
    } elsif(ref $source) {
      $self->{'source_filename'} = '' . ($source);
    } elsif(!length $source) {
      Carp::croak("Can't use empty-string as a source for parse_file");
    } else {
      {
        local *PODSOURCE;
        open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!");
        $self->{'source_filename'} = $source;
        $source = *PODSOURCE{IO};
      }
      $self->_init_fh_source($source);
    }
    # By here, $source is a FH.
  
    $self->{'source_fh'} = $source;
  
    my($i, @lines);
    until( $self->{'source_dead'} ) {
      splice @lines;
  
      for($i = MANY_LINES; $i--;) {  # read those many lines at a time
        local $/ = $NL;
        push @lines, scalar(<$source>);  # readline
        last unless defined $lines[-1];
         # but pass thru the undef, which will set source_dead to true
      }
  
      my $at_eof = ! $lines[-1]; # keep track of the undef
      pop @lines if $at_eof; # silence warnings
  
      # be eol agnostic
      s/\r\n?/\n/g for @lines;
   
      # make sure there are only one line elements for parse_lines
      @lines = split(/(?<=\n)/, join('', @lines));
  
      # push the undef back after popping it to set source_dead to true
      push @lines, undef if $at_eof;
  
      $self->parse_lines(@lines);
    }
    delete($self->{'source_fh'}); # so it can be GC'd
    return $self;
  }
  
  #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
  
  sub parse_from_file {
    # An emulation of Pod::Parser's interface, for the sake of Perldoc.
    # Basically just a wrapper around parse_file.
  
    my($self, $source, $to) = @_;
    $self = $self->new unless ref($self); # so we tolerate being a class method
    
    if(!defined $source)             { $source = *STDIN{IO}
    } elsif(ref(\$source) eq 'GLOB') { # stet
    } elsif(ref($source)           ) { # stet
    } elsif(!length $source
       or $source eq '-' or $source =~ m/^<&(?:STDIN|0)$/i
    ) { 
      $source = *STDIN{IO};
    }
  
    if(!defined $to) {             $self->output_fh( *STDOUT{IO}   );
    } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to );
    } elsif(ref($to)) {            $self->output_fh( $to );
    } elsif(!length $to
       or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i
    ) {
      $self->output_fh( *STDOUT{IO} );
    } elsif($to =~ m/^>&(?:STDERR|2)$/i) {
      $self->output_fh( *STDERR{IO} );
    } else {
      require Symbol;
      my $out_fh = Symbol::gensym();
      DEBUG and print STDERR "Write-opening to $to\n";
      open($out_fh, ">$to")  or  Carp::croak "Can't write-open $to: $!";
      binmode($out_fh)
       if $self->can('write_with_binmode') and $self->write_with_binmode;
      $self->output_fh($out_fh);
    }
  
    return $self->parse_file($source);
  }
  
  #-----------------------------------------------------------------------------
  
  sub whine {
    #my($self,$line,$complaint) = @_;
    my $self = shift(@_);
    ++$self->{'errors_seen'};
    if($self->{'no_whining'}) {
      DEBUG > 9 and print STDERR "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n";
      return;
    }
    push @{$self->{'all_errata'}{$_[0]}}, $_[1];
    return $self->_complain_warn(@_) if $self->{'complain_stderr'};
    return $self->_complain_errata(@_);
  }
  
  sub scream {    # like whine, but not suppressible
    #my($self,$line,$complaint) = @_;
    my $self = shift(@_);
    ++$self->{'errors_seen'};
    push @{$self->{'all_errata'}{$_[0]}}, $_[1];
    return $self->_complain_warn(@_) if $self->{'complain_stderr'};
    return $self->_complain_errata(@_);
  }
  
  sub _complain_warn {
    my($self,$line,$complaint) = @_;
    return printf STDERR "%s around line %s: %s\n",
      $self->{'source_filename'} || 'Pod input', $line, $complaint;
  }
  
  sub _complain_errata {
    my($self,$line,$complaint) = @_;
    if( $self->{'no_errata_section'} ) {
      DEBUG > 9 and print STDERR "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n";
    } else {
      DEBUG > 9 and print STDERR "Queuing erratum (at line $line) $complaint\n";
      push @{$self->{'errata'}{$line}}, $complaint
        # for a report to be generated later!
    }
    return 1;
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub _get_initial_item_type {
    # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n"
    my($self, $para) = @_;
    return $para->[1]{'~type'}  if $para->[1]{'~type'};
  
    return $para->[1]{'~type'} = 'text'
     if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1';
    # Else fall thru to the general case:
    return $self->_get_item_type($para);
  }
  
  
  
  sub _get_item_type {       # mutates the item!!
    my($self, $para) = @_;
    return $para->[1]{'~type'} if $para->[1]{'~type'};
  
  
    # Otherwise we haven't yet been to this node.  Maybe alter it...
    
    my $content = join "\n", @{$para}[2 .. $#$para];
  
    if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) {
      # Like: "=item *", "=item   *   ", "=item"
      splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
      $para->[1]{'~orig_content'} = $content;
      return $para->[1]{'~type'} = 'bullet';
  
    } elsif($content =~ m/^\s*\*\s+(.+)/s) {  # tolerance
    
      # Like: "=item * Foo bar baz";
      $para->[1]{'~orig_content'}      = $content;
      $para->[1]{'~_freaky_para_hack'} = $1;
      DEBUG > 2 and print STDERR " Tolerating $$para[2] as =item *\\n\\n$1\n";
      splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
      return $para->[1]{'~type'} = 'bullet';
  
    } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) {
      # Like: "=item 1.", "=item    123412"
      
      $para->[1]{'~orig_content'} = $content;
      $para->[1]{'number'} = $1;  # Yes, stores the number there!
  
      splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
      return $para->[1]{'~type'} = 'number';
      
    } else {
      # It's anything else.
      return $para->[1]{'~type'} = 'text';
  
    }
  }
  
  #-----------------------------------------------------------------------------
  
  sub _make_treelet {
    my $self = shift;  # and ($para, $start_line)
    my $treelet;
    if(!@_) {
      return [''];
    } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') {
      # Hack so we can pass in fake-o pre-cooked paragraphs:
      #  just have the first line be a reference to a ['~Top', {}, ...]
      # We use this feechure in gen_errata and stuff.
  
      DEBUG and print STDERR "Applying precooked treelet hack to $_[0][0]\n";
      $treelet = $_[0][0];
      splice @$treelet, 0, 2;  # lop the top off
      return $treelet;
    } else {
      $treelet = $self->_treelet_from_formatting_codes(@_);
    }
    
    if( $self->_remap_sequences($treelet) ) {
      $self->_treat_Zs($treelet);  # Might as well nix these first
      $self->_treat_Ls($treelet);  # L has to precede E and S
      $self->_treat_Es($treelet);
      $self->_treat_Ss($treelet);  # S has to come after E
  
      $self->_wrap_up($treelet); # Nix X's and merge texties
      
    } else {
      DEBUG and print STDERR "Formatless treelet gets fast-tracked.\n";
       # Very common case!
    }
    
    splice @$treelet, 0, 2;  # lop the top off
  
    return $treelet;
  }
  
  #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
  
  sub _wrap_up {
    my($self, @stack) = @_;
    my $nixx  = $self->{'nix_X_codes'};
    my $merge = $self->{'merge_text' };
    return unless $nixx or $merge;
  
    DEBUG > 2 and print STDERR "\nStarting _wrap_up traversal.\n",
     $merge ? (" Merge mode on\n") : (),
     $nixx  ? (" Nix-X mode on\n") : (),
    ;    
    
  
    my($i, $treelet);
    while($treelet = shift @stack) {
      DEBUG > 3 and print STDERR " Considering children of this $treelet->[0] node...\n";
      for($i = 2; $i < @$treelet; ++$i) { # iterate over children
        DEBUG > 3 and print STDERR " Considering child at $i ", pretty($treelet->[$i]), "\n";
        if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') {
          DEBUG > 3 and print STDERR "   Nixing X node at $i\n";
          splice(@$treelet, $i, 1); # just nix this node (and its descendants)
          # no need to back-update the counter just yet
          redo;
  
        } elsif($merge and $i != 2 and  # non-initial
           !ref $treelet->[$i] and !ref $treelet->[$i - 1]
        ) {
          DEBUG > 3 and print STDERR "   Merging ", $i-1,
           ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n";
          $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0];
          DEBUG > 4 and print STDERR "    Now: ", $i-1, ":[$treelet->[$i-1]]\n";
          --$i;
          next; 
          # since we just pulled the possibly last node out from under
          #  ourselves, we can't just redo()
  
        } elsif( ref $treelet->[$i] ) {
          DEBUG > 4 and print STDERR "  Enqueuing ", pretty($treelet->[$i]), " for traversal.\n";
          push @stack, $treelet->[$i];
  
          if($treelet->[$i][0] eq 'L') {
            my $thing;
            foreach my $attrname ('section', 'to') {        
              if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
                unshift @stack, $thing;
                DEBUG > 4 and print STDERR "  +Enqueuing ",
                 pretty( $treelet->[$i][1]{$attrname} ),
                 " as an attribute value to tweak.\n";
              }
            }
          }
        }
      }
    }
    DEBUG > 2 and print STDERR "End of _wrap_up traversal.\n\n";
  
    return;
  }
  
  #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
  
  sub _remap_sequences {
    my($self,@stack) = @_;
    
    if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) {
      # VERY common case: abort it.
      DEBUG and print STDERR "Skipping _remap_sequences: formatless treelet.\n";
      return 0;
    }
    
    my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?");
  
    my $start_line = $stack[0][1]{'start_line'};
    DEBUG > 2 and printf
     "\nAbout to start _remap_sequences on treelet from line %s.\n",
     $start_line || '[?]'
    ;
    DEBUG > 3 and print STDERR " Map: ",
      join('; ', map "$_=" . (
          ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_}
        ),
        sort keys %$map ),
      ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map)
       ? "  (all normal)\n" : "\n"
    ;
  
    # A recursive algorithm implemented iteratively!  Whee!
    
    my($is, $was, $i, $treelet); # scratch
    while($treelet = shift @stack) {
      DEBUG > 3 and print STDERR " Considering children of this $treelet->[0] node...\n";
      for($i = 2; $i < @$treelet; ++$i) { # iterate over children
        next unless ref $treelet->[$i];  # text nodes are uninteresting
        
        DEBUG > 4 and print STDERR "  Noting child $i : $treelet->[$i][0]<...>\n";
        
        $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] };
        if( DEBUG > 3 ) {
          if(!defined $is) {
            print STDERR "   Code $was<> is UNKNOWN!\n";
          } elsif($is eq $was) {
            DEBUG > 4 and print STDERR "   Code $was<> stays the same.\n";
          } else  {
            print STDERR "   Code $was<> maps to ",
             ref($is)
              ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" )
              : "tag $is<...>.\n";
          }
        }
        
        if(!defined $is) {
          $self->whine($start_line, "Deleting unknown formatting code $was<>");
          $is = $treelet->[$i][0] = '1';  # But saving the children!
          # I could also insert a leading "$was<" and tailing ">" as
          # children of this node, but something about that seems icky.
        }
        if(ref $is) {
          my @dynasty = @$is;
          DEBUG > 4 and print STDERR "    Renaming $was node to $dynasty[-1]\n";
          $treelet->[$i][0] = pop @dynasty;
          my $nugget;
          while(@dynasty) {
            DEBUG > 4 and printf
             "    Grafting a new %s node between %s and %s\n",
             $dynasty[-1], $treelet->[0], $treelet->[$i][0], 
            ;
            
            #$nugget = ;
            splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]];
              # relace node with a new parent
          }
        } elsif($is eq '0') {
          splice(@$treelet, $i, 1); # just nix this node (and its descendants)
          --$i;  # back-update the counter
        } elsif($is eq '1') {
          splice(@$treelet, $i, 1 # replace this node with its children!
            => splice @{ $treelet->[$i] },2
                # (not catching its first two (non-child) items)
          );
          --$i;  # back up for new stuff
        } else {
          # otherwise it's unremarkable
          unshift @stack, $treelet->[$i];  # just recurse
        }
      }
    }
    
    DEBUG > 2 and print STDERR "End of _remap_sequences traversal.\n\n";
  
    if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) {
      DEBUG and print STDERR "Noting that the treelet is now formatless.\n";
      return 0;
    }
    return 1;
  }
  
  # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  
  sub _ponder_extend {
  
    # "Go to an extreme, move back to a more comfortable place"
    #  -- /Oblique Strategies/,  Brian Eno and Peter Schmidt
    
    my($self, $para) = @_;
    my $content = join ' ', splice @$para, 2;
    $content =~ s/^\s+//s;
    $content =~ s/\s+$//s;
  
    DEBUG > 2 and print STDERR "Ogling extensor: =extend $content\n";
  
    if($content =~
      m/^
        (\S+)         # 1 : new item
        \s+
        (\S+)         # 2 : fallback(s)
        (?:\s+(\S+))? # 3 : element name(s)
        \s*
        $
      /xs
    ) {
      my $new_letter = $1;
      my $fallbacks_one = $2;
      my $elements_one;
      $elements_one = defined($3) ? $3 : $1;
  
      DEBUG > 2 and print STDERR "Extensor has good syntax.\n";
  
      unless($new_letter =~ m/^[A-Z]$/s or $new_letter) {
        DEBUG > 2 and print STDERR " $new_letter isn't a valid thing to entend.\n";
        $self->whine(
          $para->[1]{'start_line'},
          "You can extend only formatting codes A-Z, not like \"$new_letter\""
        );
        return;
      }
      
      if(grep $new_letter eq $_, @Known_formatting_codes) {
        DEBUG > 2 and print STDERR " $new_letter isn't a good thing to extend, because known.\n";
        $self->whine(
          $para->[1]{'start_line'},
          "You can't extend an established code like \"$new_letter\""
        );
        
        #TODO: or allow if last bit is same?
        
        return;
      }
  
      unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s  # like "B", "M,I", etc.
        or $fallbacks_one eq '0' or $fallbacks_one eq '1'
      ) {
        $self->whine(
          $para->[1]{'start_line'},
          "Format for second =extend parameter must be like"
          . " M or 1 or 0 or M,N or M,N,O but you have it like "
          . $fallbacks_one
        );
        return;
      }
      
      unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc.
        $self->whine(
          $para->[1]{'start_line'},
          "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like "
          . $elements_one
        );
        return;
      }
  
      my @fallbacks  = split ',', $fallbacks_one,  -1;
      my @elements   = split ',', $elements_one, -1;
  
      foreach my $f (@fallbacks) {
        next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1';
        DEBUG > 2 and print STDERR "  Can't fall back on unknown code $f\n";
        $self->whine(
          $para->[1]{'start_line'},
          "Can't use unknown formatting code '$f' as a fallback for '$new_letter'"
        );
        return;
      }
  
      DEBUG > 3 and printf STDERR "Extensor: Fallbacks <%s> Elements <%s>.\n",
       @fallbacks, @elements;
  
      my $canonical_form;
      foreach my $e (@elements) {
        if(exists $self->{'accept_codes'}{$e}) {
          DEBUG > 1 and print STDERR " Mapping '$new_letter' to known extension '$e'\n";
          $canonical_form = $e;
          last; # first acceptable elementname wins!
        } else {
          DEBUG > 1 and print STDERR " Can't map '$new_letter' to unknown extension '$e'\n";
        }
      }
  
  
      if( defined $canonical_form ) {
        # We found a good N => elementname mapping
        $self->{'accept_codes'}{$new_letter} = $canonical_form;
        DEBUG > 2 and print
         "Extensor maps $new_letter => known element $canonical_form.\n";
      } else {
        # We have to use the fallback(s), which might be '0', or '1'.
        $self->{'accept_codes'}{$new_letter}
          = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks;
        DEBUG > 2 and print
         "Extensor maps $new_letter => fallbacks @fallbacks.\n";
      }
  
    } else {
      DEBUG > 2 and print STDERR "Extensor has bad syntax.\n";
      $self->whine(
        $para->[1]{'start_line'},
        "Unknown =extend syntax: $content"
      )
    }
    return;
  }
  
  
  #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
  
  sub _treat_Zs {  # Nix Z<...>'s
    my($self,@stack) = @_;
  
    my($i, $treelet);
    my $start_line = $stack[0][1]{'start_line'};
  
    # A recursive algorithm implemented iteratively!  Whee!
  
    while($treelet = shift @stack) {
      for($i = 2; $i < @$treelet; ++$i) { # iterate over children
        next unless ref $treelet->[$i];  # text nodes are uninteresting
        unless($treelet->[$i][0] eq 'Z') {
          unshift @stack, $treelet->[$i]; # recurse
          next;
        }
          
        DEBUG > 1 and print STDERR "Nixing Z node @{$treelet->[$i]}\n";
          
        # bitch UNLESS it's empty
        unless(  @{$treelet->[$i]} == 2
             or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
        ) {
          $self->whine( $start_line, "A non-empty Z<>" );
        }      # but kill it anyway
          
        splice(@$treelet, $i, 1); # thereby just nix this node.
        --$i;
          
      }
    }
    
    return;
  }
  
  # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  
  # Quoting perlpodspec:
  
  # In parsing an L<...> code, Pod parsers must distinguish at least four
  # attributes:
  
  ############# Not used.  Expressed via the element children plus
  #############  the value of the "content-implicit" flag.
  # First:
  # The link-text. If there is none, this must be undef. (E.g., in "L<Perl
  # Functions|perlfunc>", the link-text is "Perl Functions". In
  # "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note
  # that link text may contain formatting.)
  # 
  
  ############# The element children
  # Second:
  # The possibly inferred link-text -- i.e., if there was no real link text,
  # then this is the text that we'll infer in its place. (E.g., for
  # "L<Getopt::Std>", the inferred link text is "Getopt::Std".)
  #
  
  ############# The "to" attribute (which might be text, or a treelet)
  # Third:
  # The name or URL, or undef if none. (E.g., in "L<Perl
  # Functions|perlfunc>", the name -- also sometimes called the page -- is
  # "perlfunc". In "L</CAVEATS>", the name is undef.)
  # 
  
  ############# The "section" attribute (which might be next, or a treelet)
  # Fourth:
  # The section (AKA "item" in older perlpods), or undef if none. E.g., in
  # Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this
  # is not the same as a manpage section like the "5" in "man 5 crontab".
  # "Section Foo" in the Pod sense means the part of the text that's
  # introduced by the heading or item whose text is "Foo".)
  # 
  # Pod parsers may also note additional attributes including:
  #
  
  ############# The "type" attribute.
  # Fifth:
  # A flag for whether item 3 (if present) is a URL (like
  # "http://lists.perl.org" is), in which case there should be no section
  # attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or
  # possibly a man page name (like "crontab(5)" is).
  #
  
  ############# The "raw" attribute that is already there.
  # Sixth:
  # The raw original L<...> content, before text is split on "|", "/", etc,
  # and before E<...> codes are expanded.
  
  
  # For L<...> codes without a "name|" part, only E<...> and Z<> codes may
  # occur -- no other formatting codes. That is, authors should not use
  # "L<B<Foo::Bar>>".
  #
  # Note, however, that formatting codes and Z<>'s can occur in any and all
  # parts of an L<...> (i.e., in name, section, text, and url).
  
  sub _treat_Ls {  # Process our dear dear friends, the L<...> sequences
  
    # L<name>
    # L<name/"sec"> or L<name/sec>
    # L</"sec"> or L</sec> or L<"sec">
    # L<text|name>
    # L<text|name/"sec"> or L<text|name/sec>
    # L<text|/"sec"> or L<text|/sec> or L<text|"sec">
    # L<scheme:...>
    # L<text|scheme:...>
  
    my($self,@stack) = @_;
  
    my($i, $treelet);
    my $start_line = $stack[0][1]{'start_line'};
  
    # A recursive algorithm implemented iteratively!  Whee!
  
    while($treelet = shift @stack) {
      for(my $i = 2; $i < @$treelet; ++$i) {
        # iterate over children of current tree node
        next unless ref $treelet->[$i];  # text nodes are uninteresting
        unless($treelet->[$i][0] eq 'L') {
          unshift @stack, $treelet->[$i]; # recurse
          next;
        }
        
        
        # By here, $treelet->[$i] is definitely an L node
        my $ell = $treelet->[$i];
        DEBUG > 1 and print STDERR "Ogling L node $ell\n";
          
        # bitch if it's empty
        if(  @{$ell} == 2
         or (@{$ell} == 3 and $ell->[2] eq '')
        ) {
          $self->whine( $start_line, "An empty L<>" );
          $treelet->[$i] = 'L<>';  # just make it a text node
          next;  # and move on
        }
  
        if( (! ref $ell->[2]  && $ell->[2] =~ /\A\s/)
          ||(! ref $ell->[-1] && $ell->[-1] =~ /\s\z/)
        ) {
          $self->whine( $start_line, "L<> starts or ends with whitespace" );
        }
       
        # Catch URLs:
  
        # there are a number of possible cases:
        # 1) text node containing url: http://foo.com
        #   -> [ 'http://foo.com' ]
        # 2) text node containing url and text: foo|http://foo.com
        #   -> [ 'foo|http://foo.com' ]
        # 3) text node containing url start: mailto:xE<at>foo.com
        #   -> [ 'mailto:x', [ E ... ], 'foo.com' ]
        # 4) text node containing url start and text: foo|mailto:xE<at>foo.com
        #   -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ]
        # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com
        #   -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ]
        # ... etc.
  
        # anything before the url is part of the text.
        # anything after it is part of the url.
        # the url text node itself may contain parts of both.
  
        if (my ($url_index, $text_part, $url_part) =
          # grep is no good here; we want to bail out immediately so that we can
          # use $1, $2, etc. without having to do the match twice.
          sub {
            for (2..$#$ell) {
              next if ref $ell->[$_];
              next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s;
              return ($_, $1, $2);
            }
            return;
          }->()
        ) {
          $ell->[1]{'type'} = 'url';
  
          my @text = @{$ell}[2..$url_index-1];
          push @text, $text_part if defined $text_part;
  
          my @url  = @{$ell}[$url_index+1..$#$ell];
          unshift @url, $url_part;
  
          unless (@text) {
            $ell->[1]{'content-implicit'} = 'yes';
            @text = @url;
          }
  
          $ell->[1]{to} = Pod::Simple::LinkSection->new(
            @url == 1
            ? $url[0]
            : [ '', {}, @url ],
          );
  
          splice @$ell, 2, $#$ell, @text;
  
          next;
        }
        
        # Catch some very simple and/or common cases
        if(@{$ell} == 3 and ! ref $ell->[2]) {
          my $it = $ell->[2];
          if($it =~ m{^[^/|]+[(][-a-zA-Z0-9]+[)]$}s) { # man sections
            # Hopefully neither too broad nor too restrictive a RE
            DEBUG > 1 and print STDERR "Catching \"$it\" as manpage link.\n";
            $ell->[1]{'type'} = 'man';
            # This's the only place where man links can get made.
            $ell->[1]{'content-implicit'} = 'yes';
            $ell->[1]{'to'  } =
              Pod::Simple::LinkSection->new( $it ); # treelet!
  
            next;
          }
          if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) {
            # Extremely forgiving idea of what constitutes a bare
            #  modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala>
            DEBUG > 1 and print STDERR "Catching \"$it\" as ho-hum L<Modulename> link.\n";
            $ell->[1]{'type'} = 'pod';
            $ell->[1]{'content-implicit'} = 'yes';
            $ell->[1]{'to'  } =
              Pod::Simple::LinkSection->new( $it ); # treelet!
            next;
          }
          # else fall thru...
        }
        
        
  
        # ...Uhoh, here's the real L<...> parsing stuff...
        # "With the ill behavior, with the ill behavior, with the ill behavior..."
  
        DEBUG > 1 and print STDERR "Running a real parse on this non-trivial L\n";
        
        
        my $link_text; # set to an arrayref if found
        my @ell_content = @$ell;
        splice @ell_content,0,2; # Knock off the 'L' and {} bits
  
        DEBUG > 3 and print STDERR " Ell content to start: ",
         pretty(@ell_content), "\n";
  
  
        # Look for the "|" -- only in CHILDREN (not all underlings!)
        # Like L<I like the strictness|strict>
        DEBUG > 3 and
           print STDERR "  Peering at L content for a '|' ...\n";
        for(my $j = 0; $j < @ell_content; ++$j) {
          next if ref $ell_content[$j];
          DEBUG > 3 and
           print STDERR "    Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n";
  
          if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) {
            my @link_text = ($1);   # might be 0-length
            $ell_content[$j] = $2;  # might be 0-length
  
            DEBUG > 3 and
             print STDERR "     FOUND a '|' in it.  Splitting into [$1] + [$2]\n";
  
            if ($link_text[0] =~ m{[|/]}) {
              $self->whine(
                $start_line,
                "alternative text '$link_text[0]' contains non-escaped | or /"
              );
            }
  
            unshift @link_text, splice @ell_content, 0, $j;
              # leaving only things at J and after
            @ell_content =  grep ref($_)||length($_), @ell_content ;
            $link_text   = [grep ref($_)||length($_), @link_text  ];
            DEBUG > 3 and printf
             "  So link text is %s\n  and remaining ell content is %s\n",
              pretty($link_text), pretty(@ell_content);
            last;
          }
        }
        
        
        # Now look for the "/" -- only in CHILDREN (not all underlings!)
        # And afterward, anything left in @ell_content will be the raw name
        # Like L<Foo::Bar/Object Methods>
        my $section_name;  # set to arrayref if found
        DEBUG > 3 and print STDERR "  Peering at L-content for a '/' ...\n";
        for(my $j = 0; $j < @ell_content; ++$j) {
          next if ref $ell_content[$j];
          DEBUG > 3 and
           print STDERR "    Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n";
  
          if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) {
            my @section_name = ($2); # might be 0-length
            $ell_content[$j] =  $1;  # might be 0-length
  
            DEBUG > 3 and
             print STDERR "     FOUND a '/' in it.",
               "  Splitting to page [...$1] + section [$2...]\n";
  
            push @section_name, splice @ell_content, 1+$j;
              # leaving only things before and including J
            
            @ell_content  = grep ref($_)||length($_), @ell_content  ;
            @section_name = grep ref($_)||length($_), @section_name ;
  
            # Turn L<.../"foo"> into L<.../foo>
            if(@section_name
              and !ref($section_name[0]) and !ref($section_name[-1])
              and $section_name[ 0] =~ m/^\"/s
              and $section_name[-1] =~ m/\"$/s
              and !( # catch weird degenerate case of L<"> !
                @section_name == 1 and $section_name[0] eq '"'
              )
            ) {
              $section_name[ 0] =~ s/^\"//s;
              $section_name[-1] =~ s/\"$//s;
              DEBUG > 3 and
               print STDERR "     Quotes removed: ", pretty(@section_name), "\n";
            } else {
              DEBUG > 3 and
               print STDERR "     No need to remove quotes in ", pretty(@section_name), "\n";
            }
  
            $section_name = \@section_name;
            last;
          }
        }
  
        # Turn L<"Foo Bar"> into L</Foo Bar>
        if(!$section_name and @ell_content
           and !ref($ell_content[0]) and !ref($ell_content[-1])
           and $ell_content[ 0] =~ m/^\"/s
           and $ell_content[-1] =~ m/\"$/s
           and !( # catch weird degenerate case of L<"> !
             @ell_content == 1 and $ell_content[0] eq '"'
           )
        ) {
          $section_name = [splice @ell_content];
          $section_name->[ 0] =~ s/^\"//s;
          $section_name->[-1] =~ s/\"$//s;
        }
  
        # Turn L<Foo Bar> into L</Foo Bar>.
        if(!$section_name and !$link_text and @ell_content
           and grep !ref($_) && m/ /s, @ell_content
        ) {
          $section_name = [splice @ell_content];
          # That's support for the now-deprecated syntax.
          # (Maybe generate a warning eventually?)
          # Note that it deliberately won't work on L<...|Foo Bar>
        }
  
  
        # Now make up the link_text
        # L<Foo>     -> L<Foo|Foo>
        # L</Bar>    -> L<"Bar"|Bar>
        # L<Foo/Bar> -> L<"Bar" in Foo/Foo>
        unless($link_text) {
          $ell->[1]{'content-implicit'} = 'yes';
          $link_text = [];
          push @$link_text, '"', @$section_name, '"' if $section_name;
  
          if(@ell_content) {
            $link_text->[-1] .= ' in ' if $section_name;
            push @$link_text, @ell_content;
          }
        }
  
  
        # And the E resolver will have to deal with all our treeletty things:
  
        if(@ell_content == 1 and !ref($ell_content[0])
           and $ell_content[0] =~ m{^[^/]+[(][-a-zA-Z0-9]+[)]$}s
        ) {
          $ell->[1]{'type'}    = 'man';
          DEBUG > 3 and print STDERR "Considering this ($ell_content[0]) a man link.\n";
        } else {
          $ell->[1]{'type'}    = 'pod';
          DEBUG > 3 and print STDERR "Considering this a pod link (not man or url).\n";
        }
  
        if( defined $section_name ) {
          $ell->[1]{'section'} = Pod::Simple::LinkSection->new(
            ['', {}, @$section_name]
          );
          DEBUG > 3 and print STDERR "L-section content: ", pretty($ell->[1]{'section'}), "\n";
        }
  
        if( @ell_content ) {
          $ell->[1]{'to'} = Pod::Simple::LinkSection->new(
            ['', {}, @ell_content]
          );
          DEBUG > 3 and print STDERR "L-to content: ", pretty($ell->[1]{'to'}), "\n";
        }
        
        # And update children to be the link-text:
        @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : '');
        
        DEBUG > 2 and print STDERR "End of L-parsing for this node $treelet->[$i]\n";
  
        unshift @stack, $treelet->[$i]; # might as well recurse
      }
    }
  
    return;
  }
  
  # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  
  sub _treat_Es {
    my($self,@stack) = @_;
  
    my($i, $treelet, $content, $replacer, $charnum);
    my $start_line = $stack[0][1]{'start_line'};
  
    # A recursive algorithm implemented iteratively!  Whee!
  
  
    # Has frightening side effects on L nodes' attributes.
  
    #my @ells_to_tweak;
  
    while($treelet = shift @stack) {
      for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children
        next unless ref $treelet->[$i];  # text nodes are uninteresting
        if($treelet->[$i][0] eq 'L') {
          # SPECIAL STUFF for semi-processed L<>'s
          
          my $thing;
          foreach my $attrname ('section', 'to') {        
            if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
              unshift @stack, $thing;
              DEBUG > 2 and print STDERR "  Enqueuing ",
               pretty( $treelet->[$i][1]{$attrname} ),
               " as an attribute value to tweak.\n";
            }
          }
          
          unshift @stack, $treelet->[$i]; # recurse
          next;
        } elsif($treelet->[$i][0] ne 'E') {
          unshift @stack, $treelet->[$i]; # recurse
          next;
        }
        
        DEBUG > 1 and print STDERR "Ogling E node ", pretty($treelet->[$i]), "\n";
  
        # bitch if it's empty
        if(  @{$treelet->[$i]} == 2
         or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
        ) {
          $self->whine( $start_line, "An empty E<>" );
          $treelet->[$i] = 'E<>'; # splice in a literal
          next;
        }
          
        # bitch if content is weird
        unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) {
          $self->whine( $start_line, "An E<...> surrounding strange content" );
          $replacer = $treelet->[$i]; # scratch
          splice(@$treelet, $i, 1,   # fake out a literal
            'E<',
            splice(@$replacer,2), # promote its content
            '>'
          );
          # Don't need to do --$i, as the 'E<' we just added isn't interesting.
          next;
        }
  
        DEBUG > 1 and print STDERR "Ogling E<$content>\n";
  
        # XXX E<>'s contents *should* be a valid char in the scope of the current
        # =encoding directive. Defaults to iso-8859-1, I believe. Fix this in the
        # future sometime.
  
        $charnum  = Pod::Escapes::e2charnum($content);
        DEBUG > 1 and print STDERR " Considering E<$content> with char ",
          defined($charnum) ? $charnum : "undef", ".\n";
  
        if(!defined( $charnum )) {
          DEBUG > 1 and print STDERR "I don't know how to deal with E<$content>.\n";
          $self->whine( $start_line, "Unknown E content in E<$content>" );
          $replacer = "E<$content>"; # better than nothing
        } elsif($charnum >= 255 and !UNICODE) {
          $replacer = ASCII ? "\xA4" : "?";
          DEBUG > 1 and print STDERR "This Perl version can't handle ",
            "E<$content> (chr $charnum), so replacing with $replacer\n";
        } else {
          $replacer = Pod::Escapes::e2char($content);
          DEBUG > 1 and print STDERR " Replacing E<$content> with $replacer\n";
        }
  
        splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho
      }
    }
  
    return;
  }
  
  
  # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  
  sub _treat_Ss {
    my($self,$treelet) = @_;
    
    _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'};
  
    # TODO: or a change_nbsp_to_S
    #  Normalizing nbsp's to S is harder: for each text node, make S content
    #  out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/
  
  
    return;
  }
  
  sub _change_S_to_nbsp { #  a recursive function
    # Sanely assumes that the top node in the excursion won't be an S node.
    my($treelet, $in_s) = @_;
    
    my $is_s = ('S' eq $treelet->[0]);
    $in_s ||= $is_s; # So in_s is on either by this being an S element,
                     #  or by an ancestor being an S element.
  
    for(my $i = 2; $i < @$treelet; ++$i) {
      if(ref $treelet->[$i]) {
        if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) {
          my $to_pull_up = $treelet->[$i];
          splice @$to_pull_up,0,2;   # ...leaving just its content
          splice @$treelet, $i, 1, @$to_pull_up;  # Pull up content
          $i +=  @$to_pull_up - 1;   # Make $i skip the pulled-up stuff
        }
      } else {
        $treelet->[$i] =~ s/\s/$Pod::Simple::nbsp/g if $in_s;
         
         # Note that if you apply nbsp_for_S to text, and so turn
         # "foo S<bar baz> quux" into "foo bar&#160;faz quux", you
         # end up with something that fails to say "and don't hyphenate
         # any part of 'bar baz'".  However, hyphenation is such a vexing
         # problem anyway, that most Pod renderers just don't render it
         # at all.  But if you do want to implement hyphenation, I guess
         # that you'd better have nbsp_for_S off.
      }
    }
  
    return $is_s;
  }
  
  #-----------------------------------------------------------------------------
  
  sub _accessorize {  # A simple-minded method-maker
    no strict 'refs';
    foreach my $attrname (@_) {
      next if $attrname =~ m/::/; # a hack
      *{caller() . '::' . $attrname} = sub {
        use strict;
        $Carp::CarpLevel = 1,  Carp::croak(
         "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
        ) unless (@_ == 1 or @_ == 2) and ref $_[0];
        (@_ == 1) ?  $_[0]->{$attrname}
                  : ($_[0]->{$attrname} = $_[1]);
      };
    }
    # Ya know, they say accessories make the ensemble!
    return;
  }
  
  # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
  #=============================================================================
  
  sub filter {
    my($class, $source) = @_;
    my $new = $class->new;
    $new->output_fh(*STDOUT{IO});
    
    if(ref($source || '') eq 'SCALAR') {
      $new->parse_string_document( $$source );
    } elsif(ref($source)) {  # it's a file handle
      $new->parse_file($source);
    } else {  # it's a filename
      $new->parse_file($source);
    }
    
    return $new;
  }
  
  
  #-----------------------------------------------------------------------------
  
  sub _out {
    # For use in testing: Class->_out($source)
    #  returns the transformation of $source
    
    my $class = shift(@_);
  
    my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
  
    DEBUG and print STDERR "\n\n", '#' x 76,
     "\nAbout to parse source: {{\n$_[0]\n}}\n\n";
    
    
    my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new;
    $parser->hide_line_numbers(1);
  
    my $out = '';
    $parser->output_string( \$out );
    DEBUG and print STDERR " _out to ", \$out, "\n";
    
    $mutor->($parser) if $mutor;
  
    $parser->parse_string_document( $_[0] );
    # use Data::Dumper; print STDERR Dumper($parser), "\n";
    return $out;
  }
  
  
  sub _duo {
    # For use in testing: Class->_duo($source1, $source2)
    #  returns the parse trees of $source1 and $source2.
    # Good in things like: &ok( Class->duo(... , ...) );
    
    my $class = shift(@_);
    
    Carp::croak "But $class->_duo is useful only in list context!"
     unless wantarray;
  
    my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
  
    Carp::croak "But $class->_duo takes two parameters, not: @_"
     unless @_ == 2;
  
    my(@out);
    
    while( @_ ) {
      my $parser = $class->new;
  
      push @out, '';
      $parser->output_string( \( $out[-1] ) );
  
      DEBUG and print STDERR " _duo out to ", $parser->output_string(),
        " = $parser->{'output_string'}\n";
  
      $parser->hide_line_numbers(1);
      $mutor->($parser) if $mutor;
      $parser->parse_string_document( shift( @_ ) );
      # use Data::Dumper; print STDERR Dumper($parser), "\n";
    }
  
    return @out;
  }
  
  
  
  #-----------------------------------------------------------------------------
  1;
  __END__
  
  TODO:
  A start_formatting_code and end_formatting_code methods, which in the
  base class call start_L, end_L, start_C, end_C, etc., if they are
  defined.
  
  have the POD FORMATTING ERRORS section note the localtime, and the
  version of Pod::Simple.
  
  option to delete all E<shy>s?
  option to scream if under-0x20 literals are found in the input, or
  under-E<32> E codes are found in the tree. And ditto \x7f-\x9f
  
  Option to turn highbit characters into their compromised form? (applies
  to E parsing too)
  
  TODO: BOM/encoding things.
  
  TODO: ascii-compat things in the XML classes?
  
POD_SIMPLE

$fatpacked{"Pod/Simple/BlackBox.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'POD_SIMPLE_BLACKBOX';
  package Pod::Simple::BlackBox;
  #
  # "What's in the box?"  "Pain."
  #
  ###########################################################################
  #
  # This is where all the scary things happen: parsing lines into
  #  paragraphs; and then into directives, verbatims, and then also
  #  turning formatting sequences into treelets.
  #
  # Are you really sure you want to read this code?
  #
  #-----------------------------------------------------------------------------
  #
  # The basic work of this module Pod::Simple::BlackBox is doing the dirty work
  # of parsing Pod into treelets (generally one per non-verbatim paragraph), and
  # to call the proper callbacks on the treelets.
  #
  # Every node in a treelet is a ['name', {attrhash}, ...children...]
  
  use integer; # vroom!
  use strict;
  use Carp ();
  use vars qw($VERSION );
  $VERSION = '3.35';
  #use constant DEBUG => 7;
  BEGIN {
    require Pod::Simple;
    *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG
  }
  
  # Matches a character iff the character will have a different meaning
  # if we choose CP1252 vs UTF-8 if there is no =encoding line.
  # This is broken for early Perls on non-ASCII platforms.
  my $non_ascii_re = eval "qr/[[:^ascii:]]/";
  $non_ascii_re = qr/[\x80-\xFF]/ if ! defined $non_ascii_re;
  
  my $utf8_bom;
  if (($] ge 5.007_003)) {
    $utf8_bom = "\x{FEFF}";
    utf8::encode($utf8_bom);
  } else {
    $utf8_bom = "\xEF\xBB\xBF";   # No EBCDIC BOM detection for early Perls.
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub parse_line { shift->parse_lines(@_) } # alias
  
  # - - -  Turn back now!  Run away!  - - -
  
  sub parse_lines {             # Usage: $parser->parse_lines(@lines)
    # an undef means end-of-stream
    my $self = shift;
  
    my $code_handler = $self->{'code_handler'};
    my $cut_handler  = $self->{'cut_handler'};
    my $wl_handler   = $self->{'whiteline_handler'};
    $self->{'line_count'} ||= 0;
   
    my $scratch;
  
    DEBUG > 4 and 
     print STDERR "# Parsing starting at line ", $self->{'line_count'}, ".\n";
  
    DEBUG > 5 and
     print STDERR "#  About to parse lines: ",
       join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n";
  
    my $paras = ($self->{'paras'} ||= []);
     # paragraph buffer.  Because we need to defer processing of =over
     # directives and verbatim paragraphs.  We call _ponder_paragraph_buffer
     # to process this.
    
    $self->{'pod_para_count'} ||= 0;
  
    my $line;
    foreach my $source_line (@_) {
      if( $self->{'source_dead'} ) {
        DEBUG > 4 and print STDERR "# Source is dead.\n";
        last;
      }
  
      unless( defined $source_line ) {
        DEBUG > 4 and print STDERR "# Undef-line seen.\n";
  
        push @$paras, ['~end', {'start_line' => $self->{'line_count'}}];
        push @$paras, $paras->[-1], $paras->[-1];
         # So that it definitely fills the buffer.
        $self->{'source_dead'} = 1;
        $self->_ponder_paragraph_buffer;
        next;
      }
  
  
      if( $self->{'line_count'}++ ) {
        ($line = $source_line) =~ tr/\n\r//d;
         # If we don't have two vars, we'll end up with that there
         # tr/// modding the (potentially read-only) original source line!
      
      } else {
        DEBUG > 2 and print STDERR "First line: [$source_line]\n";
  
        if( ($line = $source_line) =~ s/^$utf8_bom//s ) {
          DEBUG and print STDERR "UTF-8 BOM seen.  Faking a '=encoding utf8'.\n";
          $self->_handle_encoding_line( "=encoding utf8" );
          delete $self->{'_processed_encoding'};
          $line =~ tr/\n\r//d;
          
        } elsif( $line =~ s/^\xFE\xFF//s ) {
          DEBUG and print STDERR "Big-endian UTF-16 BOM seen.  Aborting parsing.\n";
          $self->scream(
            $self->{'line_count'},
            "UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
          );
          splice @_;
          push @_, undef;
          next;
  
          # TODO: implement somehow?
  
        } elsif( $line =~ s/^\xFF\xFE//s ) {
          DEBUG and print STDERR "Little-endian UTF-16 BOM seen.  Aborting parsing.\n";
          $self->scream(
            $self->{'line_count'},
            "UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet."
          );
          splice @_;
          push @_, undef;
          next;
  
          # TODO: implement somehow?
          
        } else {
          DEBUG > 2 and print STDERR "First line is BOM-less.\n";
          ($line = $source_line) =~ tr/\n\r//d;
        }
      }
  
      if(!$self->{'parse_characters'} && !$self->{'encoding'}
        && ($self->{'in_pod'} || $line =~ /^=/s)
        && $line =~ /$non_ascii_re/
      ) {
  
        my $encoding;
  
        # No =encoding line, and we are at the first line in the input that
        # contains a non-ascii byte, that is one whose meaning varies depending
        # on whether the file is encoded in UTF-8 or CP1252, which are the two
        # possibilities permitted by the pod spec.  (ASCII is assumed if the
        # file only contains ASCII bytes.)  In order to process this line, we
        # need to figure out what encoding we will use for the file.
        #
        # Strictly speaking ISO 8859-1 (Latin 1) refers to the code points
        # 160-255, but it is used here, as it often colloquially is, to refer to
        # the complete set of code points 0-255, including ASCII (0-127), the C1
        # controls (128-159), and strict Latin 1 (160-255).
        #
        # CP1252 is effectively a superset of Latin 1, because it differs only
        # from colloquial 8859-1 in the C1 controls, which are very unlikely to
        # actually be present in 8859-1 files, so can be used for other purposes
        # without conflict.  CP 1252 uses most of them for graphic characters.
        #
        # Note that all ASCII-range bytes represent their corresponding code
        # points in CP1252 and UTF-8.  In ASCII platform UTF-8 all other code
        # points require multiple (non-ASCII) bytes to represent.  (A separate
        # paragraph for EBCDIC is below.)  The multi-byte representation is
        # quite structured.  If we find an isolated byte that requires multiple
        # bytes to represent in UTF-8, we know that the encoding is not UTF-8.
        # If we find a sequence of bytes that violates the UTF-8 structure, we
        # also can presume the encoding isn't UTF-8, and hence must be 1252.
        #
        # But there are ambiguous cases where we could guess wrong.  If so, the
        # user will end up having to supply an =encoding line.  We use all
        # readily available information to improve our chances of guessing
        # right.  The odds of something not being UTF-8, but still passing a
        # UTF-8 validity test go down very rapidly with increasing length of the
        # sequence.  Therefore we look at all the maximal length non-ascii
        # sequences on the line.  If any of the sequences can't be UTF-8, we
        # quit there and choose CP1252.  If all could be UTF-8, we guess UTF-8.
        #
        # On EBCDIC platforms, the situation is somewhat different.  In
        # UTF-EBCDIC, not only do ASCII-range bytes represent their code points,
        # but so do the bytes that are for the C1 controls.  Recall that these
        # correspond to the unused portion of 8859-1 that 1252 mostly takes
        # over.  That means that there are fewer code points that are
        # represented by multi-bytes.  But, note that the these controls are
        # very unlikely to be in pod text.  So if we encounter one of them, it
        # means that it is quite likely CP1252 and not UTF-8.  The net result is
        # the same code below is used for both platforms.
        while ($line =~ m/($non_ascii_re+)/g) {
          my $non_ascii_seq = $1;
  
          if (length $non_ascii_seq == 1) {
            $encoding = 'CP1252';
            goto guessed;
          } elsif ($] ge 5.007_003) {
  
            # On Perls that have this function, we can see if the sequence is
            # valid UTF-8 or not.
            my $is_utf8;
            {
              no warnings 'utf8';
              $is_utf8 = utf8::decode($non_ascii_seq);
            }
            if (! $is_utf8) {
              $encoding = 'CP1252';
              goto guessed;
            }
          } elsif (ord("A") == 65) {  # An early Perl, ASCII platform
  
            # Without utf8::decode, it's a lot harder to do a rigorous check
            # (though some early releases had a different function that
            # accomplished the same thing).  Since these are ancient Perls, not
            # likely to be in use today, we take the easy way out, and look at
            # just the first two bytes of the sequence to see if they are the
            # start of a UTF-8 character.  In ASCII UTF-8, continuation bytes
            # must be between 0x80 and 0xBF.  Start bytes can range from 0xC2
            # through 0xFF, but anything above 0xF4 is not Unicode, and hence
            # extremely unlikely to be in a pod.
            if ($non_ascii_seq !~ /^[\xC2-\xF4][\x80-\xBF]/) {
              $encoding = 'CP1252';
              goto guessed;
            }
  
            # We don't bother doing anything special for EBCDIC on early Perls.
            # If there is a solitary variant, CP1252 will be chosen; otherwise
            # UTF-8.
          }
        } # End of loop through all variant sequences on the line
  
        # All sequences in the line could be UTF-8.  Guess that.
        $encoding = 'UTF-8';
  
      guessed:
        $self->_handle_encoding_line( "=encoding $encoding" );
        delete $self->{'_processed_encoding'};
        $self->{'_transcoder'} && $self->{'_transcoder'}->($line);
  
        my ($word) = $line =~ /(\S*$non_ascii_re\S*)/;
  
        $self->whine(
          $self->{'line_count'},
          "Non-ASCII character seen before =encoding in '$word'. Assuming $encoding"
        );
      }
  
      DEBUG > 5 and print STDERR "# Parsing line: [$line]\n";
  
      if(!$self->{'in_pod'}) {
        if($line =~ m/^=([a-zA-Z][a-zA-Z0-9]*)(?:\s|$)/s) {
          if($1 eq 'cut') {
            $self->scream(
              $self->{'line_count'},
              "=cut found outside a pod block.  Skipping to next block."
            );
            
            ## Before there were errata sections in the world, it was
            ## least-pessimal to abort processing the file.  But now we can
            ## just barrel on thru (but still not start a pod block).
            #splice @_;
            #push @_, undef;
            
            next;
          } else {
            $self->{'in_pod'} = $self->{'start_of_pod_block'}
                              = $self->{'last_was_blank'}     = 1;
            # And fall thru to the pod-mode block further down
          }
        } else {
          DEBUG > 5 and print STDERR "# It's a code-line.\n";
          $code_handler->(map $_, $line, $self->{'line_count'}, $self)
           if $code_handler;
          # Note: this may cause code to be processed out of order relative
          #  to pods, but in order relative to cuts.
          
          # Note also that we haven't yet applied the transcoding to $line
          #  by time we call $code_handler!
  
          if( $line =~ m/^#\s*line\s+(\d+)\s*(?:\s"([^"]+)")?\s*$/ ) {
            # That RE is from perlsyn, section "Plain Old Comments (Not!)",
            #$fname = $2 if defined $2;
            #DEBUG > 1 and defined $2 and print STDERR "# Setting fname to \"$fname\"\n";
            DEBUG > 1 and print STDERR "# Setting nextline to $1\n";
            $self->{'line_count'} = $1 - 1;
          }
          
          next;
        }
      }
      
      # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
      # Else we're in pod mode:
  
      # Apply any necessary transcoding:
      $self->{'_transcoder'} && $self->{'_transcoder'}->($line);
  
      # HERE WE CATCH =encoding EARLY!
      if( $line =~ m/^=encoding\s+\S+\s*$/s ) {
        next if $self->parse_characters;   # Ignore this line
        $line = $self->_handle_encoding_line( $line );
      }
  
      if($line =~ m/^=cut/s) {
        # here ends the pod block, and therefore the previous pod para
        DEBUG > 1 and print STDERR "Noting =cut at line ${$self}{'line_count'}\n";
        $self->{'in_pod'} = 0;
        # ++$self->{'pod_para_count'};
        $self->_ponder_paragraph_buffer();
         # by now it's safe to consider the previous paragraph as done.
        $cut_handler->(map $_, $line, $self->{'line_count'}, $self)
         if $cut_handler;
  
        # TODO: add to docs: Note: this may cause cuts to be processed out
        #  of order relative to pods, but in order relative to code.
        
      } elsif($line =~ m/^(\s*)$/s) {  # it's a blank line
        if (defined $1 and $1 =~ /[^\S\r\n]/) { # it's a white line
          $wl_handler->(map $_, $line, $self->{'line_count'}, $self)
            if $wl_handler;
        }
  
        if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
          DEBUG > 1 and print STDERR "Saving blank line at line ${$self}{'line_count'}\n";
          push @{$paras->[-1]}, $line;
        }  # otherwise it's not interesting
        
        if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) {
          DEBUG > 1 and print STDERR "Noting para ends with blank line at ${$self}{'line_count'}\n";
        }
        
        $self->{'last_was_blank'} = 1;
        
      } elsif($self->{'last_was_blank'}) {  # A non-blank line starting a new para...
        
        if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) {
          # THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS
          my $new = [$1, {'start_line' => $self->{'line_count'}}, $2];
           # Note that in "=head1 foo", the WS is lost.
           # Example: ['=head1', {'start_line' => 123}, ' foo']
          
          ++$self->{'pod_para_count'};
          
          $self->_ponder_paragraph_buffer();
           # by now it's safe to consider the previous paragraph as done.
                  
          push @$paras, $new; # the new incipient paragraph
          DEBUG > 1 and print STDERR "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n";
          
        } elsif($line =~ m/^\s/s) {
  
          if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
            DEBUG > 1 and print STDERR "Resuming verbatim para at line ${$self}{'line_count'}\n";
            push @{$paras->[-1]}, $line;
          } else {
            ++$self->{'pod_para_count'};
            $self->_ponder_paragraph_buffer();
             # by now it's safe to consider the previous paragraph as done.
            DEBUG > 1 and print STDERR "Starting verbatim para at line ${$self}{'line_count'}\n";
            push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line];
          }
        } else {
          ++$self->{'pod_para_count'};
          $self->_ponder_paragraph_buffer();
           # by now it's safe to consider the previous paragraph as done.
          push @$paras, ['~Para',  {'start_line' => $self->{'line_count'}}, $line];
          DEBUG > 1 and print STDERR "Starting plain para at line ${$self}{'line_count'}\n";
        }
        $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
  
      } else {
        # It's a non-blank line /continuing/ the current para
        if(@$paras) {
          DEBUG > 2 and print STDERR "Line ${$self}{'line_count'} continues current paragraph\n";
          push @{$paras->[-1]}, $line;
        } else {
          # Unexpected case!
          die "Continuing a paragraph but \@\$paras is empty?";
        }
        $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0;
      }
      
    } # ends the big while loop
  
    DEBUG > 1 and print STDERR (pretty(@$paras), "\n");
    return $self;
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub _handle_encoding_line {
    my($self, $line) = @_;
    
    return if $self->parse_characters;
  
    # The point of this routine is to set $self->{'_transcoder'} as indicated.
  
    return $line unless $line =~ m/^=encoding\s+(\S+)\s*$/s;
    DEBUG > 1 and print STDERR "Found an encoding line \"=encoding $1\"\n";
  
    my $e    = $1;
    my $orig = $e;
    push @{ $self->{'encoding_command_reqs'} }, "=encoding $orig";
  
    my $enc_error;
  
    # Cf.   perldoc Encode   and   perldoc Encode::Supported
  
    require Pod::Simple::Transcode;
  
    if( $self->{'encoding'} ) {
      my $norm_current = $self->{'encoding'};
      my $norm_e = $e;
      foreach my $that ($norm_current, $norm_e) {
        $that =  lc($that);
        $that =~ s/[-_]//g;
      }
      if($norm_current eq $norm_e) {
        DEBUG > 1 and print STDERR "The '=encoding $orig' line is ",
         "redundant.  ($norm_current eq $norm_e).  Ignoring.\n";
        $enc_error = '';
         # But that doesn't necessarily mean that the earlier one went okay
      } else {
        $enc_error = "Encoding is already set to " . $self->{'encoding'};
        DEBUG > 1 and print STDERR $enc_error;
      }
    } elsif (
      # OK, let's turn on the encoding
      do {
        DEBUG > 1 and print STDERR " Setting encoding to $e\n";
        $self->{'encoding'} = $e;
        1;
      }
      and $e eq 'HACKRAW'
    ) {
      DEBUG and print STDERR " Putting in HACKRAW (no-op) encoding mode.\n";
  
    } elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) {
  
      die($enc_error = "WHAT? _transcoder is already set?!")
       if $self->{'_transcoder'};   # should never happen
      require Pod::Simple::Transcode;
      $self->{'_transcoder'} = Pod::Simple::Transcode::->make_transcoder($e);
      eval {
        my @x = ('', "abc", "123");
        $self->{'_transcoder'}->(@x);
      };
      $@ && die( $enc_error =
        "Really unexpected error setting up encoding $e: $@\nAborting"
      );
      $self->{'detected_encoding'} = $e;
  
    } else {
      my @supported = Pod::Simple::Transcode::->all_encodings;
  
      # Note unsupported, and complain
      DEBUG and print STDERR " Encoding [$e] is unsupported.",
        "\nSupporteds: @supported\n";
      my $suggestion = '';
  
      # Look for a near match:
      my $norm = lc($e);
      $norm =~ tr[-_][]d;
      my $n;
      foreach my $enc (@supported) {
        $n = lc($enc);
        $n =~ tr[-_][]d;
        next unless $n eq $norm;
        $suggestion = "  (Maybe \"$e\" should be \"$enc\"?)";
        last;
      }
      my $encmodver = Pod::Simple::Transcode::->encmodver;
      $enc_error = join '' =>
        "This document probably does not appear as it should, because its ",
        "\"=encoding $e\" line calls for an unsupported encoding.",
        $suggestion, "  [$encmodver\'s supported encodings are: @supported]"
      ;
  
      $self->scream( $self->{'line_count'}, $enc_error );
    }
    push @{ $self->{'encoding_command_statuses'} }, $enc_error;
    if (defined($self->{'_processed_encoding'})) {
      # Double declaration.
      $self->scream( $self->{'line_count'}, 'Cannot have multiple =encoding directives');
    }
    $self->{'_processed_encoding'} = $orig;
  
    return $line;
  }
  
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  
  sub _handle_encoding_second_level {
    # By time this is called, the encoding (if well formed) will already
    #  have been acted one.
    my($self, $para) = @_;
    my @x = @$para;
    my $content = join ' ', splice @x, 2;
    $content =~ s/^\s+//s;
    $content =~ s/\s+$//s;
  
    DEBUG > 2 and print STDERR "Ogling encoding directive: =encoding $content\n";
    
    if (defined($self->{'_processed_encoding'})) {
      #if($content ne $self->{'_processed_encoding'}) {
      #  Could it happen?
      #}
      delete $self->{'_processed_encoding'};
      # It's already been handled.  Check for errors.
      if(! $self->{'encoding_command_statuses'} ) {
        DEBUG > 2 and print STDERR " CRAZY ERROR: It wasn't really handled?!\n";
      } elsif( $self->{'encoding_command_statuses'}[-1] ) {
        $self->whine( $para->[1]{'start_line'},
          sprintf "Couldn't do %s: %s",
            $self->{'encoding_command_reqs'  }[-1],
            $self->{'encoding_command_statuses'}[-1],
        );
      } else {
        DEBUG > 2 and print STDERR " (Yup, it was successfully handled already.)\n";
      }
      
    } else {
      # Otherwise it's a syntax error
      $self->whine( $para->[1]{'start_line'},
        "Invalid =encoding syntax: $content"
      );
    }
    
    return;
  }
  
  #~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`
  
  {
  my $m = -321;   # magic line number
  
  sub _gen_errata {
    my $self = $_[0];
    # Return 0 or more fake-o paragraphs explaining the accumulated
    #  errors on this document.
  
    return() unless $self->{'errata'} and keys %{$self->{'errata'}};
  
    my @out;
    
    foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) {
      push @out,
        ['=item', {'start_line' => $m}, "Around line $line:"],
        map( ['~Para', {'start_line' => $m, '~cooked' => 1},
          #['~Top', {'start_line' => $m},
          $_
          #]
          ],
          @{$self->{'errata'}{$line}}
        )
      ;
    }
    
    # TODO: report of unknown entities? unrenderable characters?
  
    unshift @out,
      ['=head1', {'start_line' => $m, 'errata' => 1}, 'POD ERRORS'],
      ['~Para', {'start_line' => $m, '~cooked' => 1, 'errata' => 1},
       "Hey! ",
       ['B', {},
        'The above document had some coding errors, which are explained below:'
       ]
      ],
      ['=over',  {'start_line' => $m, 'errata' => 1}, ''],
    ;
  
    push @out, 
      ['=back',  {'start_line' => $m, 'errata' => 1}, ''],
    ;
  
    DEBUG and print STDERR "\n<<\n", pretty(\@out), "\n>>\n\n";
  
    return @out;
  }
  
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  ##############################################################################
  ##
  ##  stop reading now stop reading now stop reading now stop reading now stop
  ##
  ##                         HERE IT BECOMES REALLY SCARY
  ##
  ##  stop reading now stop reading now stop reading now stop reading now stop
  ##
  ##############################################################################
  
  sub _ponder_paragraph_buffer {
  
    # Para-token types as found in the buffer.
    #   ~Verbatim, ~Para, ~end, =head1..4, =for, =begin, =end,
    #   =over, =back, =item
    #   and the null =pod (to be complained about if over one line)
    #
    # "~data" paragraphs are something we generate at this level, depending on
    # a currently open =over region
  
    # Events fired:  Begin and end for:
    #                   directivename (like head1 .. head4), item, extend,
    #                   for (from =begin...=end, =for),
    #                   over-bullet, over-number, over-text, over-block,
    #                   item-bullet, item-number, item-text,
    #                   Document,
    #                   Data, Para, Verbatim
    #                   B, C, longdirname (TODO -- wha?), etc. for all directives
    # 
  
    my $self = $_[0];
    my $paras;
    return unless @{$paras = $self->{'paras'}};
    my $curr_open = ($self->{'curr_open'} ||= []);
  
    my $scratch;
  
    DEBUG > 10 and print STDERR "# Paragraph buffer: <<", pretty($paras), ">>\n";
  
    # We have something in our buffer.  So apparently the document has started.
    unless($self->{'doc_has_started'}) {
      $self->{'doc_has_started'} = 1;
      
      my $starting_contentless;
      $starting_contentless =
       (
         !@$curr_open  
         and @$paras and ! grep $_->[0] ne '~end', @$paras
          # i.e., if the paras is all ~ends
       )
      ;
      DEBUG and print STDERR "# Starting ",
        $starting_contentless ? 'contentless' : 'contentful',
        " document\n"
      ;
      
      $self->_handle_element_start(
        ($scratch = 'Document'),
        {
          'start_line' => $paras->[0][1]{'start_line'},
          $starting_contentless ? ( 'contentless' => 1 ) : (),
        },
      );
    }
  
    my($para, $para_type);
    while(@$paras) {
      last if @$paras == 1 and
        ( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim'
          or $paras->[0][0] eq '=item' )
      ;
      # Those're the three kinds of paragraphs that require lookahead.
      #   Actually, an "=item Foo" inside an <over type=text> region
      #   and any =item inside an <over type=block> region (rare)
      #   don't require any lookahead, but all others (bullets
      #   and numbers) do.
  
  # TODO: whinge about many kinds of directives in non-resolving =for regions?
  # TODO: many?  like what?  =head1 etc?
  
      $para = shift @$paras;
      $para_type = $para->[0];
  
      DEBUG > 1 and print STDERR "Pondering a $para_type paragraph, given the stack: (",
        $self->_dump_curr_open(), ")\n";
      
      if($para_type eq '=for') {
        next if $self->_ponder_for($para,$curr_open,$paras);
  
      } elsif($para_type eq '=begin') {
        next if $self->_ponder_begin($para,$curr_open,$paras);
  
      } elsif($para_type eq '=end') {
        next if $self->_ponder_end($para,$curr_open,$paras);
  
      } elsif($para_type eq '~end') { # The virtual end-document signal
        next if $self->_ponder_doc_end($para,$curr_open,$paras);
      }
  
  
      # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
      #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
      if(grep $_->[1]{'~ignore'}, @$curr_open) {
        DEBUG > 1 and
         print STDERR "Skipping $para_type paragraph because in ignore mode.\n";
        next;
      }
      #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
      # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
  
      if($para_type eq '=pod') {
        $self->_ponder_pod($para,$curr_open,$paras);
  
      } elsif($para_type eq '=over') {
        next if $self->_ponder_over($para,$curr_open,$paras);
  
      } elsif($para_type eq '=back') {
        next if $self->_ponder_back($para,$curr_open,$paras);
  
      } else {
  
        # All non-magical codes!!!
        
        # Here we start using $para_type for our own twisted purposes, to
        #  mean how it should get treated, not as what the element name
        #  should be.
  
        DEBUG > 1 and print STDERR "Pondering non-magical $para_type\n";
  
        my $i;
  
        # Enforce some =headN discipline
        if($para_type =~ m/^=head\d$/s
           and ! $self->{'accept_heads_anywhere'}
           and @$curr_open
           and $curr_open->[-1][0] eq '=over'
        ) {
          DEBUG > 2 and print STDERR "'=$para_type' inside an '=over'!\n";
          $self->whine(
            $para->[1]{'start_line'},
            "You forgot a '=back' before '$para_type'"
          );
          unshift @$paras, ['=back', {}, ''], $para;   # close the =over
          next;
        }
  
  
        if($para_type eq '=item') {
  
          my $over;
          unless(@$curr_open and
                 $over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) {
            $self->whine(
              $para->[1]{'start_line'},
              "'=item' outside of any '=over'"
            );
            unshift @$paras,
              ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
              $para
            ;
            next;
          }
          
          
          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;
            next;
  
          } 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 STDERR " 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') {
              $self->whine(
                $para->[1]{'start_line'},
                "Expected text after =item, not a $item_type"
              );
              # 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 STDERR " 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 STDERR " Numeric item has the expected value of $expected_value\n";
              
            } else {
              DEBUG > 1 and print STDERR " 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 STDERR "Assimilating following ~Para content into $over_type item\n";
                push @$para, splice @{shift @$paras},2;
              } else {
                DEBUG and print STDERR "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 STDERR " 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 STDERR "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 STDERR "Assimilating following ~Para content into $over_type item\n";
                push @$para, splice @{shift @$paras},2;
              } else {
                DEBUG and print STDERR "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_type = 'Plain';
          $para->[0] .= '-' . $over_type;
          # Whew.  Now fall thru and process it.
  
  
        } elsif($para_type eq '=extend') {
          # Well, might as well implement it here.
          $self->_ponder_extend($para);
          next;  # and skip
        } elsif($para_type eq '=encoding') {
          # Not actually acted on here, but we catch errors here.
          $self->_handle_encoding_second_level($para);
          next unless $self->keep_encoding_directive;
          $para_type = 'Plain';
        } elsif($para_type eq '~Verbatim') {
          $para->[0] = 'Verbatim';
          $para_type = '?Verbatim';
        } elsif($para_type eq '~Para') {
          $para->[0] = 'Para';
          $para_type = '?Plain';
        } elsif($para_type eq 'Data') {
          $para->[0] = 'Data';
          $para_type = '?Data';
        } elsif( $para_type =~ s/^=//s
          and defined( $para_type = $self->{'accept_directives'}{$para_type} )
        ) {
          DEBUG > 1 and print STDERR " Pondering known directive ${$para}[0] as $para_type\n";
        } else {
          # An unknown directive!
          DEBUG > 1 and printf STDERR "Unhandled directive %s (Handled: %s)\n",
           $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} )
          ;
          $self->whine(
            $para->[1]{'start_line'},
            "Unknown directive: $para->[0]"
          );
  
          # And maybe treat it as text instead of just letting it go?
          next;
        }
  
        if($para_type =~ s/^\?//s) {
          if(! @$curr_open) {  # usual case
            DEBUG and print STDERR "Treating $para_type paragraph as such because stack is empty.\n";
          } else {
            my @fors = grep $_->[0] eq '=for', @$curr_open;
            DEBUG > 1 and print STDERR "Containing fors: ",
              join(',', map $_->[1]{'target'}, @fors), "\n";
            
            if(! @fors) {
              DEBUG and print STDERR "Treating $para_type paragraph as such because stack has no =for's\n";
              
            #} elsif(grep $_->[1]{'~resolve'}, @fors) {
            #} elsif(not grep !$_->[1]{'~resolve'}, @fors) {
            } elsif( $fors[-1][1]{'~resolve'} ) {
              # Look to the immediately containing for
            
              if($para_type eq 'Data') {
                DEBUG and print STDERR "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
                $para->[0] = 'Para';
                $para_type = 'Plain';
              } else {
                DEBUG and print STDERR "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
              }
            } else {
              DEBUG and print STDERR "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n";
              $para->[0] = $para_type = 'Data';
            }
          }
        }
  
        #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        if($para_type eq 'Plain') {
          $self->_ponder_Plain($para);
        } elsif($para_type eq 'Verbatim') {
          $self->_ponder_Verbatim($para);        
        } elsif($para_type eq 'Data') {
          $self->_ponder_Data($para);
        } else {
          die "\$para type is $para_type -- how did that happen?";
          # Shouldn't happen.
        }
  
        #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        $para->[0] =~ s/^[~=]//s;
  
        DEBUG and print STDERR "\n", pretty($para), "\n";
  
        # traverse the treelet (which might well be just one string scalar)
        $self->{'content_seen'} ||= 1;
        $self->_traverse_treelet_bit(@$para);
      }
    }
    
    return;
  }
  
  ###########################################################################
  # The sub-ponderers...
  
  
  
  sub _ponder_for {
    my ($self,$para,$curr_open,$paras) = @_;
  
    # Fake it out as a begin/end
    my $target;
  
    if(grep $_->[1]{'~ignore'}, @$curr_open) {
      DEBUG > 1 and print STDERR "Ignoring ignorable =for\n";
      return 1;
    }
  
    for(my $i = 2; $i < @$para; ++$i) {
      if($para->[$i] =~ s/^\s*(\S+)\s*//s) {
        $target = $1;
        last;
      }
    }
    unless(defined $target) {
      $self->whine(
        $para->[1]{'start_line'},
        "=for without a target?"
      );
      return 1;
    }
    DEBUG > 1 and
     print STDERR "Faking out a =for $target as a =begin $target / =end $target\n";
    
    $para->[0] = 'Data';
    
    unshift @$paras,
      ['=begin',
        {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
        $target,
      ],
      $para,
      ['=end',
        {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'},
        $target,
      ],
    ;
    
    return 1;
  }
  
  sub _ponder_begin {
    my ($self,$para,$curr_open,$paras) = @_;
    my $content = join ' ', splice @$para, 2;
    $content =~ s/^\s+//s;
    $content =~ s/\s+$//s;
    unless(length($content)) {
      $self->whine(
        $para->[1]{'start_line'},
        "=begin without a target?"
      );
      DEBUG and print STDERR "Ignoring targetless =begin\n";
      return 1;
    }
    
    my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/;
    $para->[1]{'title'} = $title if ($title);
    $para->[1]{'target'} = $target;  # without any ':'
    $content = $target; # strip off the title
    
    $content =~ s/^:!/!:/s;
    my $neg;  # whether this is a negation-match
    $neg = 1        if $content =~ s/^!//s;
    my $to_resolve;  # whether to process formatting codes
    $to_resolve = 1 if $content =~ s/^://s;
    
    my $dont_ignore; # whether this target matches us
    
    foreach my $target_name (
      split(',', $content, -1),
      $neg ? () : '*'
    ) {
      DEBUG > 2 and
       print STDERR " Considering whether =begin $content matches $target_name\n";
      next unless $self->{'accept_targets'}{$target_name};
      
      DEBUG > 2 and
       print STDERR "  It DOES match the acceptable target $target_name!\n";
      $to_resolve = 1
        if $self->{'accept_targets'}{$target_name} eq 'force_resolve';
      $dont_ignore = 1;
      $para->[1]{'target_matching'} = $target_name;
      last; # stop looking at other target names
    }
  
    if($neg) {
      if( $dont_ignore ) {
        $dont_ignore = '';
        delete $para->[1]{'target_matching'};
        DEBUG > 2 and print STDERR " But the leading ! means that this is a NON-match!\n";
      } else {
        $dont_ignore = 1;
        $para->[1]{'target_matching'} = '!';
        DEBUG > 2 and print STDERR " But the leading ! means that this IS a match!\n";
      }
    }
  
    $para->[0] = '=for';  # Just what we happen to call these, internally
    $para->[1]{'~really'} ||= '=begin';
    $para->[1]{'~ignore'}   = (! $dont_ignore) || 0;
    $para->[1]{'~resolve'}  = $to_resolve || 0;
  
    DEBUG > 1 and print STDERR " Making note to ", $dont_ignore ? 'not ' : '',
      "ignore contents of this region\n";
    DEBUG > 1 and $dont_ignore and print STDERR " Making note to treat contents as ",
      ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n";
    DEBUG > 1 and print STDERR " (Stack now: ", $self->_dump_curr_open(), ")\n";
  
    push @$curr_open, $para;
    if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) {
      DEBUG > 1 and print STDERR "Ignoring ignorable =begin\n";
    } else {
      $self->{'content_seen'} ||= 1;
      $self->_handle_element_start((my $scratch='for'), $para->[1]);
    }
  
    return 1;
  }
  
  sub _ponder_end {
    my ($self,$para,$curr_open,$paras) = @_;
    my $content = join ' ', splice @$para, 2;
    $content =~ s/^\s+//s;
    $content =~ s/\s+$//s;
    DEBUG and print STDERR "Ogling '=end $content' directive\n";
  
    unless(length($content)) {
      $self->whine(
        $para->[1]{'start_line'},
        "'=end' without a target?" . (
          ( @$curr_open and $curr_open->[-1][0] eq '=for' )
          ? ( " (Should be \"=end " . $curr_open->[-1][1]{'target'} . '")' )
          : ''
        )
      );
      DEBUG and print STDERR "Ignoring targetless =end\n";
      return 1;
    }
    
    unless($content =~ m/^\S+$/) {  # i.e., unless it's one word
      $self->whine(
        $para->[1]{'start_line'},
        "'=end $content' is invalid.  (Stack: "
        . $self->_dump_curr_open() . ')'
      );
      DEBUG and print STDERR "Ignoring mistargetted =end $content\n";
      return 1;
    }
    
    unless(@$curr_open and $curr_open->[-1][0] eq '=for') {
      $self->whine(
        $para->[1]{'start_line'},
        "=end $content without matching =begin.  (Stack: "
        . $self->_dump_curr_open() . ')'
      );
      DEBUG and print STDERR "Ignoring mistargetted =end $content\n";
      return 1;
    }
    
    unless($content eq $curr_open->[-1][1]{'target'}) {
      $self->whine(
        $para->[1]{'start_line'},
        "=end $content doesn't match =begin " 
        . $curr_open->[-1][1]{'target'}
        . ".  (Stack: "
        . $self->_dump_curr_open() . ')'
      );
      DEBUG and print STDERR "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n";
      return 1;
    }
  
    # Else it's okay to close...
    if(grep $_->[1]{'~ignore'}, @$curr_open) {
      DEBUG > 1 and print STDERR "Not firing any event for this =end $content because in an ignored region\n";
      # And that may be because of this to-be-closed =for region, or some
      #  other one, but it doesn't matter.
    } else {
      $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'};
        # what's that for?
      
      $self->{'content_seen'} ||= 1;
      $self->_handle_element_end( my $scratch = 'for', $para->[1]);
    }
    DEBUG > 1 and print STDERR "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n";
    pop @$curr_open;
  
    return 1;
  } 
  
  sub _ponder_doc_end {
    my ($self,$para,$curr_open,$paras) = @_;
    if(@$curr_open) { # Deal with things left open
      DEBUG and print STDERR "Stack is nonempty at end-document: (",
        $self->_dump_curr_open(), ")\n";
        
      DEBUG > 9 and print STDERR "Stack: ", pretty($curr_open), "\n";
      unshift @$paras, $self->_closers_for_all_curr_open;
      # Make sure there is exactly one ~end in the parastack, at the end:
      @$paras = grep $_->[0] ne '~end', @$paras;
      push @$paras, $para, $para;
       # We need two -- once for the next cycle where we
       #  generate errata, and then another to be at the end
       #  when that loop back around to process the errata.
      return 1;
      
    } else {
      DEBUG and print STDERR "Okay, stack is empty now.\n";
    }
    
    # Try generating errata section, if applicable
    unless($self->{'~tried_gen_errata'}) {
      $self->{'~tried_gen_errata'} = 1;
      my @extras = $self->_gen_errata();
      if(@extras) {
        unshift @$paras, @extras;
        DEBUG and print STDERR "Generated errata... relooping...\n";
        return 1;  # I.e., loop around again to process these fake-o paragraphs
      }
    }
    
    splice @$paras; # Well, that's that for this paragraph buffer.
    DEBUG and print STDERR "Throwing end-document event.\n";
  
    $self->_handle_element_end( my $scratch = 'Document' );
    return 1; # Hasta la byebye
  }
  
  sub _ponder_pod {
    my ($self,$para,$curr_open,$paras) = @_;
    $self->whine(
      $para->[1]{'start_line'},
      "=pod directives shouldn't be over one line long!  Ignoring all "
       . (@$para - 2) . " lines of content"
    ) if @$para > 3;
  
    # Content ignored unless 'pod_handler' is set
    if (my $pod_handler = $self->{'pod_handler'}) {
        my ($line_num, $line) = map $_, $para->[1]{'start_line'}, $para->[2];
        $line = $line eq '' ? "=pod" : "=pod $line"; # imitate cut_handler output
        $pod_handler->($line, $line_num, $self);
    }
  
    # The surrounding methods set content_seen, so let us remain consistent.
    # I do not know why it was not here before -- should it not be here?
    # $self->{'content_seen'} ||= 1;
  
    return;
  }
  
  sub _ponder_over {
    my ($self,$para,$curr_open,$paras) = @_;
    return 1 unless @$paras;
    my $list_type;
  
    if($paras->[0][0] eq '=item') { # most common case
      $list_type = $self->_get_initial_item_type($paras->[0]);
  
    } elsif($paras->[0][0] eq '=back') {
      # Ignore empty lists by default
      if ($self->{'parse_empty_lists'}) {
        $list_type = 'empty';
      } else {
        shift @$paras;
        return 1;
      }
    } elsif($paras->[0][0] eq '~end') {
      $self->whine(
        $para->[1]{'start_line'},
        "=over is the last thing in the document?!"
      );
      return 1; # But feh, ignore it.
    } else {
      $list_type = 'block';
    }
    $para->[1]{'~type'} = $list_type;
    push @$curr_open, $para;
     # yes, we reuse the paragraph as a stack item
    
    my $content = join ' ', splice @$para, 2;
    my $overness;
    if($content =~ m/^\s*$/s) {
      $para->[1]{'indent'} = 4;
    } elsif($content =~ m/^\s*((?:\d*\.)?\d+)\s*$/s) {
      no integer;
      $para->[1]{'indent'} = $1;
      if($1 == 0) {
        $self->whine(
          $para->[1]{'start_line'},
          "Can't have a 0 in =over $content"
        );
        $para->[1]{'indent'} = 4;
      }
    } else {
      $self->whine(
        $para->[1]{'start_line'},
        "=over should be: '=over' or '=over positive_number'"
      );
      $para->[1]{'indent'} = 4;
    }
    DEBUG > 1 and print STDERR "=over found of type $list_type\n";
    
    $self->{'content_seen'} ||= 1;
    $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]);
  
    return;
  }
        
  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 STDERR "=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'} ), $para->[1]
      );
    } else {
      DEBUG > 1 and print STDERR "=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 = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) {
      $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 STDERR " 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') {
        $self->whine(
            $para->[1]{'start_line'},
            "Expected text after =item, not a $item_type"
        );
        # 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 STDERR " 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 STDERR " Numeric item has the expected value of $expected_value\n";
        
      } else {
        DEBUG > 1 and print STDERR " 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 STDERR "Assimilating following ~Para content into $over_type item\n";
          push @$para, splice @{shift @$paras},2;
        } else {
          DEBUG and print STDERR "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 STDERR " 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 STDERR "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 STDERR "Assimilating following ~Para content into $over_type item\n";
          push @$para, splice @{shift @$paras},2;
        } else {
          DEBUG and print STDERR "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 STDERR " 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 STDERR " giving verbatim treatment...\n";
  
    $para->[1]{'xml:space'} = 'preserve';
  
    my $indent = $self->strip_verbatim_indent;
    if ($indent && ref $indent eq 'CODE') {
        my @shifted = (shift @{$para}, shift @{$para});
        $indent = $indent->($para);
        unshift @{$para}, @shifted;
    }
  
    for(my $i = 2; $i < @$para; $i++) {
      foreach my $line ($para->[$i]) { # just for aliasing
        # Strip indentation.
        $line =~ s/^\Q$indent// if $indent
            && !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted});
        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 STDERR " 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 @_);
    
    while (@_) {
      my $x = shift;
      if (ref($x)) {
        &_traverse_treelet_bit($self, @$x);
      } else {
        $x .= shift while @_ && !ref($_[0]);
        $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') {
        $self->whine(
          $still_open->[1]{start_line} ,
          "=over without closing =back"
        );
  
        $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
      }
  
      $copy[1]{'fake-closer'} = 1;
  
      DEBUG and print STDERR "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 STDERR "_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 STDERR "<<\n";
      for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines
        print STDERR "_verbatim_format $i: $p->[$i]";
      }
      print STDERR ">>\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 STDERR "Scrutinizing line $i: $$p[$i]\n";
      if($p->[$i]   =~ m{^#:([ \^\/\%]*)\n?$}s) {
        DEBUG > 5 and print STDERR "  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 STDERR "  Previous line is formatty!  Skipping this one.\n";
          next;
        } else {
          DEBUG > 5 and print STDERR "  Previous line is non-formatty!  Yay!\n";
        }
      } else {
        DEBUG > 5 and print STDERR "  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 STDERR "_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));
      }
      # Make $formatting and the previous line be exactly the same length,
      # with $formatting having a " " as the last character.
   
      DEBUG > 4 and print STDERR "Formatting <$formatting>    on <", $p->[$i-1], ">\n";
  
  
      my @new_line;
      while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) {
        #print STDERR "Format matches $1\n";
  
        if($2) {
          #print STDERR "SKIPPING <$2>\n";
          push @new_line,
            substr($p->[$i-1], pos($formatting)-length($1), length($1));
        } else {
          #print STDERR "SNARING $+\n";
          push @new_line, [
            (
              $3 ? 'VerbatimB'  :
              $4 ? 'VerbatimI'  :
              $5 ? 'VerbatimBI' : die("Should never get called")
            ), {},
            substr($p->[$i-1], pos($formatting)-length($1), length($1))
          ];
          #print STDERR "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n";
        }
      }
      my @nixed =    
        splice @$p, $i-1, 2, @new_line; # replace myself and the next line
      DEBUG > 10 and print STDERR "Nixed count: ", scalar(@nixed), "\n";
      
      DEBUG > 6 and print STDERR "New version of the above line is these tokens (",
        scalar(@new_line), "):",
        map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n";
      $i--; # So the next line we scrutinize is the line before the one
            #  that we just went and formatted
    }
  
    $p->[0] = 'VerbatimFormatted';
  
    # Collapse adjacent text nodes, just for kicks.
    for( my $i = 2; $i > $#$p; $i++ ) { # work forwards over the tokens except for the last
      if( !ref($p->[$i]) and !ref($p->[$i + 1]) ) {
        DEBUG > 5 and print STDERR "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n";
        $p->[$i] .= splice @$p, $i+1, 1; # merge
        --$i;  # and back up
      }
    }
  
    # Now look for the last text token, and remove the terminal newline
    for( my $i = $#$p; $i >= 2; $i-- ) {
      # work backwards over the tokens, even the first
      if( !ref($p->[$i]) ) {
        if($p->[$i] =~ s/\n$//s) {
          DEBUG > 5 and print STDERR "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n";
        } else {
          DEBUG > 5 and print STDERR
           "No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n";
        }
        last; # we only want the next one
      }
    }
  
    return;
  }
  
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  
  sub _treelet_from_formatting_codes {
    # Given a paragraph, returns a treelet.  Full of scary tokenizing code.
    #  Like [ '~Top', {'start_line' => $start_line},
    #            "I like ",
    #            [ 'B', {}, "pie" ],
    #            "!"
    #       ]
    
    my($self, $para, $start_line, $preserve_space) = @_;
    
    my $treelet = ['~Top', {'start_line' => $start_line},];
    
    unless ($preserve_space || $self->{'preserve_whitespace'}) {
      $para =~ s/\s+/ /g; # collapse and trim all whitespace first.
      $para =~ s/ $//;
      $para =~ s/^ //;
    }
    
    # Only apparent problem the above code is that N<<  >> turns into
    # N<< >>.  But then, word wrapping does that too!  So don't do that!
    
    my @stack;
    my @lineage = ($treelet);
    my $raw = ''; # raw content of L<> fcode before splitting/processing
      # XXX 'raw' is not 100% accurate: all surrounding whitespace is condensed
      # into just 1 ' '. Is this the regex's doing or 'raw's?
    my $inL = 0;
  
    DEBUG > 4 and print STDERR "Paragraph:\n$para\n\n";
   
    # Here begins our frightening tokenizer RE.  The following regex matches
    # text in four main parts:
    #
    #  * Start-codes.  The first alternative matches C< or C<<, the latter
    #    followed by some whitespace.  $1 will hold the entire start code
    #    (including any space following a multiple-angle-bracket delimiter),
    #    and $2 will hold only the additional brackets past the first in a
    #    multiple-bracket delimiter.  length($2) + 1 will be the number of
    #    closing brackets we have to find.
    #
    #  * Closing brackets.  Match some amount of whitespace followed by
    #    multiple close brackets.  The logic to see if this closes anything
    #    is down below.  Note that in order to parse C<<  >> correctly, we
    #    have to use look-behind (?<=\s\s), since the match of the starting
    #    code will have consumed the whitespace.
    #
    #  * A single closing bracket, to close a simple code like C<>.
    #
    #  * Something that isn't a start or end code.  We have to be careful
    #    about accepting whitespace, since perlpodspec says that any whitespace
    #    before a multiple-bracket closing delimiter should be ignored.
    #
    while($para =~
      m/\G
        (?:
          # Match starting codes, including the whitespace following a
          # multiple-delimiter start code.  $1 gets the whole start code and
          # $2 gets all but one of the <s in the multiple-bracket case.
          ([A-Z]<(?:(<+)\s+)?)
          |
          # Match multiple-bracket end codes.  $3 gets the whitespace that
          # should be discarded before an end bracket but kept in other cases
          # and $4 gets the end brackets themselves.
          (\s+|(?<=\s\s))(>{2,})
          |
          (\s?>)          # $5: simple end-codes
          |
          (               # $6: stuff containing no start-codes or end-codes
            (?:
              [^A-Z\s>]
              |
              (?:
                [A-Z](?!<)
              )
              |
              # whitespace is ok, but we don't want to eat the whitespace before
              # a multiple-bracket end code.
              # NOTE: we may still have problems with e.g. S<<    >>
              (?:
                \s(?!\s*>{2,})
              )
            )+
          )
        )
      /xgo
    ) {
      DEBUG > 4 and print STDERR "\nParagraphic tokenstack = (@stack)\n";
      if(defined $1) {
        if(defined $2) {
          DEBUG > 3 and print STDERR "Found complex start-text code \"$1\"\n";
          push @stack, length($2) + 1; 
            # length of the necessary complex end-code string
        } else {
          DEBUG > 3 and print STDERR "Found simple start-text code \"$1\"\n";
          push @stack, 0;  # signal that we're looking for simple
        }
        push @lineage, [ substr($1,0,1), {}, ];  # new node object
        push @{ $lineage[-2] }, $lineage[-1];
        if ('L' eq substr($1,0,1)) {
          $raw = $inL ? $raw.$1 : ''; # reset raw content accumulator
          $inL = 1;
        } else {
          $raw .= $1 if $inL;
        }
  
      } elsif(defined $4) {
        DEBUG > 3 and print STDERR "Found apparent complex end-text code \"$3$4\"\n";
        # This is where it gets messy...
        if(! @stack) {
          # We saw " >>>>" but needed nothing.  This is ALL just stuff then.
          DEBUG > 4 and print STDERR " But it's really just stuff.\n";
          push @{ $lineage[-1] }, $3, $4;
          next;
        } elsif(!$stack[-1]) {
          # We saw " >>>>" but needed only ">".  Back pos up.
          DEBUG > 4 and print STDERR " And that's more than we needed to close simple.\n";
          push @{ $lineage[-1] }, $3; # That was a for-real space, too.
          pos($para) = pos($para) - length($4) + 1;
        } elsif($stack[-1] == length($4)) {
          # We found " >>>>", and it was exactly what we needed.  Commonest case.
          DEBUG > 4 and print STDERR " And that's exactly what we needed to close complex.\n";
        } elsif($stack[-1] < length($4)) {
          # We saw " >>>>" but needed only " >>".  Back pos up.
          DEBUG > 4 and print STDERR " And that's more than we needed to close complex.\n";
          pos($para) = pos($para) - length($4) + $stack[-1];
        } else {
          # We saw " >>>>" but needed " >>>>>>".  So this is all just stuff!
          DEBUG > 4 and print STDERR " But it's really just stuff, because we needed more.\n";
          push @{ $lineage[-1] }, $3, $4;
          next;
        }
        #print STDERR "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n";
  
        push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
        # Keep the element from being childless
        
        pop @stack;
        pop @lineage;
  
        unless (@stack) { # not in an L if there are no open fcodes
          $inL = 0;
          if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') {
            $lineage[-1][-1][1]{'raw'} = $raw
          }
        }
        $raw .= $3.$4 if $inL;
        
      } elsif(defined $5) {
        DEBUG > 3 and print STDERR "Found apparent simple end-text code \"$5\"\n";
  
        if(@stack and ! $stack[-1]) {
          # We're indeed expecting a simple end-code
          DEBUG > 4 and print STDERR " It's indeed an end-code.\n";
  
          if(length($5) == 2) { # There was a space there: " >"
            push @{ $lineage[-1] }, ' ';
          } elsif( 2 == @{ $lineage[-1] } ) { # Closing a childless element
            push @{ $lineage[-1] }, ''; # keep it from being really childless
          }
  
          pop @stack;
          pop @lineage;
        } else {
          DEBUG > 4 and print STDERR " It's just stuff.\n";
          push @{ $lineage[-1] }, $5;
        }
  
        unless (@stack) { # not in an L if there are no open fcodes
          $inL = 0;
          if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') {
            $lineage[-1][-1][1]{'raw'} = $raw
          }
        }
        $raw .= $5 if $inL;
  
      } elsif(defined $6) {
        DEBUG > 3 and print STDERR "Found stuff \"$6\"\n";
        push @{ $lineage[-1] }, $6;
        $raw .= $6 if $inL;
          # XXX does not capture multiplace whitespaces -- 'raw' ends up with
          #     at most 1 leading/trailing whitespace, why not all of it?
  
      } else {
        # should never ever ever ever happen
        DEBUG and print STDERR "AYYAYAAAAA at line ", __LINE__, "\n";
        die "SPORK 512512!";
      }
    }
  
    if(@stack) { # Uhoh, some sequences weren't closed.
      my $x= "...";
      while(@stack) {
        push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
        # Hmmmmm!
  
        my $code         = (pop @lineage)->[0];
        my $ender_length =  pop @stack;
        if($ender_length) {
          --$ender_length;
          $x = $code . ("<" x $ender_length) . " $x " . (">" x $ender_length);
        } else {
          $x = $code . "<$x>";
        }
      }
      DEBUG > 1 and print STDERR "Unterminated $x sequence\n";
      $self->whine($start_line,
        "Unterminated $x sequence",
      );
    }
  
    return $treelet;
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub text_content_of_treelet {  # method: $parser->text_content_of_treelet($lol)
    return stringify_lol($_[1]);
  }
  
  sub stringify_lol {  # function: stringify_lol($lol)
    my $string_form = '';
    _stringify_lol( $_[0] => \$string_form );
    return $string_form;
  }
  
  sub _stringify_lol {  # the real recursor
    my($lol, $to) = @_;
    for(my $i = 2; $i < @$lol; ++$i) {
      if( ref($lol->[$i] || '') and UNIVERSAL::isa($lol->[$i], 'ARRAY') ) {
        _stringify_lol( $lol->[$i], $to);  # recurse!
      } else {
        $$to .= $lol->[$i];
      }
    }
    return;
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  sub _dump_curr_open { # return a string representation of the stack
    my $curr_open = $_[0]{'curr_open'};
  
    return '[empty]' unless @$curr_open;
    return join '; ',
      map {;
             ($_->[0] eq '=for')
               ? ( ($_->[1]{'~really'} || '=over')
                 . ' ' . $_->[1]{'target'})
               : $_->[0]
          }
      @$curr_open
    ;
  }
  
  ###########################################################################
  my %pretty_form = (
    "\a" => '\a', # ding!
    "\b" => '\b', # BS
    "\e" => '\e', # ESC
    "\f" => '\f', # FF
    "\t" => '\t', # tab
    "\cm" => '\cm',
    "\cj" => '\cj',
    "\n" => '\n', # probably overrides one of either \cm or \cj
    '"' => '\"',
    '\\' => '\\\\',
    '$' => '\\$',
    '@' => '\\@',
    '%' => '\\%',
    '#' => '\\#',
  );
  
  sub pretty { # adopted from Class::Classless
    # Not the most brilliant routine, but passable.
    # Don't give it a cyclic data structure!
    my @stuff = @_; # copy
    my $x;
    my $out =
      # join ",\n" .
      join ", ",
      map {;
      if(!defined($_)) {
        "undef";
      } elsif(ref($_) eq 'ARRAY' or ref($_) eq 'Pod::Simple::LinkSection') {
        $x = "[ " . pretty(@$_) . " ]" ;
        $x;
      } elsif(ref($_) eq 'SCALAR') {
        $x = "\\" . pretty($$_) ;
        $x;
      } elsif(ref($_) eq 'HASH') {
        my $hr = $_;
        $x = "{" . join(", ",
          map(pretty($_) . '=>' . pretty($hr->{$_}),
              sort keys %$hr ) ) . "}" ;
        $x;
      } elsif(!length($_)) { q{''} # empty string
      } elsif(
        $_ eq '0' # very common case
        or(
           m/^-?(?:[123456789]\d*|0)(?:\.\d+)?$/s
           and $_ ne '-0' # the strange case that RE lets thru
        )
      ) { $_;
      } else {
          # Yes, explicitly name every character desired. There are shorcuts one
          # could make, but I (Karl Williamson) was afraid that some Perl
          # releases would have bugs in some of them. For example [A-Z] works
          # even on EBCDIC platforms to match exactly the 26 uppercase English
          # letters, but I don't know if it has always worked without bugs. It
          # seemed safest just to list the characters.
          # s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
          s<([^ !#'()*+,\-./0123456789:;\<=\>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]^_`abcdefghijklmnopqrstuvwxyz{|}~])>
           <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
           #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
        qq{"$_"};
      }
    } @stuff;
    # $out =~ s/\n */ /g if length($out) < 75;
    return $out;
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  # A rather unsubtle method of blowing away all the state information
  # from a parser object so it can be reused. Provided as a utility for
  # backward compatibility in Pod::Man, etc. but not recommended for
  # general use.
  
  sub reinit {
    my $self = shift;
    foreach (qw(source_dead source_filename doc_has_started
  start_of_pod_block content_seen last_was_blank paras curr_open
  line_count pod_para_count in_pod ~tried_gen_errata all_errata errata errors_seen
  Title)) {
  
      delete $self->{$_};
    }
  }
  
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  1;
  
POD_SIMPLE_BLACKBOX

$fatpacked{"Pod/Simple/LinkSection.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'POD_SIMPLE_LINKSECTION';
  
  require 5;
  package Pod::Simple::LinkSection;
    # Based somewhat dimly on Array::Autojoin
  use vars qw($VERSION );
  $VERSION = '3.35';
  
  use strict;
  use Pod::Simple::BlackBox;
  use vars qw($VERSION );
  $VERSION = '3.35';
  
  use overload( # So it'll stringify nice
    '""'   => \&Pod::Simple::BlackBox::stringify_lol,
    'bool' => \&Pod::Simple::BlackBox::stringify_lol,
    # '.='   => \&tack_on,  # grudgingly support
    
    'fallback' => 1,         # turn on cleverness
  );
  
  sub tack_on {
    $_[0] = ['', {}, "$_[0]" ];
    return $_[0][2] .= $_[1];
  }
  
  sub as_string {
    goto &Pod::Simple::BlackBox::stringify_lol;
  }
  sub stringify {
    goto &Pod::Simple::BlackBox::stringify_lol;
  }
  
  sub new {
    my $class = shift;
    $class = ref($class) || $class;
    my $new;
    if(@_ == 1) {
      if (!ref($_[0] || '')) { # most common case: one bare string
        return bless ['', {}, $_[0] ], $class;
      } elsif( ref($_[0] || '') eq 'ARRAY') {
        $new = [ @{ $_[0] } ];
      } else {
        Carp::croak( "$class new() doesn't know to clone $new" );
      }
    } else { # misc stuff
      $new = [ '', {}, @_ ];
    }
  
    # By now it's a treelet:  [ 'foo', {}, ... ]
    foreach my $x (@$new) {
      if(ref($x || '') eq 'ARRAY') {
        $x = $class->new($x); # recurse
      } elsif(ref($x || '') eq 'HASH') {
        $x = { %$x };
      }
       # otherwise leave it.
    }
  
    return bless $new, $class;
  }
  
  # Not much in this class is likely to be link-section specific --
  # but it just so happens that link-sections are about the only treelets
  # that are exposed to the user.
  
  1;
  
  __END__
  
  # TODO: let it be an option whether a given subclass even wants little treelets?
  
  
  __END__
  
  =head1 NAME
  
  Pod::Simple::LinkSection -- represent "section" attributes of L codes
  
  =head1 SYNOPSIS
  
   # a long story
  
  =head1 DESCRIPTION
  
  This class is not of interest to general users.
  
  Pod::Simple uses this class for representing the value of the
  "section" attribute of "L" start-element events.  Most applications
  can just use the normal stringification of objects of this class;
  they stringify to just the text content of the section,
  such as "foo" for
  C<< LZ<><Stuff/foo> >>, and "bar" for 
  C<< LZ<><Stuff/bIZ<><ar>> >>.
  
  However, anyone particularly interested in getting the full value of
  the treelet, can just traverse the content of the treeleet
  @$treelet_object.  To wit:
  
  
    % perl -MData::Dumper -e
      "use base qw(Pod::Simple::Methody);
       sub start_L { print Dumper($_[1]{'section'} ) }
       __PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
      "
  Output:
    $VAR1 = bless( [
                     '',
                     {},
                     'b',
                     bless( [
                              'I',
                              {},
                              'ar'
                            ], 'Pod::Simple::LinkSection' ),
                     'baz'
                   ], 'Pod::Simple::LinkSection' );
  
  But stringify it and you get just the text content:
  
    % perl -MData::Dumper -e
      "use base qw(Pod::Simple::Methody);
       sub start_L { print Dumper( '' . $_[1]{'section'} ) }
       __PACKAGE__->new->parse_string_document('=head1 L<Foo/bI<ar>baz>>')
      "
  Output:
    $VAR1 = 'barbaz';
  
  
  =head1 SEE ALSO
  
  L<Pod::Simple>
  
  =head1 SUPPORT
  
  Questions or discussion about POD and Pod::Simple should be sent to the
  pod-people@perl.org mail list. Send an empty email to
  pod-people-subscribe@perl.org to subscribe.
  
  This module is managed in an open GitHub repository,
  L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or
  to clone L<git://github.com/perl-pod/pod-simple.git> and send patches!
  
  Patches against Pod::Simple are welcome. Please send bug reports to
  <bug-pod-simple@rt.cpan.org>.
  
  =head1 COPYRIGHT AND DISCLAIMERS
  
  Copyright (c) 2004 Sean M. Burke.
  
  This library is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.
  
  This program is distributed in the hope that it will be useful, but
  without any warranty; without even the implied warranty of
  merchantability or fitness for a particular purpose.
  
  =head1 AUTHOR
  
  Pod::Simple was created by Sean M. Burke <sburke@cpan.org>.
  But don't bother him, he's retired.
  
  Pod::Simple is maintained by:
  
  =over
  
  =item * Allison Randal C<allison@perl.org>
  
  =item * Hans Dieter Pearcey C<hdp@cpan.org>
  
  =item * David E. Wheeler C<dwheeler@cpan.org>
  
  =back
  
  =cut
POD_SIMPLE_LINKSECTION

$fatpacked{"Pod/Text.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'POD_TEXT';
  # Convert POD data to formatted text.
  #
  # This module converts POD to formatted text.  It replaces the old Pod::Text
  # module that came with versions of Perl prior to 5.6.0 and attempts to match
  # its output except for some specific circumstances where other decisions
  # seemed to produce better output.  It uses Pod::Parser and is designed to be
  # very easy to subclass.
  #
  # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl
  
  ##############################################################################
  # Modules and declarations
  ##############################################################################
  
  package Pod::Text;
  
  use 5.006;
  use strict;
  use warnings;
  
  use vars qw(@ISA @EXPORT %ESCAPES $VERSION);
  
  use Carp qw(carp croak);
  use Encode qw(encode);
  use Exporter ();
  use Pod::Simple ();
  
  @ISA = qw(Pod::Simple Exporter);
  
  # We have to export pod2text for backward compatibility.
  @EXPORT = qw(pod2text);
  
  $VERSION = '4.11';
  
  # Ensure that $Pod::Simple::nbsp and $Pod::Simple::shy are available.  Code
  # taken from Pod::Simple 3.32, but was only added in 3.30.
  my ($NBSP, $SHY);
  if ($Pod::Simple::VERSION ge 3.30) {
      $NBSP = $Pod::Simple::nbsp;
      $SHY  = $Pod::Simple::shy;
  } else {
      if ($] ge 5.007_003) {
          $NBSP = chr utf8::unicode_to_native(0xA0);
          $SHY  = chr utf8::unicode_to_native(0xAD);
      } elsif (Pod::Simple::ASCII) {
          $NBSP = "\xA0";
          $SHY  = "\xAD";
      } else {
          $NBSP = "\x41";
          $SHY  = "\xCA";
      }
  }
  
  ##############################################################################
  # Initialization
  ##############################################################################
  
  # This function handles code blocks.  It's registered as a callback to
  # Pod::Simple and therefore doesn't work as a regular method call, but all it
  # does is call output_code with the line.
  sub handle_code {
      my ($line, $number, $parser) = @_;
      $parser->output_code ($line . "\n");
  }
  
  # Initialize the object and set various Pod::Simple options that we need.
  # Here, we also process any additional options passed to the constructor or
  # set up defaults if none were given.  Note that all internal object keys are
  # in all-caps, reserving all lower-case object keys for Pod::Simple and user
  # arguments.
  sub new {
      my $class = shift;
      my $self = $class->SUPER::new;
  
      # Tell Pod::Simple to handle S<> by automatically inserting &nbsp;.
      $self->nbsp_for_S (1);
  
      # Tell Pod::Simple to keep whitespace whenever possible.
      if ($self->can ('preserve_whitespace')) {
          $self->preserve_whitespace (1);
      } else {
          $self->fullstop_space_harden (1);
      }
  
      # The =for and =begin targets that we accept.
      $self->accept_targets (qw/text TEXT/);
  
      # Ensure that contiguous blocks of code are merged together.  Otherwise,
      # some of the guesswork heuristics don't work right.
      $self->merge_text (1);
  
      # Pod::Simple doesn't do anything useful with our arguments, but we want
      # to put them in our object as hash keys and values.  This could cause
      # problems if we ever clash with Pod::Simple's own internal class
      # variables.
      my %opts = @_;
      my @opts = map { ("opt_$_", $opts{$_}) } keys %opts;
      %$self = (%$self, @opts);
  
      # Send errors to stderr if requested.
      if ($$self{opt_stderr} and not $$self{opt_errors}) {
          $$self{opt_errors} = 'stderr';
      }
      delete $$self{opt_stderr};
  
      # Validate the errors parameter and act on it.
      if (not defined $$self{opt_errors}) {
          $$self{opt_errors} = 'pod';
      }
      if ($$self{opt_errors} eq 'stderr' || $$self{opt_errors} eq 'die') {
          $self->no_errata_section (1);
          $self->complain_stderr (1);
          if ($$self{opt_errors} eq 'die') {
              $$self{complain_die} = 1;
          }
      } elsif ($$self{opt_errors} eq 'pod') {
          $self->no_errata_section (0);
          $self->complain_stderr (0);
      } elsif ($$self{opt_errors} eq 'none') {
          $self->no_errata_section (1);
          $self->no_whining (1);
      } else {
          croak (qq(Invalid errors setting: "$$self{errors}"));
      }
      delete $$self{errors};
  
      # Initialize various things from our parameters.
      $$self{opt_alt}      = 0  unless defined $$self{opt_alt};
      $$self{opt_indent}   = 4  unless defined $$self{opt_indent};
      $$self{opt_margin}   = 0  unless defined $$self{opt_margin};
      $$self{opt_loose}    = 0  unless defined $$self{opt_loose};
      $$self{opt_sentence} = 0  unless defined $$self{opt_sentence};
      $$self{opt_width}    = 76 unless defined $$self{opt_width};
  
      # Figure out what quotes we'll be using for C<> text.
      $$self{opt_quotes} ||= '"';
      if ($$self{opt_quotes} eq 'none') {
          $$self{LQUOTE} = $$self{RQUOTE} = '';
      } elsif (length ($$self{opt_quotes}) == 1) {
          $$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes};
      } elsif (length ($$self{opt_quotes}) % 2 == 0) {
          my $length = length ($$self{opt_quotes}) / 2;
          $$self{LQUOTE} = substr ($$self{opt_quotes}, 0, $length);
          $$self{RQUOTE} = substr ($$self{opt_quotes}, $length);
      } else {
          croak qq(Invalid quote specification "$$self{opt_quotes}");
      }
  
      # If requested, do something with the non-POD text.
      $self->code_handler (\&handle_code) if $$self{opt_code};
  
      # Return the created object.
      return $self;
  }
  
  ##############################################################################
  # Core parsing
  ##############################################################################
  
  # This is the glue that connects the code below with Pod::Simple itself.  The
  # goal is to convert the event stream coming from the POD parser into method
  # calls to handlers once the complete content of a tag has been seen.  Each
  # paragraph or POD command will have textual content associated with it, and
  # as soon as all of a paragraph or POD command has been seen, that content
  # will be passed in to the corresponding method for handling that type of
  # object.  The exceptions are handlers for lists, which have opening tag
  # handlers and closing tag handlers that will be called right away.
  #
  # The internal hash key PENDING is used to store the contents of a tag until
  # all of it has been seen.  It holds a stack of open tags, each one
  # represented by a tuple of the attributes hash for the tag and the contents
  # of the tag.
  
  # Add a block of text to the contents of the current node, formatting it
  # according to the current formatting instructions as we do.
  sub _handle_text {
      my ($self, $text) = @_;
      my $tag = $$self{PENDING}[-1];
      $$tag[1] .= $text;
  }
  
  # Given an element name, get the corresponding method name.
  sub method_for_element {
      my ($self, $element) = @_;
      $element =~ tr/-/_/;
      $element =~ tr/A-Z/a-z/;
      $element =~ tr/_a-z0-9//cd;
      return $element;
  }
  
  # Handle the start of a new element.  If cmd_element is defined, assume that
  # we need to collect the entire tree for this element before passing it to the
  # element method, and create a new tree into which we'll collect blocks of
  # text and nested elements.  Otherwise, if start_element is defined, call it.
  sub _handle_element_start {
      my ($self, $element, $attrs) = @_;
      my $method = $self->method_for_element ($element);
  
      # If we have a command handler, we need to accumulate the contents of the
      # tag before calling it.
      if ($self->can ("cmd_$method")) {
          push (@{ $$self{PENDING} }, [ $attrs, '' ]);
      } elsif ($self->can ("start_$method")) {
          my $method = 'start_' . $method;
          $self->$method ($attrs, '');
      }
  }
  
  # Handle the end of an element.  If we had a cmd_ method for this element,
  # this is where we pass along the text that we've accumulated.  Otherwise, if
  # we have an end_ method for the element, call that.
  sub _handle_element_end {
      my ($self, $element) = @_;
      my $method = $self->method_for_element ($element);
  
      # If we have a command handler, pull off the pending text and pass it to
      # the handler along with the saved attribute hash.
      if ($self->can ("cmd_$method")) {
          my $tag = pop @{ $$self{PENDING} };
          my $method = 'cmd_' . $method;
          my $text = $self->$method (@$tag);
          if (defined $text) {
              if (@{ $$self{PENDING} } > 1) {
                  $$self{PENDING}[-1][1] .= $text;
              } else {
                  $self->output ($text);
              }
          }
      } elsif ($self->can ("end_$method")) {
          my $method = 'end_' . $method;
          $self->$method ();
      }
  }
  
  ##############################################################################
  # Output formatting
  ##############################################################################
  
  # Wrap a line, indenting by the current left margin.  We can't use Text::Wrap
  # because it plays games with tabs.  We can't use formline, even though we'd
  # really like to, because it screws up non-printing characters.  So we have to
  # do the wrapping ourselves.
  sub wrap {
      my $self = shift;
      local $_ = shift;
      my $output = '';
      my $spaces = ' ' x $$self{MARGIN};
      my $width = $$self{opt_width} - $$self{MARGIN};
      while (length > $width) {
          if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
              $output .= $spaces . $1 . "\n";
          } else {
              last;
          }
      }
      $output .= $spaces . $_;
      $output =~ s/\s+$/\n\n/;
      return $output;
  }
  
  # Reformat a paragraph of text for the current margin.  Takes the text to
  # reformat and returns the formatted text.
  sub reformat {
      my $self = shift;
      local $_ = shift;
  
      # If we're trying to preserve two spaces after sentences, do some munging
      # to support that.  Otherwise, smash all repeated whitespace.
      if ($$self{opt_sentence}) {
          s/ +$//mg;
          s/\.\n/. \n/g;
          s/\n/ /g;
          s/   +/  /g;
      } else {
          s/\s+/ /g;
      }
      return $self->wrap ($_);
  }
  
  # Output text to the output device.  Replace non-breaking spaces with spaces
  # and soft hyphens with nothing, and then try to fix the output encoding if
  # necessary to match the input encoding unless UTF-8 output is forced.  This
  # preserves the traditional pass-through behavior of Pod::Text.
  sub output {
      my ($self, @text) = @_;
      my $text = join ('', @text);
      if ($NBSP) {
          $text =~ s/$NBSP/ /g;
      }
      if ($SHY) {
          $text =~ s/$SHY//g;
      }
      unless ($$self{opt_utf8}) {
          my $encoding = $$self{encoding} || '';
          if ($encoding && $encoding ne $$self{ENCODING}) {
              $$self{ENCODING} = $encoding;
              eval { binmode ($$self{output_fh}, ":encoding($encoding)") };
          }
      }
      if ($$self{ENCODE}) {
          print { $$self{output_fh} } encode ('UTF-8', $text);
      } else {
          print { $$self{output_fh} } $text;
      }
  }
  
  # Output a block of code (something that isn't part of the POD text).  Called
  # by preprocess_paragraph only if we were given the code option.  Exists here
  # only so that it can be overridden by subclasses.
  sub output_code { $_[0]->output ($_[1]) }
  
  ##############################################################################
  # Document initialization
  ##############################################################################
  
  # Set up various things that have to be initialized on a per-document basis.
  sub start_document {
      my ($self, $attrs) = @_;
      if ($$attrs{contentless} && !$$self{ALWAYS_EMIT_SOMETHING}) {
          $$self{CONTENTLESS} = 1;
      } else {
          delete $$self{CONTENTLESS};
      }
      my $margin = $$self{opt_indent} + $$self{opt_margin};
  
      # Initialize a few per-document variables.
      $$self{INDENTS} = [];       # Stack of indentations.
      $$self{MARGIN}  = $margin;  # Default left margin.
      $$self{PENDING} = [[]];     # Pending output.
  
      # We have to redo encoding handling for each document.
      $$self{ENCODING} = '';
  
      # When UTF-8 output is set, check whether our output file handle already
      # has a PerlIO encoding layer set.  If it does not, we'll need to encode
      # our output before printing it (handled in the output() sub).  Wrap the
      # check in an eval to handle versions of Perl without PerlIO.
      $$self{ENCODE} = 0;
      if ($$self{opt_utf8}) {
          $$self{ENCODE} = 1;
          eval {
              my @options = (output => 1, details => 1);
              my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1];
              if ($flag & PerlIO::F_UTF8 ()) {
                  $$self{ENCODE} = 0;
                  $$self{ENCODING} = 'UTF-8';
              }
          };
      }
  
      return '';
  }
  
  # Handle the end of the document.  The only thing we do is handle dying on POD
  # errors, since Pod::Parser currently doesn't.
  sub end_document {
      my ($self) = @_;
      if ($$self{complain_die} && $self->errors_seen) {
          croak ("POD document had syntax errors");
      }
  }
  
  ##############################################################################
  # Text blocks
  ##############################################################################
  
  # Intended for subclasses to override, this method returns text with any
  # non-printing formatting codes stripped out so that length() correctly
  # returns the length of the text.  For basic Pod::Text, it does nothing.
  sub strip_format {
      my ($self, $string) = @_;
      return $string;
  }
  
  # This method is called whenever an =item command is complete (in other words,
  # we've seen its associated paragraph or know for certain that it doesn't have
  # one).  It gets the paragraph associated with the item as an argument.  If
  # that argument is empty, just output the item tag; if it contains a newline,
  # output the item tag followed by the newline.  Otherwise, see if there's
  # enough room for us to output the item tag in the margin of the text or if we
  # have to put it on a separate line.
  sub item {
      my ($self, $text) = @_;
      my $tag = $$self{ITEM};
      unless (defined $tag) {
          carp "Item called without tag";
          return;
      }
      undef $$self{ITEM};
  
      # Calculate the indentation and margin.  $fits is set to true if the tag
      # will fit into the margin of the paragraph given our indentation level.
      my $indent = $$self{INDENTS}[-1];
      $indent = $$self{opt_indent} unless defined $indent;
      my $margin = ' ' x $$self{opt_margin};
      my $tag_length = length ($self->strip_format ($tag));
      my $fits = ($$self{MARGIN} - $indent >= $tag_length + 1);
  
      # If the tag doesn't fit, or if we have no associated text, print out the
      # tag separately.  Otherwise, put the tag in the margin of the paragraph.
      if (!$text || $text =~ /^\s+$/ || !$fits) {
          my $realindent = $$self{MARGIN};
          $$self{MARGIN} = $indent;
          my $output = $self->reformat ($tag);
          $output =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
          $output =~ s/\n*$/\n/;
  
          # If the text is just whitespace, we have an empty item paragraph;
          # this can result from =over/=item/=back without any intermixed
          # paragraphs.  Insert some whitespace to keep the =item from merging
          # into the next paragraph.
          $output .= "\n" if $text && $text =~ /^\s*$/;
  
          $self->output ($output);
          $$self{MARGIN} = $realindent;
          $self->output ($self->reformat ($text)) if ($text && $text =~ /\S/);
      } else {
          my $space = ' ' x $indent;
          $space =~ s/^$margin /$margin:/ if $$self{opt_alt};
          $text = $self->reformat ($text);
          $text =~ s/^$margin /$margin:/ if ($$self{opt_alt} && $indent > 0);
          my $tagspace = ' ' x $tag_length;
          $text =~ s/^($space)$tagspace/$1$tag/ or warn "Bizarre space in item";
          $self->output ($text);
      }
  }
  
  # Handle a basic block of text.  The only tricky thing here is that if there
  # is a pending item tag, we need to format this as an item paragraph.
  sub cmd_para {
      my ($self, $attrs, $text) = @_;
      $text =~ s/\s+$/\n/;
      if (defined $$self{ITEM}) {
          $self->item ($text . "\n");
      } else {
          $self->output ($self->reformat ($text . "\n"));
      }
      return '';
  }
  
  # Handle a verbatim paragraph.  Just print it out, but indent it according to
  # our margin.
  sub cmd_verbatim {
      my ($self, $attrs, $text) = @_;
      $self->item if defined $$self{ITEM};
      return if $text =~ /^\s*$/;
      $text =~ s/^(\n*)([ \t]*\S+)/$1 . (' ' x $$self{MARGIN}) . $2/gme;
      $text =~ s/\s*$/\n\n/;
      $self->output ($text);
      return '';
  }
  
  # Handle literal text (produced by =for and similar constructs).  Just output
  # it with the minimum of changes.
  sub cmd_data {
      my ($self, $attrs, $text) = @_;
      $text =~ s/^\n+//;
      $text =~ s/\n{0,2}$/\n/;
      $self->output ($text);
      return '';
  }
  
  ##############################################################################
  # Headings
  ##############################################################################
  
  # The common code for handling all headers.  Takes the header text, the
  # indentation, and the surrounding marker for the alt formatting method.
  sub heading {
      my ($self, $text, $indent, $marker) = @_;
      $self->item ("\n\n") if defined $$self{ITEM};
      $text =~ s/\s+$//;
      if ($$self{opt_alt}) {
          my $closemark = reverse (split (//, $marker));
          my $margin = ' ' x $$self{opt_margin};
          $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n");
      } else {
          $text .= "\n" if $$self{opt_loose};
          my $margin = ' ' x ($$self{opt_margin} + $indent);
          $self->output ($margin . $text . "\n");
      }
      return '';
  }
  
  # First level heading.
  sub cmd_head1 {
      my ($self, $attrs, $text) = @_;
      $self->heading ($text, 0, '====');
  }
  
  # Second level heading.
  sub cmd_head2 {
      my ($self, $attrs, $text) = @_;
      $self->heading ($text, $$self{opt_indent} / 2, '==  ');
  }
  
  # Third level heading.
  sub cmd_head3 {
      my ($self, $attrs, $text) = @_;
      $self->heading ($text, $$self{opt_indent} * 2 / 3 + 0.5, '=   ');
  }
  
  # Fourth level heading.
  sub cmd_head4 {
      my ($self, $attrs, $text) = @_;
      $self->heading ($text, $$self{opt_indent} * 3 / 4 + 0.5, '-   ');
  }
  
  ##############################################################################
  # List handling
  ##############################################################################
  
  # Handle the beginning of an =over block.  Takes the type of the block as the
  # first argument, and then the attr hash.  This is called by the handlers for
  # the four different types of lists (bullet, number, text, and block).
  sub over_common_start {
      my ($self, $attrs) = @_;
      $self->item ("\n\n") if defined $$self{ITEM};
  
      # Find the indentation level.
      my $indent = $$attrs{indent};
      unless (defined ($indent) && $indent =~ /^\s*[-+]?\d{1,4}\s*$/) {
          $indent = $$self{opt_indent};
      }
  
      # Add this to our stack of indents and increase our current margin.
      push (@{ $$self{INDENTS} }, $$self{MARGIN});
      $$self{MARGIN} += ($indent + 0);
      return '';
  }
  
  # End an =over block.  Takes no options other than the class pointer.  Output
  # any pending items and then pop one level of indentation.
  sub over_common_end {
      my ($self) = @_;
      $self->item ("\n\n") if defined $$self{ITEM};
      $$self{MARGIN} = pop @{ $$self{INDENTS} };
      return '';
  }
  
  # Dispatch the start and end calls as appropriate.
  sub start_over_bullet { $_[0]->over_common_start ($_[1]) }
  sub start_over_number { $_[0]->over_common_start ($_[1]) }
  sub start_over_text   { $_[0]->over_common_start ($_[1]) }
  sub start_over_block  { $_[0]->over_common_start ($_[1]) }
  sub end_over_bullet { $_[0]->over_common_end }
  sub end_over_number { $_[0]->over_common_end }
  sub end_over_text   { $_[0]->over_common_end }
  sub end_over_block  { $_[0]->over_common_end }
  
  # The common handler for all item commands.  Takes the type of the item, the
  # attributes, and then the text of the item.
  sub item_common {
      my ($self, $type, $attrs, $text) = @_;
      $self->item if defined $$self{ITEM};
  
      # Clean up the text.  We want to end up with two variables, one ($text)
      # which contains any body text after taking out the item portion, and
      # another ($item) which contains the actual item text.  Note the use of
      # the internal Pod::Simple attribute here; that's a potential land mine.
      $text =~ s/\s+$//;
      my ($item, $index);
      if ($type eq 'bullet') {
          $item = '*';
      } elsif ($type eq 'number') {
          $item = $$attrs{'~orig_content'};
      } else {
          $item = $text;
          $item =~ s/\s*\n\s*/ /g;
          $text = '';
      }
      $$self{ITEM} = $item;
  
      # If body text for this item was included, go ahead and output that now.
      if ($text) {
          $text =~ s/\s*$/\n/;
          $self->item ($text);
      }
      return '';
  }
  
  # Dispatch the item commands to the appropriate place.
  sub cmd_item_bullet { my $self = shift; $self->item_common ('bullet', @_) }
  sub cmd_item_number { my $self = shift; $self->item_common ('number', @_) }
  sub cmd_item_text   { my $self = shift; $self->item_common ('text',   @_) }
  sub cmd_item_block  { my $self = shift; $self->item_common ('block',  @_) }
  
  ##############################################################################
  # Formatting codes
  ##############################################################################
  
  # The simple ones.
  sub cmd_b { return $_[0]{alt} ? "``$_[2]''" : $_[2] }
  sub cmd_f { return $_[0]{alt} ? "\"$_[2]\"" : $_[2] }
  sub cmd_i { return '*' . $_[2] . '*' }
  sub cmd_x { return '' }
  
  # Apply a whole bunch of messy heuristics to not quote things that don't
  # benefit from being quoted.  These originally come from Barrie Slaymaker and
  # largely duplicate code in Pod::Man.
  sub cmd_c {
      my ($self, $attrs, $text) = @_;
  
      # A regex that matches the portion of a variable reference that's the
      # array or hash index, separated out just because we want to use it in
      # several places in the following regex.
      my $index = '(?: \[.*\] | \{.*\} )?';
  
      # Check for things that we don't want to quote, and if we find any of
      # them, return the string with just a font change and no quoting.
      $text =~ m{
        ^\s*
        (?:
           ( [\'\`\"] ) .* \1                             # already quoted
         | \` .* \'                                       # `quoted'
         | \$+ [\#^]? \S $index                           # special ($^Foo, $")
         | [\$\@%&*]+ \#? [:\'\w]+ $index                 # plain var or func
         | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call
         | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number
         | 0x [a-fA-F\d]+                                 # a hex constant
        )
        \s*\z
       }xo && return $text;
  
      # If we didn't return, go ahead and quote the text.
      return $$self{opt_alt}
          ? "``$text''"
          : "$$self{LQUOTE}$text$$self{RQUOTE}";
  }
  
  # Links reduce to the text that we're given, wrapped in angle brackets if it's
  # a URL.
  sub cmd_l {
      my ($self, $attrs, $text) = @_;
      if ($$attrs{type} eq 'url') {
          if (not defined($$attrs{to}) or $$attrs{to} eq $text) {
              return "<$text>";
          } elsif ($$self{opt_nourls}) {
              return $text;
          } else {
              return "$text <$$attrs{to}>";
          }
      } else {
          return $text;
      }
  }
  
  ##############################################################################
  # Backwards compatibility
  ##############################################################################
  
  # The old Pod::Text module did everything in a pod2text() function.  This
  # tries to provide the same interface for legacy applications.
  sub pod2text {
      my @args;
  
      # This is really ugly; I hate doing option parsing in the middle of a
      # module.  But the old Pod::Text module supported passing flags to its
      # entry function, so handle -a and -<number>.
      while ($_[0] =~ /^-/) {
          my $flag = shift;
          if    ($flag eq '-a')       { push (@args, alt => 1)    }
          elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) }
          else {
              unshift (@_, $flag);
              last;
          }
      }
  
      # Now that we know what arguments we're using, create the parser.
      my $parser = Pod::Text->new (@args);
  
      # If two arguments were given, the second argument is going to be a file
      # handle.  That means we want to call parse_from_filehandle(), which means
      # we need to turn the first argument into a file handle.  Magic open will
      # handle the <&STDIN case automagically.
      if (defined $_[1]) {
          my @fhs = @_;
          local *IN;
          unless (open (IN, $fhs[0])) {
              croak ("Can't open $fhs[0] for reading: $!\n");
              return;
          }
          $fhs[0] = \*IN;
          $parser->output_fh ($fhs[1]);
          my $retval = $parser->parse_file ($fhs[0]);
          my $fh = $parser->output_fh ();
          close $fh;
          return $retval;
      } else {
          $parser->output_fh (\*STDOUT);
          return $parser->parse_file (@_);
      }
  }
  
  # Reset the underlying Pod::Simple object between calls to parse_from_file so
  # that the same object can be reused to convert multiple pages.
  sub parse_from_file {
      my $self = shift;
      $self->reinit;
  
      # Fake the old cutting option to Pod::Parser.  This fiddles with internal
      # Pod::Simple state and is quite ugly; we need a better approach.
      if (ref ($_[0]) eq 'HASH') {
          my $opts = shift @_;
          if (defined ($$opts{-cutting}) && !$$opts{-cutting}) {
              $$self{in_pod} = 1;
              $$self{last_was_blank} = 1;
          }
      }
  
      # Do the work.
      my $retval = $self->Pod::Simple::parse_from_file (@_);
  
      # Flush output, since Pod::Simple doesn't do this.  Ideally we should also
      # close the file descriptor if we had to open one, but we can't easily
      # figure this out.
      my $fh = $self->output_fh ();
      my $oldfh = select $fh;
      my $oldflush = $|;
      $| = 1;
      print $fh '';
      $| = $oldflush;
      select $oldfh;
      return $retval;
  }
  
  # Pod::Simple failed to provide this backward compatibility function, so
  # implement it ourselves.  File handles are one of the inputs that
  # parse_from_file supports.
  sub parse_from_filehandle {
      my $self = shift;
      $self->parse_from_file (@_);
  }
  
  # Pod::Simple's parse_file doesn't set output_fh.  Wrap the call and do so
  # ourself unless it was already set by the caller, since our documentation has
  # always said that this should work.
  sub parse_file {
      my ($self, $in) = @_;
      unless (defined $$self{output_fh}) {
          $self->output_fh (\*STDOUT);
      }
      return $self->SUPER::parse_file ($in);
  }
  
  # Do the same for parse_lines, just to be polite.  Pod::Simple's man page
  # implies that the caller is responsible for setting this, but I don't see any
  # reason not to set a default.
  sub parse_lines {
      my ($self, @lines) = @_;
      unless (defined $$self{output_fh}) {
          $self->output_fh (\*STDOUT);
      }
      return $self->SUPER::parse_lines (@lines);
  }
  
  # Likewise for parse_string_document.
  sub parse_string_document {
      my ($self, $doc) = @_;
      unless (defined $$self{output_fh}) {
          $self->output_fh (\*STDOUT);
      }
      return $self->SUPER::parse_string_document ($doc);
  }
  
  ##############################################################################
  # Module return value and documentation
  ##############################################################################
  
  1;
  __END__
  
  =for stopwords
  alt stderr Allbery Sean Burke's Christiansen UTF-8 pre-Unicode utf8 nourls
  parsers
  
  =head1 NAME
  
  Pod::Text - Convert POD data to formatted text
  
  =head1 SYNOPSIS
  
      use Pod::Text;
      my $parser = Pod::Text->new (sentence => 1, width => 78);
  
      # Read POD from STDIN and write to STDOUT.
      $parser->parse_from_filehandle;
  
      # Read POD from file.pod and write to file.txt.
      $parser->parse_from_file ('file.pod', 'file.txt');
  
  =head1 DESCRIPTION
  
  Pod::Text is a module that can convert documentation in the POD format
  (the preferred language for documenting Perl) into formatted text.  It
  uses no special formatting controls or codes whatsoever, and its output is
  therefore suitable for nearly any device.
  
  As a derived class from Pod::Simple, Pod::Text supports the same methods and
  interfaces.  See L<Pod::Simple> for all the details; briefly, one creates a
  new parser with C<< Pod::Text->new() >> and then normally calls parse_file().
  
  new() can take options, in the form of key/value pairs, that control the
  behavior of the parser.  The currently recognized options are:
  
  =over 4
  
  =item alt
  
  If set to a true value, selects an alternate output format that, among other
  things, uses a different heading style and marks C<=item> entries with a
  colon in the left margin.  Defaults to false.
  
  =item code
  
  If set to a true value, the non-POD parts of the input file will be included
  in the output.  Useful for viewing code documented with POD blocks with the
  POD rendered and the code left intact.
  
  =item errors
  
  How to report errors.  C<die> says to throw an exception on any POD
  formatting error.  C<stderr> says to report errors on standard error, but
  not to throw an exception.  C<pod> says to include a POD ERRORS section
  in the resulting documentation summarizing the errors.  C<none> ignores
  POD errors entirely, as much as possible.
  
  The default is C<pod>.
  
  =item indent
  
  The number of spaces to indent regular text, and the default indentation for
  C<=over> blocks.  Defaults to 4.
  
  =item loose
  
  If set to a true value, a blank line is printed after a C<=head1> heading.
  If set to false (the default), no blank line is printed after C<=head1>,
  although one is still printed after C<=head2>.  This is the default because
  it's the expected formatting for manual pages; if you're formatting
  arbitrary text documents, setting this to true may result in more pleasing
  output.
  
  =item margin
  
  The width of the left margin in spaces.  Defaults to 0.  This is the margin
  for all text, including headings, not the amount by which regular text is
  indented; for the latter, see the I<indent> option.  To set the right
  margin, see the I<width> option.
  
  =item nourls
  
  Normally, LZ<><> formatting codes with a URL but anchor text are formatted
  to show both the anchor text and the URL.  In other words:
  
      L<foo|http://example.com/>
  
  is formatted as:
  
      foo <http://example.com/>
  
  This option, if set to a true value, suppresses the URL when anchor text
  is given, so this example would be formatted as just C<foo>.  This can
  produce less cluttered output in cases where the URLs are not particularly
  important.
  
  =item quotes
  
  Sets the quote marks used to surround CE<lt>> text.  If the value is a
  single character, it is used as both the left and right quote.  Otherwise,
  it is split in half, and the first half of the string is used as the left
  quote and the second is used as the right quote.
  
  This may also be set to the special value C<none>, in which case no quote
  marks are added around CE<lt>> text.
  
  =item sentence
  
  If set to a true value, Pod::Text will assume that each sentence ends in two
  spaces, and will try to preserve that spacing.  If set to false, all
  consecutive whitespace in non-verbatim paragraphs is compressed into a
  single space.  Defaults to false.
  
  =item stderr
  
  Send error messages about invalid POD to standard error instead of
  appending a POD ERRORS section to the generated output.  This is
  equivalent to setting C<errors> to C<stderr> if C<errors> is not already
  set.  It is supported for backward compatibility.
  
  =item utf8
  
  By default, Pod::Text uses the same output encoding as the input encoding
  of the POD source (provided that Perl was built with PerlIO; otherwise, it
  doesn't encode its output).  If this option is given, the output encoding
  is forced to UTF-8.
  
  Be aware that, when using this option, the input encoding of your POD
  source should be properly declared unless it's US-ASCII.  Pod::Simple will
  attempt to guess the encoding and may be successful if it's Latin-1 or
  UTF-8, but it will produce warnings.  Use the C<=encoding> command to
  declare the encoding.  See L<perlpod(1)> for more information.
  
  =item width
  
  The column at which to wrap text on the right-hand side.  Defaults to 76.
  
  =back
  
  The standard Pod::Simple method parse_file() takes one argument naming the
  POD file to read from.  By default, the output is sent to C<STDOUT>, but
  this can be changed with the output_fh() method.
  
  The standard Pod::Simple method parse_from_file() takes up to two
  arguments, the first being the input file to read POD from and the second
  being the file to write the formatted output to.
  
  You can also call parse_lines() to parse an array of lines or
  parse_string_document() to parse a document already in memory.  As with
  parse_file(), parse_lines() and parse_string_document() default to sending
  their output to C<STDOUT> unless changed with the output_fh() method.
  
  To put the output from any parse method into a string instead of a file
  handle, call the output_string() method instead of output_fh().
  
  See L<Pod::Simple> for more specific details on the methods available to
  all derived parsers.
  
  =head1 DIAGNOSTICS
  
  =over 4
  
  =item Bizarre space in item
  
  =item Item called without tag
  
  (W) Something has gone wrong in internal C<=item> processing.  These
  messages indicate a bug in Pod::Text; you should never see them.
  
  =item Can't open %s for reading: %s
  
  (F) Pod::Text was invoked via the compatibility mode pod2text() interface
  and the input file it was given could not be opened.
  
  =item Invalid errors setting "%s"
  
  (F) The C<errors> parameter to the constructor was set to an unknown value.
  
  =item Invalid quote specification "%s"
  
  (F) The quote specification given (the C<quotes> option to the
  constructor) was invalid.  A quote specification must be either one
  character long or an even number (greater than one) characters long.
  
  =item POD document had syntax errors
  
  (F) The POD document being formatted had syntax errors and the C<errors>
  option was set to C<die>.
  
  =back
  
  =head1 BUGS
  
  Encoding handling assumes that PerlIO is available and does not work
  properly if it isn't.  The C<utf8> option is therefore not supported
  unless Perl is built with PerlIO support.
  
  =head1 CAVEATS
  
  If Pod::Text is given the C<utf8> option, the encoding of its output file
  handle will be forced to UTF-8 if possible, overriding any existing
  encoding.  This will be done even if the file handle is not created by
  Pod::Text and was passed in from outside.  This maintains consistency
  regardless of PERL_UNICODE and other settings.
  
  If the C<utf8> option is not given, the encoding of its output file handle
  will be forced to the detected encoding of the input POD, which preserves
  whatever the input text is.  This ensures backward compatibility with
  earlier, pre-Unicode versions of this module, without large numbers of
  Perl warnings.
  
  This is not ideal, but it seems to be the best compromise.  If it doesn't
  work for you, please let me know the details of how it broke.
  
  =head1 NOTES
  
  This is a replacement for an earlier Pod::Text module written by Tom
  Christiansen.  It has a revamped interface, since it now uses Pod::Simple,
  but an interface roughly compatible with the old Pod::Text::pod2text()
  function is still available.  Please change to the new calling convention,
  though.
  
  The original Pod::Text contained code to do formatting via termcap
  sequences, although it wasn't turned on by default and it was problematic to
  get it to work at all.  This rewrite doesn't even try to do that, but a
  subclass of it does.  Look for L<Pod::Text::Termcap>.
  
  =head1 AUTHOR
  
  Russ Allbery <rra@cpan.org>, based I<very> heavily on the original
  Pod::Text by Tom Christiansen <tchrist@mox.perl.com> and its conversion to
  Pod::Parser by Brad Appleton <bradapp@enteract.com>.  Sean Burke's initial
  conversion of Pod::Man to use Pod::Simple provided much-needed guidance on
  how to use Pod::Simple.
  
  =head1 COPYRIGHT AND LICENSE
  
  Copyright 1999-2002, 2004, 2006, 2008-2009, 2012-2016, 2018 Russ Allbery
  <rra@cpan.org>
  
  This program is free software; you may redistribute it and/or modify it
  under the same terms as Perl itself.
  
  =head1 SEE ALSO
  
  L<Pod::Simple>, L<Pod::Text::Termcap>, L<perlpod(1)>, L<pod2text(1)>
  
  The current version of this module is always available from its web site at
  L<https://www.eyrie.org/~eagle/software/podlators/>.  It is also part of the
  Perl core distribution as of 5.6.0.
  
  =cut
  
  # Local Variables:
  # copyright-at-end-flag: t
  # End:
POD_TEXT

$fatpacked{"Pod/Usage.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'POD_USAGE';
  #############################################################################
  # Pod/Usage.pm -- print usage messages for the running script.
  #
  # Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
  # Copyright (c) 2001-2016 by Marek Rouchal.
  # This file is part of "Pod-Usage". Pod-Usage is free software;
  # you can redistribute it and/or modify it under the same terms
  # as Perl itself.
  #############################################################################
  
  package Pod::Usage;
  use strict;
  
  use vars qw($VERSION @ISA @EXPORT);
  $VERSION = '1.69';  ## Current version of this package
  require  5.006;    ## requires this Perl version or later
  
  #use diagnostics;
  use Carp;
  use Config;
  use Exporter;
  use File::Spec;
  
  @EXPORT = qw(&pod2usage);
  BEGIN {
      $Pod::Usage::Formatter ||= 'Pod::Text';
      eval "require $Pod::Usage::Formatter";
      die $@ if $@;
      @ISA = ( $Pod::Usage::Formatter );
  }
  
  our $MAX_HEADING_LEVEL = 3;
  
  ##---------------------------------------------------------------------------
  
  ##---------------------------------
  ## Function definitions begin here
  ##---------------------------------
  
  sub pod2usage {
      local($_) = shift;
      my %opts;
      ## Collect arguments
      if (@_ > 0) {
          ## Too many arguments - assume that this is a hash and
          ## the user forgot to pass a reference to it.
          %opts = ($_, @_);
      }
      elsif (!defined $_) {
        $_ = '';
      }
      elsif (ref $_) {
          ## User passed a ref to a hash
          %opts = %{$_}  if (ref($_) eq 'HASH');
      }
      elsif (/^[-+]?\d+$/) {
          ## User passed in the exit value to use
          $opts{'-exitval'} =  $_;
      }
      else {
          ## User passed in a message to print before issuing usage.
          $_  and  $opts{'-message'} = $_;
      }
  
      ## Need this for backward compatibility since we formerly used
      ## options that were all uppercase words rather than ones that
      ## looked like Unix command-line options.
      ## to be uppercase keywords)
      %opts = map {
          my ($key, $val) = ($_, $opts{$_});
          $key =~ s/^(?=\w)/-/;
          $key =~ /^-msg/i   and  $key = '-message';
          $key =~ /^-exit/i  and  $key = '-exitval';
          lc($key) => $val;
      } (keys %opts);
  
      ## Now determine default -exitval and -verbose values to use
      if ((! defined $opts{'-exitval'}) && (! defined $opts{'-verbose'})) {
          $opts{'-exitval'} = 2;
          $opts{'-verbose'} = 0;
      }
      elsif (! defined $opts{'-exitval'}) {
          $opts{'-exitval'} = ($opts{'-verbose'} > 0) ? 1 : 2;
      }
      elsif (! defined $opts{'-verbose'}) {
          $opts{'-verbose'} = (lc($opts{'-exitval'}) eq 'noexit' ||
                               $opts{'-exitval'} < 2);
      }
  
      ## Default the output file
      $opts{'-output'} = (lc($opts{'-exitval'}) eq 'noexit' ||
                          $opts{'-exitval'} < 2) ? \*STDOUT : \*STDERR
              unless (defined $opts{'-output'});
      ## Default the input file
      $opts{'-input'} = $0  unless (defined $opts{'-input'});
  
      ## Look up input file in path if it doesn't exist.
      unless ((ref $opts{'-input'}) || (-e $opts{'-input'})) {
          my $basename = $opts{'-input'};
          my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/i) ? ';'
                              : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' :  ':');
          my $pathspec = $opts{'-pathlist'} || $ENV{PATH} || $ENV{PERL5LIB};
  
          my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
          for my $dirname (@paths) {
              $_ = File::Spec->catfile($dirname, $basename)  if length;
              last if (-e $_) && ($opts{'-input'} = $_);
          }
      }
  
      ## Now create a pod reader and constrain it to the desired sections.
      my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts);
      if ($opts{'-verbose'} == 0) {
          $parser->select('(?:SYNOPSIS|USAGE)\s*');
      }
      elsif ($opts{'-verbose'} == 1) {
          my $opt_re = '(?i)' .
                       '(?:OPTIONS|ARGUMENTS)' .
                       '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
          $parser->select( '(?:SYNOPSIS|USAGE)\s*', $opt_re, "DESCRIPTION/$opt_re" );
      }
      elsif ($opts{'-verbose'} >= 2 && $opts{'-verbose'} != 99) {
          $parser->select('.*');
      }
      elsif ($opts{'-verbose'} == 99) {
          my $sections = $opts{'-sections'};
          $parser->select( (ref $sections) ? @$sections : $sections );
          $opts{'-verbose'} = 1;
      }
  
      ## Check for perldoc
      my $progpath = $opts{'-perldoc'} ? $opts{'-perldoc'} :
          File::Spec->catfile($Config{scriptdirexp} 
  	|| $Config{scriptdir}, 'perldoc');
  
      my $version = sprintf("%vd",$^V);
      if ($Config{versiononly} and $Config{startperl} =~ /\Q$version\E$/ ) {
        $progpath .= $version;
      }
      $opts{'-noperldoc'} = 1 unless -e $progpath;
  
      ## Now translate the pod document and then exit with the desired status
      if (      !$opts{'-noperldoc'}
           and  $opts{'-verbose'} >= 2
           and  !ref($opts{'-input'})
           and  $opts{'-output'} == \*STDOUT )
      {
         ## spit out the entire PODs. Might as well invoke perldoc
         print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'});
         if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) {
           # the perldocs back to 5.005 should all have -F
  	 # without -F there are warnings in -T scripts
  	 my $f = $1;
           my @perldoc_cmd = ($progpath);
  	 if ($opts{'-perldocopt'}) {
             $opts{'-perldocopt'} =~ s/^\s+|\s+$//g;
  	   push @perldoc_cmd, split(/\s+/, $opts{'-perldocopt'});
  	 }
  	 push @perldoc_cmd, ('-F', $f);
           unshift @perldoc_cmd, $opts{'-perlcmd'} if $opts{'-perlcmd'};
           system(@perldoc_cmd);
           if($?) {
             # RT16091: fall back to more if perldoc failed
             system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1);
           }
         } else {
           croak "Unspecified input file or insecure argument.\n";
         }
      }
      else {
         $parser->parse_from_file($opts{'-input'}, $opts{'-output'});
      }
  
      exit($opts{'-exitval'})  unless (lc($opts{'-exitval'}) eq 'noexit');
  }
  
  ##---------------------------------------------------------------------------
  
  ##-------------------------------
  ## Method definitions begin here
  ##-------------------------------
  
  sub new {
      my $this = shift;
      my $class = ref($this) || $this;
      my %params = @_;
      my $self = {%params};
      bless $self, $class;
      if ($self->can('initialize')) {
          $self->initialize();
      } else {
          # pass through options to Pod::Text
          my %opts;
         	for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) {
              my $val = $params{USAGE_OPTIONS}{"-$_"};
              $opts{$_} = $val if defined $val;
          }
          $self = $self->SUPER::new(%opts);
          %$self = (%$self, %params);
      }
      return $self;
  }
  
  # This subroutine was copied in whole-cloth from Pod::Select 1.60 in order to
  # allow the ejection of Pod::Select from the core without breaking Pod::Usage.
  # -- rjbs, 2013-03-18
  sub _compile_section_spec {
      my ($section_spec) = @_;
      my (@regexs, $negated);
  
      ## Compile the spec into a list of regexs
      local $_ = $section_spec;
      s{\\\\}{\001}g;  ## handle escaped backward slashes
      s{\\/}{\002}g;   ## handle escaped forward slashes
  
      ## Parse the regexs for the heading titles
      @regexs = split(/\//, $_, $MAX_HEADING_LEVEL);
  
      ## Set default regex for ommitted levels
      for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
          $regexs[$i]  = '.*'  unless ((defined $regexs[$i])
                                       && (length $regexs[$i]));
      }
      ## Modify the regexs as needed and validate their syntax
      my $bad_regexs = 0;
      for (@regexs) {
          $_ .= '.+'  if ($_ eq '!');
          s{\001}{\\\\}g;       ## restore escaped backward slashes
          s{\002}{\\/}g;        ## restore escaped forward slashes
          $negated = s/^\!//;   ## check for negation
          eval "m{$_}";         ## check regex syntax
          if ($@) {
              ++$bad_regexs;
              carp qq{Bad regular expression /$_/ in "$section_spec": $@\n};
          }
          else {
              ## Add the forward and rear anchors (and put the negator back)
              $_ = '^' . $_  unless (/^\^/);
              $_ = $_ . '$'  unless (/\$$/);
              $_ = '!' . $_  if ($negated);
          }
      }
      return  (! $bad_regexs) ? [ @regexs ] : undef;
  }
  
  sub select {
      my ($self, @sections) = @_;
      if ($ISA[0]->can('select')) {
          $self->SUPER::select(@sections);
      } else {
          # we're using Pod::Simple - need to mimic the behavior of Pod::Select
          my $add = ($sections[0] eq '+') ? shift(@sections) : '';
          ## Reset the set of sections to use
          unless (@sections) {
            delete $self->{USAGE_SELECT} unless ($add);
            return;
          }
          $self->{USAGE_SELECT} = []
            unless ($add && $self->{USAGE_SELECT});
          my $sref = $self->{USAGE_SELECT};
          ## Compile each spec
          for my $spec (@sections) {
            my $cs = _compile_section_spec($spec);
            if ( defined $cs ) {
              ## Store them in our sections array
              push(@$sref, $cs);
            } else {
              carp qq{Ignoring section spec "$spec"!\n};
            }
          }
      }
  }
  
  # Override Pod::Text->seq_i to return just "arg", not "*arg*".
  sub seq_i { return $_[1] }
  # Override Pod::Text->cmd_i to return just "arg", not "*arg*".
  # newer version based on Pod::Simple
  sub cmd_i { return $_[2] }
  
  # This overrides the Pod::Text method to do something very akin to what
  # Pod::Select did as well as the work done below by preprocess_paragraph.
  # Note that the below is very, very specific to Pod::Text and Pod::Simple.
  sub _handle_element_end {
      my ($self, $element) = @_;
      if ($element eq 'head1') {
          $self->{USAGE_HEADINGS} = [ $$self{PENDING}[-1][1] ];
          if ($self->{USAGE_OPTIONS}->{-verbose} < 2) {
              $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/;
          }
      } elsif ($element =~ /^head(\d+)$/ && $1) { # avoid 0
          my $idx = $1 - 1;
          $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS});
          $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1];
          # we have to get rid of the lower headings
          splice(@{$self->{USAGE_HEADINGS}},$idx+1);
      }
      if ($element =~ /^head\d+$/) {
          $$self{USAGE_SKIPPING} = 1;
          if (!$$self{USAGE_SELECT} || !@{ $$self{USAGE_SELECT} }) {
              $$self{USAGE_SKIPPING} = 0;
          } else {
              my @headings = @{$$self{USAGE_HEADINGS}};
              for my $section_spec ( @{$$self{USAGE_SELECT}} ) {
                  my $match = 1;
                  for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) {
                      $headings[$i] = '' unless defined $headings[$i];
                      my $regex   = $section_spec->[$i];
                      my $negated = ($regex =~ s/^\!//);
                      $match  &= ($negated ? ($headings[$i] !~ /${regex}/)
                                           : ($headings[$i] =~ /${regex}/));
                      last unless ($match);
                  } # end heading levels
                  if ($match) {
                    $$self{USAGE_SKIPPING} = 0;
                    last;
                  }
              } # end sections
          }
  
          # Try to do some lowercasing instead of all-caps in headings, and use
          # a colon to end all headings.
          if($self->{USAGE_OPTIONS}->{-verbose} < 2) {
              local $_ = $$self{PENDING}[-1][1];
              s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
              s/\s*$/:/  unless (/:\s*$/);
              $_ .= "\n";
              $$self{PENDING}[-1][1] = $_;
          }
      }
      if ($$self{USAGE_SKIPPING} && $element !~ m/^over-|^[BCFILSZ]$/) {
          pop @{ $$self{PENDING} };
      } else {
          $self->SUPER::_handle_element_end($element);
      }
  }
  
  # required for Pod::Simple API
  sub start_document {
      my $self = shift;
      $self->SUPER::start_document();
      my $msg = $self->{USAGE_OPTIONS}->{-message}  or  return 1;
      my $out_fh = $self->output_fh();
      print $out_fh "$msg\n";
  }
  
  # required for old Pod::Parser API
  sub begin_pod {
      my $self = shift;
      $self->SUPER::begin_pod();  ## Have to call superclass
      my $msg = $self->{USAGE_OPTIONS}->{-message}  or  return 1;
      my $out_fh = $self->output_handle();
      print $out_fh "$msg\n";
  }
  
  sub preprocess_paragraph {
      my $self = shift;
      local $_ = shift;
      my $line = shift;
      ## See if this is a heading and we aren't printing the entire manpage.
      if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) {
          ## Change the title of the SYNOPSIS section to USAGE
          s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/;
          ## Try to do some lowercasing instead of all-caps in headings
          s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge;
          ## Use a colon to end all headings
          s/\s*$/:/  unless (/:\s*$/);
          $_ .= "\n";
      }
      return  $self->SUPER::preprocess_paragraph($_);
  }
  
  1; # keep require happy
  
  __END__
  
  =head1 NAME
  
  Pod::Usage - print a usage message from embedded pod documentation
  
  =head1 SYNOPSIS
  
    use Pod::Usage
  
    my $message_text  = "This text precedes the usage message.";
    my $exit_status   = 2;          ## The exit status to use
    my $verbose_level = 0;          ## The verbose level to use
    my $filehandle    = \*STDERR;   ## The filehandle to write to
  
    pod2usage($message_text);
  
    pod2usage($exit_status);
  
    pod2usage( { -message => $message_text ,
                 -exitval => $exit_status  ,  
                 -verbose => $verbose_level,  
                 -output  => $filehandle } );
  
    pod2usage(   -msg     => $message_text ,
                 -exitval => $exit_status  ,  
                 -verbose => $verbose_level,  
                 -output  => $filehandle );
  
    pod2usage(   -verbose => 2,
                 -noperldoc => 1  );
  
    pod2usage(   -verbose => 2,
                 -perlcmd => $path_to_perl,
                 -perldoc => $path_to_perldoc,
                 -perldocopt => $perldoc_options );
  
  =head1 ARGUMENTS
  
  B<pod2usage> should be given either a single argument, or a list of
  arguments corresponding to an associative array (a "hash"). When a single
  argument is given, it should correspond to exactly one of the following:
  
  =over 4
  
  =item *
  
  A string containing the text of a message to print I<before> printing
  the usage message
  
  =item *
  
  A numeric value corresponding to the desired exit status
  
  =item *
  
  A reference to a hash
  
  =back
  
  If more than one argument is given then the entire argument list is
  assumed to be a hash.  If a hash is supplied (either as a reference or
  as a list) it should contain one or more elements with the following
  keys:
  
  =over 4
  
  =item C<-message> I<string>
  
  =item C<-msg> I<string>
  
  The text of a message to print immediately prior to printing the
  program's usage message. 
  
  =item C<-exitval> I<value>
  
  The desired exit status to pass to the B<exit()> function.
  This should be an integer, or else the string "NOEXIT" to
  indicate that control should simply be returned without
  terminating the invoking process.
  
  =item C<-verbose> I<value>
  
  The desired level of "verboseness" to use when printing the usage message.
  If the value is 0, then only the "SYNOPSIS" section of the pod documentation
  is printed. If the value is 1, then the "SYNOPSIS" section, along with any
  section entitled "OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is
  printed. If the corresponding value is 2 or more then the entire manpage is
  printed, using L<perldoc> if available; otherwise L<Pod::Text> is used for
  the formatting. For better readability, the all-capital headings are
  downcased, e.g. C<SYNOPSIS> =E<gt> C<Synopsis>.
  
  The special verbosity level 99 requires to also specify the -sections
  parameter; then these sections are extracted and printed.
  
  =item C<-sections> I<spec>
  
  There are two ways to specify the selection. Either a string (scalar) 
  representing a selection regexp for sections to be printed when -verbose
  is set to 99, e.g.
  
    "NAME|SYNOPSIS|DESCRIPTION|VERSION"
  
  With the above regexp all content following (and including) any of the
  given C<=head1> headings will be shown. It is possible to restrict the 
  output to particular subsections only, e.g.:
  
    "DESCRIPTION/Algorithm"
  
  This will output only the C<=head2 Algorithm> heading and content within
  the C<=head1 DESCRIPTION> section. The regexp binding is stronger than the
  section separator, such that e.g.:
  
    "DESCRIPTION|OPTIONS|ENVIORNMENT/Caveats"
  
  will print any C<=head2 Caveats> section (only) within any of the three
  C<=head1> sections.
  
  Alternatively, an array reference of section specifications can be used:
  
    pod2usage(-verbose => 99, -sections => [
      qw(DESCRIPTION DESCRIPTION/Introduction) ] );
  
  This will print only the content of C<=head1 DESCRIPTION> and the 
  C<=head2 Introduction> sections, but no other C<=head2>, and no other
  C<=head1> either.
  
  =item C<-output> I<handle>
  
  A reference to a filehandle, or the pathname of a file to which the
  usage message should be written. The default is C<\*STDERR> unless the
  exit value is less than 2 (in which case the default is C<\*STDOUT>).
  
  =item C<-input> I<handle>
  
  A reference to a filehandle, or the pathname of a file from which the
  invoking script's pod documentation should be read.  It defaults to the
  file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>).
  
  If you are calling B<pod2usage()> from a module and want to display
  that module's POD, you can use this:
  
    use Pod::Find qw(pod_where);
    pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) );
  
  =item C<-pathlist> I<string>
  
  A list of directory paths. If the input file does not exist, then it
  will be searched for in the given directory list (in the order the
  directories appear in the list). It defaults to the list of directories
  implied by C<$ENV{PATH}>. The list may be specified either by a reference
  to an array, or by a string of directory paths which use the same path
  separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for
  MSWin32 and DOS).
  
  =item C<-noperldoc>
  
  By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is
  specified. This does not work well e.g. if the script was packed
  with L<PAR>. The -noperldoc option suppresses the external call to
  L<perldoc> and uses the simple text formatter (L<Pod::Text>) to 
  output the POD.
  
  =item C<-perlcmd>
  
  By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is
  specified. In case of special or unusual Perl installations,
  the -perlcmd option may be used to supply the path to a L<perl> executable
  which should run L<perldoc>.
  
  =item C<-perldoc> I<path-to-perldoc>
  
  By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is
  specified. In case L<perldoc> is not installed where the L<perl> interpreter
  thinks it is (see L<Config>), the -perldoc option may be used to supply
  the correct path to L<perldoc>.
  
  =item C<-perldocopt> I<string>
  
  By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is specified.
  The -perldocopt option may be used to supply options to L<perldoc>. The
  string may contain several, space-separated options.
  
  =back
  
  =head2 Formatting base class
  
  The default text formatter is L<Pod::Text>. The base class for Pod::Usage can
  be defined by pre-setting C<$Pod::Usage::Formatter> I<before>
  loading Pod::Usage, e.g.:
  
      BEGIN { $Pod::Usage::Formatter = 'Pod::Text::Termcap'; }
      use Pod::Usage qw(pod2usage);
  
  Pod::Usage uses L<Pod::Simple>'s _handle_element_end() method to implement
  the section selection, and in case of verbosity < 2 it down-cases the
  all-caps headings to first capital letter and rest lowercase, and adds
  a colon/newline at the end of the headings, for better readability. Same for
  verbosity = 99.
  
  =head2 Pass-through options
  
  The following options are passed through to the underlying text formatter.
  See the manual pages of these modules for more information.
  
    alt code indent loose margin quotes sentence stderr utf8 width
  
  =head1 DESCRIPTION
  
  B<pod2usage> will print a usage message for the invoking script (using
  its embedded pod documentation) and then exit the script with the
  desired exit status. The usage message printed may have any one of three
  levels of "verboseness": If the verbose level is 0, then only a synopsis
  is printed. If the verbose level is 1, then the synopsis is printed
  along with a description (if present) of the command line options and
  arguments. If the verbose level is 2, then the entire manual page is
  printed.
  
  Unless they are explicitly specified, the default values for the exit
  status, verbose level, and output stream to use are determined as
  follows:
  
  =over 4
  
  =item *
  
  If neither the exit status nor the verbose level is specified, then the
  default is to use an exit status of 2 with a verbose level of 0.
  
  =item *
  
  If an exit status I<is> specified but the verbose level is I<not>, then the
  verbose level will default to 1 if the exit status is less than 2 and
  will default to 0 otherwise.
  
  =item *
  
  If an exit status is I<not> specified but verbose level I<is> given, then
  the exit status will default to 2 if the verbose level is 0 and will
  default to 1 otherwise.
  
  =item *
  
  If the exit status used is less than 2, then output is printed on
  C<STDOUT>.  Otherwise output is printed on C<STDERR>.
  
  =back
  
  Although the above may seem a bit confusing at first, it generally does
  "the right thing" in most situations.  This determination of the default
  values to use is based upon the following typical Unix conventions:
  
  =over 4
  
  =item *
  
  An exit status of 0 implies "success". For example, B<diff(1)> exits
  with a status of 0 if the two files have the same contents.
  
  =item *
  
  An exit status of 1 implies possibly abnormal, but non-defective, program
  termination.  For example, B<grep(1)> exits with a status of 1 if
  it did I<not> find a matching line for the given regular expression.
  
  =item *
  
  An exit status of 2 or more implies a fatal error. For example, B<ls(1)>
  exits with a status of 2 if you specify an illegal (unknown) option on
  the command line.
  
  =item *
  
  Usage messages issued as a result of bad command-line syntax should go
  to C<STDERR>.  However, usage messages issued due to an explicit request
  to print usage (like specifying B<-help> on the command line) should go
  to C<STDOUT>, just in case the user wants to pipe the output to a pager
  (such as B<more(1)>).
  
  =item *
  
  If program usage has been explicitly requested by the user, it is often
  desirable to exit with a status of 1 (as opposed to 0) after issuing
  the user-requested usage message.  It is also desirable to give a
  more verbose description of program usage in this case.
  
  =back
  
  B<pod2usage> doesn't force the above conventions upon you, but it will
  use them by default if you don't expressly tell it to do otherwise.  The
  ability of B<pod2usage()> to accept a single number or a string makes it
  convenient to use as an innocent looking error message handling function:
  
      use strict;
      use Pod::Usage;
      use Getopt::Long;
  
      ## Parse options
      my %opt;
      GetOptions(\%opt, "help|?", "man", "flag1")  ||  pod2usage(2);
      pod2usage(1)  if ($opt{help});
      pod2usage(-exitval => 0, -verbose => 2)  if ($opt{man});
  
      ## Check for too many filenames
      pod2usage("$0: Too many files given.\n")  if (@ARGV > 1);
  
  Some user's however may feel that the above "economy of expression" is
  not particularly readable nor consistent and may instead choose to do
  something more like the following:
  
      use strict;
      use Pod::Usage qw(pod2usage);
      use Getopt::Long qw(GetOptions);
  
      ## Parse options
      my %opt;
      GetOptions(\%opt, "help|?", "man", "flag1")  ||
        pod2usage(-verbose => 0);
  
      pod2usage(-verbose => 1)  if ($opt{help});
      pod2usage(-verbose => 2)  if ($opt{man});
  
      ## Check for too many filenames
      pod2usage(-verbose => 2, -message => "$0: Too many files given.\n")
        if (@ARGV > 1);
  
  
  As with all things in Perl, I<there's more than one way to do it>, and
  B<pod2usage()> adheres to this philosophy.  If you are interested in
  seeing a number of different ways to invoke B<pod2usage> (although by no
  means exhaustive), please refer to L<"EXAMPLES">.
  
  =head2 Scripts
  
  The Pod::Usage distribution comes with a script pod2usage which offers
  a command line interface to the functionality of Pod::Usage. See
  L<pod2usage>.
  
  
  =head1 EXAMPLES
  
  Each of the following invocations of C<pod2usage()> will print just the
  "SYNOPSIS" section to C<STDERR> and will exit with a status of 2:
  
      pod2usage();
  
      pod2usage(2);
  
      pod2usage(-verbose => 0);
  
      pod2usage(-exitval => 2);
  
      pod2usage({-exitval => 2, -output => \*STDERR});
  
      pod2usage({-verbose => 0, -output  => \*STDERR});
  
      pod2usage(-exitval => 2, -verbose => 0);
  
      pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR);
  
  Each of the following invocations of C<pod2usage()> will print a message
  of "Syntax error." (followed by a newline) to C<STDERR>, immediately
  followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and
  will exit with a status of 2:
  
      pod2usage("Syntax error.");
  
      pod2usage(-message => "Syntax error.", -verbose => 0);
  
      pod2usage(-msg  => "Syntax error.", -exitval => 2);
  
      pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR});
  
      pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR});
  
      pod2usage(-msg  => "Syntax error.", -exitval => 2, -verbose => 0);
  
      pod2usage(-message => "Syntax error.",
                -exitval => 2,
                -verbose => 0,
                -output  => \*STDERR);
  
  Each of the following invocations of C<pod2usage()> will print the
  "SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to
  C<STDOUT> and will exit with a status of 1:
  
      pod2usage(1);
  
      pod2usage(-verbose => 1);
  
      pod2usage(-exitval => 1);
  
      pod2usage({-exitval => 1, -output => \*STDOUT});
  
      pod2usage({-verbose => 1, -output => \*STDOUT});
  
      pod2usage(-exitval => 1, -verbose => 1);
  
      pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT});
  
  Each of the following invocations of C<pod2usage()> will print the
  entire manual page to C<STDOUT> and will exit with a status of 1:
  
      pod2usage(-verbose  => 2);
  
      pod2usage({-verbose => 2, -output => \*STDOUT});
  
      pod2usage(-exitval  => 1, -verbose => 2);
  
      pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT});
  
  =head2 Recommended Use
  
  Most scripts should print some type of usage message to C<STDERR> when a
  command line syntax error is detected. They should also provide an
  option (usually C<-H> or C<-help>) to print a (possibly more verbose)
  usage message to C<STDOUT>. Some scripts may even wish to go so far as to
  provide a means of printing their complete documentation to C<STDOUT>
  (perhaps by allowing a C<-man> option). The following complete example
  uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these
  things:
  
      use strict;
      use Getopt::Long qw(GetOptions);
      use Pod::Usage qw(pod2usage);
  
      my $man = 0;
      my $help = 0;
      ## Parse options and print usage if there is a syntax error,
      ## or if usage was explicitly requested.
      GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
      pod2usage(1) if $help;
      pod2usage(-verbose => 2) if $man;
  
      ## If no arguments were given, then allow STDIN to be used only
      ## if it's not connected to a terminal (otherwise print usage)
      pod2usage("$0: No files given.")  if ((@ARGV == 0) && (-t STDIN));
  
      __END__
  
      =head1 NAME
  
      sample - Using GetOpt::Long and Pod::Usage
  
      =head1 SYNOPSIS
  
      sample [options] [file ...]
  
       Options:
         -help            brief help message
         -man             full documentation
  
      =head1 OPTIONS
  
      =over 4
  
      =item B<-help>
  
      Print a brief help message and exits.
  
      =item B<-man>
  
      Prints the manual page and exits.
  
      =back
  
      =head1 DESCRIPTION
  
      B<This program> will read the given input file(s) and do something
      useful with the contents thereof.
  
      =cut
  
  =head1 CAVEATS
  
  By default, B<pod2usage()> will use C<$0> as the path to the pod input
  file.  Unfortunately, not all systems on which Perl runs will set C<$0>
  properly (although if C<$0> isn't found, B<pod2usage()> will search
  C<$ENV{PATH}> or else the list specified by the C<-pathlist> option).
  If this is the case for your system, you may need to explicitly specify
  the path to the pod docs for the invoking script using something
  similar to the following:
  
      pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs");
  
  In the pathological case that a script is called via a relative path
  I<and> the script itself changes the current working directory
  (see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will
  fail even on robust platforms. Don't do that. Or use L<FindBin> to locate
  the script:
  
      use FindBin;
      pod2usage(-input => $FindBin::Bin . "/" . $FindBin::Script);
  
  =head1 AUTHOR
  
  Please report bugs using L<http://rt.cpan.org>.
  
  Marek Rouchal E<lt>marekr@cpan.orgE<gt>
  
  Brad Appleton E<lt>bradapp@enteract.comE<gt>
  
  Based on code for B<Pod::Text::pod2text()> written by
  Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
  
  =head1 ACKNOWLEDGMENTS
  
  rjbs for refactoring Pod::Usage to not use Pod::Parser any more.
  
  Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience
  with re-writing this manpage.
  
  =head1 SEE ALSO
  
  B<Pod::Usage> is now a standalone distribution, depending on
  L<Pod::Text> which in turn depends on L<Pod::Simple>.
  
  L<Pod::Perldoc>, L<Getopt::Long>, L<Pod::Find>, L<FindBin>,
  L<Pod::Text>, L<Pod::Text::Termcap>, L<Pod::Simple>
  
  =cut
  
POD_USAGE

$fatpacked{"Text/Diff.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TEXT_DIFF';
  package Text::Diff;
  
  use 5.006;
  use strict;
  use warnings;
  use Carp            qw/ croak confess /;
  use Exporter        ();
  use Algorithm::Diff ();
  
  our $VERSION = '1.45';
  our @ISA     = qw/ Exporter /;
  our @EXPORT  = qw/ diff /;
  
  ## Hunks are made of ops.  An op is the starting index for each
  ## sequence and the opcode:
  use constant A       => 0;   # Array index before match/discard
  use constant B       => 1;
  use constant OPCODE  => 2;   # "-", " ", "+"
  use constant FLAG    => 3;   # What to display if not OPCODE "!"
  
  my %internal_styles = (
      Unified  => undef,
      Context  => undef,
      OldStyle => undef,
      Table    => undef,   ## "internal", but in another module
  );
  
  sub diff {
      my @seqs    = ( shift, shift );
      my $options = shift || {};
  
      for my $i ( 0 .. 1 ) {
          my $seq = $seqs[$i];
          my $type = ref $seq;
  
          while ( $type eq "CODE" ) {
              $seqs[$i] = $seq = $seq->( $options );
              $type = ref $seq;
          }
  
          my $AorB = !$i ? "A" : "B";
  
          if ( $type eq "ARRAY" ) {
              ## This is most efficient :)
              $options->{"OFFSET_$AorB"} = 0
                  unless defined $options->{"OFFSET_$AorB"};
          }
          elsif ( $type eq "SCALAR" ) {
              $seqs[$i] = [split( /^/m, $$seq )];
              $options->{"OFFSET_$AorB"} = 1
                  unless defined $options->{"OFFSET_$AorB"};
          }
          elsif ( ! $type ) {
              $options->{"OFFSET_$AorB"} = 1
                  unless defined $options->{"OFFSET_$AorB"};
              $options->{"FILENAME_$AorB"} = $seq
                  unless defined $options->{"FILENAME_$AorB"};
              $options->{"MTIME_$AorB"} = (stat($seq))[9]
                  unless defined $options->{"MTIME_$AorB"};
  
              local $/ = "\n";
              open F, "<$seq" or croak "$!: $seq";
              $seqs[$i] = [<F>];
              close F;
  
          }
          elsif ( $type eq "GLOB" || UNIVERSAL::isa( $seq, "IO::Handle" ) ) {
              $options->{"OFFSET_$AorB"} = 1
                  unless defined $options->{"OFFSET_$AorB"};
              local $/ = "\n";
              $seqs[$i] = [<$seq>];
          }
          else {
              confess "Can't handle input of type ", ref;
          }
      }
  
      ## Config vars
      my $output;
      my $output_handler = $options->{OUTPUT};
      my $type = ref $output_handler ;
      if ( ! defined $output_handler ) {
          $output = "";
          $output_handler = sub { $output .= shift };
      }
      elsif ( $type eq "CODE" ) {
          ## No problems, mate.
      }
      elsif ( $type eq "SCALAR" ) {
          my $out_ref = $output_handler;
          $output_handler = sub { $$out_ref .= shift };
      }
      elsif ( $type eq "ARRAY" ) {
          my $out_ref = $output_handler;
          $output_handler = sub { push @$out_ref, shift };
      }
      elsif ( $type eq "GLOB" || UNIVERSAL::isa $output_handler, "IO::Handle" ) {
          my $output_handle = $output_handler;
          $output_handler = sub { print $output_handle shift };
      }
      else {
          croak "Unrecognized output type: $type";
      }
  
      my $style  = $options->{STYLE};
      $style = "Unified" unless defined $options->{STYLE};
      $style = "Text::Diff::$style" if exists $internal_styles{$style};
  
      if ( ! $style->can( "hunk" ) ) {
          eval "require $style; 1" or die $@;
      }
  
      $style = $style->new if ! ref $style && $style->can( "new" );
  
      my $ctx_lines = $options->{CONTEXT};
      $ctx_lines = 3 unless defined $ctx_lines;
      $ctx_lines = 0 if $style->isa( "Text::Diff::OldStyle" );
  
      my @keygen_args = $options->{KEYGEN_ARGS}
          ? @{$options->{KEYGEN_ARGS}}
          : ();
  
      ## State vars
      my $diffs = 0; ## Number of discards this hunk
      my $ctx   = 0; ## Number of " " (ctx_lines) ops pushed after last diff.
      my @ops;       ## ops (" ", +, -) in this hunk
      my $hunks = 0; ## Number of hunks
  
      my $emit_ops = sub {
          $output_handler->( $style->file_header( @seqs,     $options ) )
              unless $hunks++;
          $output_handler->( $style->hunk_header( @seqs, @_, $options ) );
          $output_handler->( $style->hunk       ( @seqs, @_, $options ) );
          $output_handler->( $style->hunk_footer( @seqs, @_, $options ) );
      };
  
      ## We keep 2*ctx_lines so that if a diff occurs
      ## at 2*ctx_lines we continue to grow the hunk instead
      ## of emitting diffs and context as we go. We
      ## need to know the total length of both of the two
      ## subsequences so the line count can be printed in the
      ## header.
      my $dis_a = sub {push @ops, [@_[0,1],"-"]; ++$diffs ; $ctx = 0 };
      my $dis_b = sub {push @ops, [@_[0,1],"+"]; ++$diffs ; $ctx = 0 };
  
      Algorithm::Diff::traverse_sequences(
          @seqs,
          {
              MATCH => sub {
                  push @ops, [@_[0,1]," "];
  
                  if ( $diffs && ++$ctx > $ctx_lines * 2 ) {
                      $emit_ops->( [ splice @ops, 0, $#ops - $ctx_lines ] );
                      $ctx = $diffs = 0;
                  }
  
                  ## throw away context lines that aren't needed any more
                  shift @ops if ! $diffs && @ops > $ctx_lines;
              },
              DISCARD_A => $dis_a,
              DISCARD_B => $dis_b,
          },
          $options->{KEYGEN},  # pass in user arguments for key gen function
          @keygen_args,
      );
  
      if ( $diffs ) {
          $#ops -= $ctx - $ctx_lines if $ctx > $ctx_lines;
          $emit_ops->( \@ops );
      }
  
      $output_handler->( $style->file_footer( @seqs, $options ) ) if $hunks;
  
      return defined $output ? $output : $hunks;
  }
  
  sub _header {
      my ( $h ) = @_;
      my ( $p1, $fn1, $t1, $p2, $fn2, $t2 ) = @{$h}{
          "FILENAME_PREFIX_A",
          "FILENAME_A",
          "MTIME_A",
          "FILENAME_PREFIX_B",
          "FILENAME_B",
          "MTIME_B"
      };
  
      ## remember to change Text::Diff::Table if this logic is tweaked.
      return "" unless defined $fn1 && defined $fn2;
  
      return join( "",
          $p1, " ", $fn1, defined $t1 ? "\t" . localtime $t1 : (), "\n",
          $p2, " ", $fn2, defined $t2 ? "\t" . localtime $t2 : (), "\n",
      );
  }
  
  ## _range encapsulates the building of, well, ranges.  Turns out there are
  ## a few nuances.
  sub _range {
      my ( $ops, $a_or_b, $format ) = @_;
  
      my $start = $ops->[ 0]->[$a_or_b];
      my $after = $ops->[-1]->[$a_or_b];
  
      ## The sequence indexes in the lines are from *before* the OPCODE is
      ## executed, so we bump the last index up unless the OP indicates
      ## it didn't change.
      ++$after
          unless $ops->[-1]->[OPCODE] eq ( $a_or_b == A ? "+" : "-" );
  
      ## convert from 0..n index to 1..(n+1) line number.  The unless modifier
      ## handles diffs with no context, where only one file is affected.  In this
      ## case $start == $after indicates an empty range, and the $start must
      ## not be incremented.
      my $empty_range = $start == $after;
      ++$start unless $empty_range;
  
      return
          $start == $after
              ? $format eq "unified" && $empty_range
                  ? "$start,0"
                  : $start
              : $format eq "unified"
                  ? "$start,".($after-$start+1)
                  : "$start,$after";
  }
  
  sub _op_to_line {
      my ( $seqs, $op, $a_or_b, $op_prefixes ) = @_;
  
      my $opcode = $op->[OPCODE];
      return () unless defined $op_prefixes->{$opcode};
  
      my $op_sym = defined $op->[FLAG] ? $op->[FLAG] : $opcode;
      $op_sym = $op_prefixes->{$op_sym};
      return () unless defined $op_sym;
  
      $a_or_b = $op->[OPCODE] ne "+" ? 0 : 1 unless defined $a_or_b;
      my @line = ( $op_sym, $seqs->[$a_or_b][$op->[$a_or_b]] );
      unless ( $line[1] =~ /(?:\n|\r\n)$/ ) {
          $line[1] .= "\n\\ No newline at end of file\n";
      }
      return @line;
  }
  
  SCOPE: {
      package Text::Diff::Base;
  
      sub new         {
          my $proto = shift;
          return bless { @_ }, ref $proto || $proto;
      }
  
      sub file_header { return "" }
  
      sub hunk_header { return "" }
  
      sub hunk        { return "" }
  
      sub hunk_footer { return "" }
  
      sub file_footer { return "" }
  }
  
  @Text::Diff::Unified::ISA = qw( Text::Diff::Base );
  
  sub Text::Diff::Unified::file_header {
      shift; ## No instance data
      my $options = pop ;
  
      _header(
          { FILENAME_PREFIX_A => "---", FILENAME_PREFIX_B => "+++", %$options }
      );
  }
  
  sub Text::Diff::Unified::hunk_header {
      shift; ## No instance data
      pop; ## Ignore options
      my $ops = pop;
  
      return join( "",
          "@@ -",
          _range( $ops, A, "unified" ),
          " +",
          _range( $ops, B, "unified" ),
          " @@\n",
      );
  }
  
  sub Text::Diff::Unified::hunk {
      shift; ## No instance data
      pop; ## Ignore options
      my $ops = pop;
  
      my $prefixes = { "+" => "+", " " => " ", "-" => "-" };
  
      return join "", map _op_to_line( \@_, $_, undef, $prefixes ), @$ops
  }
  
  @Text::Diff::Context::ISA = qw( Text::Diff::Base );
  
  sub Text::Diff::Context::file_header {
      _header { FILENAME_PREFIX_A=>"***", FILENAME_PREFIX_B=>"---", %{$_[-1]} };
  }
  
  sub Text::Diff::Context::hunk_header {
      return "***************\n";
  }
  
  sub Text::Diff::Context::hunk {
      shift; ## No instance data
      pop; ## Ignore options
      my $ops = pop;
      ## Leave the sequences in @_[0,1]
  
      my $a_range = _range( $ops, A, "" );
      my $b_range = _range( $ops, B, "" );
  
      ## Sigh.  Gotta make sure that differences that aren't adds/deletions
      ## get prefixed with "!", and that the old opcodes are removed.
      my $after;
      for ( my $start = 0; $start <= $#$ops ; $start = $after ) {
          ## Scan until next difference
          $after = $start + 1;
          my $opcode = $ops->[$start]->[OPCODE];
          next if $opcode eq " ";
  
          my $bang_it;
          while ( $after <= $#$ops && $ops->[$after]->[OPCODE] ne " " ) {
              $bang_it ||= $ops->[$after]->[OPCODE] ne $opcode;
              ++$after;
          }
  
          if ( $bang_it ) {
              for my $i ( $start..($after-1) ) {
                  $ops->[$i]->[FLAG] = "!";
              }
          }
      }
  
      my $b_prefixes = { "+" => "+ ",  " " => "  ", "-" => undef, "!" => "! " };
      my $a_prefixes = { "+" => undef, " " => "  ", "-" => "- ",  "!" => "! " };
  
      return join( "",
          "*** ", $a_range, " ****\n",
          map( _op_to_line( \@_, $_, A, $a_prefixes ), @$ops ),
          "--- ", $b_range, " ----\n",
          map( _op_to_line( \@_, $_, B, $b_prefixes ), @$ops ),
      );
  }
  
  @Text::Diff::OldStyle::ISA = qw( Text::Diff::Base );
  
  sub _op {
      my $ops = shift;
      my $op = $ops->[0]->[OPCODE];
      $op = "c" if grep $_->[OPCODE] ne $op, @$ops;
      $op = "a" if $op eq "+";
      $op = "d" if $op eq "-";
      return $op;
  }
  
  sub Text::Diff::OldStyle::hunk_header {
      shift; ## No instance data
      pop; ## ignore options
      my $ops = pop;
  
      my $op = _op $ops;
  
      return join "", _range( $ops, A, "" ), $op, _range( $ops, B, "" ), "\n";
  }
  
  sub Text::Diff::OldStyle::hunk {
      shift; ## No instance data
      pop; ## ignore options
      my $ops = pop;
      ## Leave the sequences in @_[0,1]
  
      my $a_prefixes = { "+" => undef,  " " => undef, "-" => "< "  };
      my $b_prefixes = { "+" => "> ",   " " => undef, "-" => undef };
  
      my $op = _op $ops;
  
      return join( "",
          map( _op_to_line( \@_, $_, A, $a_prefixes ), @$ops ),
          $op eq "c" ? "---\n" : (),
          map( _op_to_line( \@_, $_, B, $b_prefixes ), @$ops ),
      );
  }
  
  1;
  
  __END__
  
  =head1 NAME
  
  Text::Diff - Perform diffs on files and record sets
  
  =head1 SYNOPSIS
  
      use Text::Diff;
  
      ## Mix and match filenames, strings, file handles, producer subs,
      ## or arrays of records; returns diff in a string.
      ## WARNING: can return B<large> diffs for large files.
      my $diff = diff "file1.txt", "file2.txt", { STYLE => "Context" };
      my $diff = diff \$string1,   \$string2,   \%options;
      my $diff = diff \*FH1,       \*FH2;
      my $diff = diff \&reader1,   \&reader2;
      my $diff = diff \@records1,  \@records2;
  
      ## May also mix input types:
      my $diff = diff \@records1,  "file_B.txt";
  
  =head1 DESCRIPTION
  
  C<diff()> provides a basic set of services akin to the GNU C<diff> utility.  It
  is not anywhere near as feature complete as GNU C<diff>, but it is better
  integrated with Perl and available on all platforms.  It is often faster than
  shelling out to a system's C<diff> executable for small files, and generally
  slower on larger files.
  
  Relies on L<Algorithm::Diff> for, well, the algorithm.  This may not produce
  the same exact diff as a system's local C<diff> executable, but it will be a
  valid diff and comprehensible by C<patch>.  We haven't seen any differences
  between L<Algorithm::Diff>'s logic and GNU C<diff>'s, but we have not examined
  them to make sure they are indeed identical.
  
  B<Note>: If you don't want to import the C<diff> function, do one of the
  following:
  
     use Text::Diff ();
  
     require Text::Diff;
  
  That's a pretty rare occurrence,
  so C<diff()> is exported by default.
  
  If you pass a filename, but the file can't be read,
  then C<diff()> will C<croak>.
  
  =head1 OPTIONS
  
  C<diff()> takes two parameters from which to draw input and a set of
  options to control its output.  The options are:
  
  =over
  
  =item FILENAME_A, MTIME_A, FILENAME_B, MTIME_B
  
  The name of the file and the modification time "files".
  
  These are filled in automatically for each file when C<diff()> is passed a
  filename, unless a defined value is passed in.
  
  If a filename is not passed in and FILENAME_A and FILENAME_B are not provided
  or are C<undef>, the header will not be printed.
  
  Unused on C<OldStyle> diffs.
  
  =item OFFSET_A, OFFSET_B
  
  The index of the first line / element.  These default to 1 for all
  parameter types except ARRAY references, for which the default is 0.  This
  is because ARRAY references are presumed to be data structures, while the
  others are line-oriented text.
  
  =item STYLE
  
  "Unified", "Context", "OldStyle", or an object or class reference for a class
  providing C<file_header()>, C<hunk_header()>, C<hunk()>, C<hunk_footer()> and
  C<file_footer()> methods.  The two footer() methods are provided for
  overloading only; none of the formats provide them.
  
  Defaults to "Unified" (unlike standard C<diff>, but Unified is what's most
  often used in submitting patches and is the most human readable of the three.
  
  If the package indicated by the STYLE has no C<hunk()> method, C<diff()> will
  load it automatically (lazy loading).  Since all such packages should inherit
  from C<Text::Diff::Base>, this should be marvy.
  
  Styles may be specified as class names (C<STYLE =E<gt> 'Foo'>),
  in which case they will be C<new()>ed with no parameters,
  or as objects (C<STYLE =E<gt> Foo-E<gt>new>).
  
  =item CONTEXT
  
  How many lines before and after each diff to display.  Ignored on old-style
  diffs.  Defaults to 3.
  
  =item OUTPUT
  
  Examples and their equivalent subroutines:
  
      OUTPUT   => \*FOOHANDLE,   # like: sub { print FOOHANDLE shift() }
      OUTPUT   => \$output,      # like: sub { $output .= shift }
      OUTPUT   => \@output,      # like: sub { push @output, shift }
      OUTPUT   => sub { $output .= shift },
  
  If no C<OUTPUT> is supplied, returns the diffs in a string.  If
  C<OUTPUT> is a C<CODE> ref, it will be called once with the (optional)
  file header, and once for each hunk body with the text to emit.  If
  C<OUTPUT> is an L<IO::Handle>, output will be emitted to that handle.
  
  =item FILENAME_PREFIX_A, FILENAME_PREFIX_B
  
  The string to print before the filename in the header. Unused on C<OldStyle>
  diffs.  Defaults are C<"---">, C<"+++"> for Unified and C<"***">, C<"+++"> for
  Context.
  
  =item KEYGEN, KEYGEN_ARGS
  
  These are passed to L<Algorithm::Diff/traverse_sequences>.
  
  =back
  
  B<Note>: if neither C<FILENAME_> option is defined, the header will not be
  printed.  If at least one is present, the other and both C<MTIME_> options must
  be present or "Use of undefined variable" warnings will be generated (except
  on C<OldStyle> diffs, which ignores these options).
  
  =head1 Formatting Classes
  
  These functions implement the output formats.  They are grouped in to classes
  so C<diff()> can use class names to call the correct set of output routines and
  so that you may inherit from them easily.  There are no constructors or
  instance methods for these classes, though subclasses may provide them if need
  be.
  
  Each class has C<file_header()>, C<hunk_header()>, C<hunk()>, and C<footer()>
  methods identical to those documented in the C<Text::Diff::Unified> section.
  C<header()> is called before the C<hunk()> is first called, C<footer()>
  afterwards.  The default footer function is an empty method provided for
  overloading:
  
      sub footer { return "End of patch\n" }
  
  Some output formats are provided by external modules (which are loaded
  automatically), such as L<Text::Diff::Table>.  These are
  are documented here to keep the documentation simple.
  
  =head2 Text::Diff::Base
  
  Returns "" for all methods (other than C<new()>).
  
  =head2 Text::Diff::Unified
  
    --- A   Mon Nov 12 23:49:30 2001
    +++ B   Mon Nov 12 23:49:30 2001
    @@ -2,13 +2,13 @@
     2
     3
     4
    -5d
    +5a
     6
     7
     8
     9
    +9a
     10
     11
    -11d
     12
     13
  
  =over
  
  =item Text::Diff::Unified::file_header
  
    $s = Text::Diff::Unified->file_header( $options );
  
  Returns a string containing a unified header.  The sole parameter is the
  C<options> hash passed in to C<diff()>, containing at least:
  
    FILENAME_A  => $fn1,
    MTIME_A     => $mtime1,
    FILENAME_B  => $fn2,
    MTIME_B     => $mtime2
  
  May also contain
  
    FILENAME_PREFIX_A    => "---",
    FILENAME_PREFIX_B    => "+++",
  
  to override the default prefixes (default values shown).
  
  =item Text::Diff::Unified::hunk_header
  
    Text::Diff::Unified->hunk_header( \@ops, $options );
  
  Returns a string containing the heading of one hunk of unified diff.
  
  =item Text::Diff::Unified::hunk
  
    Text::Diff::Unified->hunk( \@seq_a, \@seq_b, \@ops, $options );
  
  Returns a string containing the output of one hunk of unified diff.
  
  =back
  
  =head2 Text::Diff::Table
  
    +--+----------------------------------+--+------------------------------+
    |  |../Test-Differences-0.2/MANIFEST  |  |../Test-Differences/MANIFEST  |
    |  |Thu Dec 13 15:38:49 2001          |  |Sat Dec 15 02:09:44 2001      |
    +--+----------------------------------+--+------------------------------+
    |  |                                  * 1|Changes                       *
    | 1|Differences.pm                    | 2|Differences.pm                |
    | 2|MANIFEST                          | 3|MANIFEST                      |
    |  |                                  * 4|MANIFEST.SKIP                 *
    | 3|Makefile.PL                       | 5|Makefile.PL                   |
    |  |                                  * 6|t/00escape.t                  *
    | 4|t/00flatten.t                     | 7|t/00flatten.t                 |
    | 5|t/01text_vs_data.t                | 8|t/01text_vs_data.t            |
    | 6|t/10test.t                        | 9|t/10test.t                    |
    +--+----------------------------------+--+------------------------------+
  
  This format also goes to some pains to highlight "invisible" characters on
  differing elements by selectively escaping whitespace:
  
    +--+--------------------------+--------------------------+
    |  |demo_ws_A.txt             |demo_ws_B.txt             |
    |  |Fri Dec 21 08:36:32 2001  |Fri Dec 21 08:36:50 2001  |
    +--+--------------------------+--------------------------+
    | 1|identical                 |identical                 |
    * 2|        spaced in         |        also spaced in    *
    * 3|embedded space            |embedded        tab       *
    | 4|identical                 |identical                 |
    * 5|        spaced in         |\ttabbed in               *
    * 6|trailing spaces\s\s\n     |trailing tabs\t\t\n       *
    | 7|identical                 |identical                 |
    * 8|lf line\n                 |crlf line\r\n             *
    * 9|embedded ws               |embedded\tws              *
    +--+--------------------------+--------------------------+
  
  See L<Text::Diff::Table> for more details, including how the whitespace
  escaping works.
  
  =head2 Text::Diff::Context
  
      *** A   Mon Nov 12 23:49:30 2001
      --- B   Mon Nov 12 23:49:30 2001
      ***************
      *** 2,14 ****
        2
        3
        4
      ! 5d
        6
        7
        8
        9
        10
        11
      - 11d
        12
        13
      --- 2,14 ----
        2
        3
        4
      ! 5a
        6
        7
        8
        9
      + 9a
        10
        11
        12
        13
  
  Note: C<hunk_header()> returns only "***************\n".
  
  =head2 Text::Diff::OldStyle
  
      5c5
      < 5d
      ---
      > 5a
      9a10
      > 9a
      12d12
      < 11d
  
  Note: no C<file_header()>.
  
  =head1 LIMITATIONS
  
  Must suck both input files entirely in to memory and store them with a normal
  amount of Perlish overhead (one array location) per record.  This is implied by
  the implementation of L<Algorithm::Diff>, which takes two arrays.  If
  L<Algorithm::Diff> ever offers an incremental mode, this can be changed
  (contact the maintainers of L<Algorithm::Diff> and C<Text::Diff> if you need
  this; it shouldn't be too terribly hard to tie arrays in this fashion).
  
  Does not provide most of the more refined GNU C<diff> options: recursive
  directory tree scanning, ignoring blank lines / whitespace, etc., etc.  These
  can all be added as time permits and need arises, many are rather easy; patches
  quite welcome.
  
  Uses closures internally, this may lead to leaks on Perl versions 5.6.1 and
  prior if used many times over a process' life time.
  
  =head1 SEE ALSO
  
  L<Algorithm::Diff> - the underlying implementation of the diff algorithm
  used by C<Text::Diff>.
  
  L<YAML::Diff> - find difference between two YAML documents.
  
  L<HTML::Differences> - find difference between two HTML documents.
  This uses a more sane approach than L<HTML::Diff>.
  
  L<XML::Diff> - find difference between two XML documents.
  
  L<Array::Diff> - find the differences between two Perl arrays.
  
  L<Hash::Diff> - find the differences between two Perl hashes.
  
  L<Data::Diff> - find difference between two arbitrary data structures.
  
  =head1 REPOSITORY
  
  L<https://github.com/neilbowers/Text-Diff>
  
  =head1 AUTHOR
  
  Adam Kennedy E<lt>adamk@cpan.orgE<gt>
  
  Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
  
  =head1 COPYRIGHT
  
  Some parts copyright 2009 Adam Kennedy.
  
  Copyright 2001 Barrie Slaymaker.  All Rights Reserved.
  
  You may use this under the terms of either the Artistic License or GNU Public
  License v 2.0 or greater.
  
  =cut
  
  1;
TEXT_DIFF

s/^  //mg for values %fatpacked;

my $class = 'FatPacked::'.(0+\%fatpacked);
no strict 'refs';
*{"${class}::files"} = sub { keys %{$_[0]} };

if ($] < 5.008) {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      my $pos = 0;
      my $last = length $fat;
      return (sub {
        return 0 if $pos == $last;
        my $next = (1 + index $fat, "\n", $pos) || $last;
        $_ .= substr $fat, $pos, $next - $pos;
        $pos = $next;
        return 1;
      });
    }
  };
}

else {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      open my $fh, '<', \$fat
        or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
      return $fh;
    }
    return;
  };
}

unshift @INC, bless \%fatpacked, $class;
  } # END OF FATPACK CODE

#!/usr/bin/env perl

use 5.008001;  # msysgit still bundles the antique 5.8.8
use strict;
use warnings;

use File::Spec;
use Cwd ();
use Getopt::Long qw(:config require_order auto_version);
use Pod::Usage;
use Sys::Hostname;

use constant HAS_TEXT_DIFF => eval { require Text::Diff; 1 };

our $VERSION = '1.306';

use constant {
    PROG => (File::Spec->splitpath($0))[2],
    CWD => Cwd::getcwd,
    # msys is the special unix emulation of Unix on Win32: perl 5.8 from msysgit
    WIN32 => $^O eq 'MSWin32' || $^O eq 'msys',
};
# We can't rely on File::HomeDir because we have to reproduce OpenSSH
# behavior, and not depend on what File::HomeDir thinks is right
use constant HOME_DIR => $ENV{HOME} || (WIN32 ? $ENV{USERPROFILE} : (getpwent)[7]);
use constant SSH_DIR => File::Spec->rel2abs('.ssh', HOME_DIR);

# 443.github.com is a pure SSH config alias to ssh.github.com
sub GITHUB_HOSTS() { qw(github.com gist.github.com ssh.github.com 443.github.com) }

$SIG{__WARN__} = sub {
    print STDERR PROG.": ", @_;
};

$SIG{__DIE__} = sub {
    my ($message, $exit_code) = @_;
    print STDERR PROG.": $message";
    exit(defined $exit_code ? $exit_code : 1);
};

sub resolve_path($)
{
    my $path = shift;
    if (WIN32) {
        $path =~ s!^\~(?=[/\\])! HOME_DIR !e;
        $path =~ s!/!\\!g if $^O ne 'msys';
    } else {
        $path =~ s!^\~(?=/)! HOME_DIR !e;
    }
    $path
}

sub ssh_file($)
{
    File::Spec->rel2abs($_[0], SSH_DIR);
}

my %compressed_paths;

sub compress_path($)
{
    my $p = shift;
    my $path = $compressed_paths{$p};
    unless (defined $path) {
        $path = File::Spec->canonpath($p);
        my $home_dir = HOME_DIR;
        # FIXME
        $path =~ s!^\Q$home_dir\E\b!~!;
        $compressed_paths{$p} = $path;
    }
    $path;
}

use constant {
    SSH_CONFIG_FILE => ssh_file('config'),
    KNOWN_HOSTS_FILE => ssh_file('known_hosts_github'),
};

my $offline; # No network connection
my $remove_all;
my $key_type = 'rsa';
my $key_bits = 4096;
my $github_default = '';

# Parse global options
GetOptions(
    'R|reset|remove-all' => \$remove_all,
    't|key-type=s' => \$key_type,
    'b|key-bits=i' => \$key_bits,
    'offline' => \$offline,
) or pod2usage(1);

my @github_accounts;
my %github_accounts;
my %github_remove;



while (@ARGV) {
    my $user = shift @ARGV;
    pod2usage("invalid user '$user'") unless $user =~ /^([a-z0-9_-]+)(?:\@github)?$/;
    $user = $1;

    my $remove = 0;
    my %u = (
        user => $user,
        remove => \$remove,
        passphrase => undef,
        key_file => undef,
        key_type => $key_type,
        key_bits => $key_bits,
    );
    GetOptions(
        'r|remove' => \$remove,
        'd|default' => sub { $github_default = $user },
        'i|identity=s' => \$u{key_file},
        'p|passphrase=s' => \$u{passphrase},
        't|key-type=s' => \$u{key_type},
        'b|key-bits=i' => \$u{key_bits},
        'C|key-comment=s' => \$u{key_comment},
    ) or pod2usage(1);
    pod2usage("invalid empty identity file for user '$user'")
        if defined $u{key_file} && ! length $u{key_file};

    if ($remove) {
        $github_remove{$user} = 1;
    } else {
        push @github_accounts, $user;
        $github_accounts{$user} = \%u;

        # Resolve relative path
        if (defined $u{key_file} && ! File::Spec->file_name_is_absolute($u{key_file})) {
            if (-e $u{key_file}) {
                $u{key_file} = File::Spec->rel2abs($u{key_file}, CWD);
            } else {
                # If the relative path contains a volume or directory,
                # make it relative to CWD, else to SSH_DIR
                my ($v, $d, undef) = File::Spec->splitpath($u{key_file});
                $u{key_file} = File::Spec->rel2abs($u{key_file},
                   (length($v) || length($d)) ? CWD : SSH_DIR);
            }
        }
    }
}

# Load ~/.ssh/config

my @ssh_config_lines;

if (-e SSH_CONFIG_FILE) {
    my @stat = stat SSH_CONFIG_FILE;
    if ($stat[4] != $<) {
        die sprintf("%s: bad owner\n", SSH_CONFIG_FILE);
    }
    if (!WIN32 && $stat[2] & 0133) {
        die sprintf("%s: bad file permissions. Fix: chmod u-x,og-wx %s\n", SSH_CONFIG_FILE, compress_path(SSH_CONFIG_FILE));
    }

    # The :crlf layer is needed for msys
    if (open my $f, WIN32 ? '<:crlf' : '<', SSH_CONFIG_FILE) {
        @ssh_config_lines = <$f>;
        close $f;
    } else {
        warn sprintf "can't open %s\n", SSH_CONFIG_FILE;
    }
}

# Save the original content to show the diff later
my @ssh_config_lines_orig = @ssh_config_lines;


my %users;
my $in_ghkg;
my $dirty;
my $n = 0;
my @github_accounts_from_config;

# List of sections initialized with default section: "Host *"
my @sections = ([ Host => [ '*' ] ]);
my $section_start = 1; # line number of the start of current section
my $ghkg_section_pos;  # index of the last GHKG section

while ($n < @ssh_config_lines) {
    my $l = $ssh_config_lines[$n++];

    if ($l =~ m/\A\s*#.*\bgithub-keygen\b.*\bbegin\b/i) {
        if ($in_ghkg) {
            $dirty = 1;
            warn sprintf "github-keygen section error in %s at line %d\n",
                         compress_path(SSH_CONFIG_FILE), $n;
        } else {
            $in_ghkg = $n;
            $ghkg_section_pos = scalar @sections;
        }
    } elsif ($l =~ m/\A\s*#.*\bgithub-keygen\b.*\bend\b/i) {
        if ($in_ghkg) {
            undef $in_ghkg;
            $n++ while $n < @ssh_config_lines && $ssh_config_lines[$n] eq "\n";
            next;
        } else {
            $dirty = 1;
            warn sprintf "github-keygen section error in %s at line %d\n",
                         compress_path(SSH_CONFIG_FILE), $n;
        }
    } elsif ($l =~ m/\A\s*Host\s+(.*?)\s*\Z/i) {
        %users = ();
        my @hosts_patterns = split /\s+/, $1;

        unless ($in_ghkg) {
            # Extract comment lines just above to put them
            # in the new section
            my @comments;
            my $last_section = $sections[-1];
            while (@$last_section > 2 && $last_section->[-1] =~ /^#/) {
                unshift @comments, pop @$last_section;
            }

            # If the previous section was empty, drop it.
            pop @sections if @{$sections[-1]} == 2;
            # Begin the new section
            push @sections, [ Host => \@hosts_patterns, @comments ];
            $section_start = $n;
        }

        my @github_hosts_pat = grep { /\bgithub\.com$/ } @hosts_patterns;
        if (@github_hosts_pat) {
            unless ($in_ghkg) {
                warn sprintf "GitHub section outside github-keygen section in %s line %u\n",
                             compress_path(SSH_CONFIG_FILE), $n;
                # $dirty = 1;
            }
            #print map(+"[$_] ", @github_hosts_pat), "\n";
            # perl 5.10
            #%users = map { m/^((?!gist)[a-z_0-9]*+)(?:\.gist)?\.github.com$/ ? ($1 => undef) : () } @github_hosts_pat;
            # perl 5.8
            %users = map { m/^([a-z_0-9]+)(?:\.(?:gist|ssh|443))?\.github.com$/ && $_ ne 'gist.github.com' && $_ ne 'ssh.github.com' && $_ ne '443.github.com' ? ($1 => undef) : () } @github_hosts_pat;
            if (%users) {
                # Ignore users which are asked to be removed
                delete @users{keys %github_remove};
                if ($remove_all) {
                    $github_remove{$_} = 1 for keys %users;
                } elsif ($github_default eq '' && keys(%users) == 1 && grep { $_ eq 'github.com' } @github_hosts_pat) {
                    ($github_default) = keys %users;
                }
            }
        }
    } elsif (%users && $l =~ m/^\s*IdentityFile\s+(\S+)\s*/i) {
        if (keys %users > 1) {
            warn sprintf "multiple users detected in %s line %u\n",
                             compress_path(SSH_CONFIG_FILE), $section_start;
            $dirty = 1;
        } else {
            my $user = (keys %users)[0];
            if (exists $github_accounts{$user}) {
                $github_accounts{$user}{key_file} = resolve_path($1)
                    unless defined $github_accounts{$user}{key_file};
                push @github_accounts_from_config, $user;
            } elsif (! exists $github_remove{$user}) {
                my $key_file = resolve_path($1);
                warn sprintf "identity file %s for GitHub user %s doesn't exist\n",
                             compress_path($key_file), $user
                    unless -e $key_file;
                $github_accounts{$user} = {
                    # Create the user without 'key_type' so that the key is not
                    # created if it does not exist
                    # Rationale: the github-keygen user has not asked for this
                    # account
                    user => $user,
                    key_file => $key_file,
                };
                push @github_accounts_from_config, $user;
            }
        }
    } elsif ($in_ghkg && $l =~ /^# Version: ([0-9]+\.[0-9]*)/) {
        my $v = $1;
        if ($v > $VERSION) {
            if ($ENV{GITHUB_KEYGEN_DONWGRADE}) {
                warn sprintf "downgrading github-keygen section from v%s to v%s\n", $v, $VERSION;
            } else {
                die sprintf "%s has a github-keygen section of v%s. Can't downgrade to v%s!\n",
                    compress_path(SSH_CONFIG_FILE), $v, $VERSION;
            }
        }
    }
    # Append the line to the current section
    push @{$sections[-1]}, $l unless $in_ghkg;
}

# Pop the last section if it has no lines
pop @sections if @sections && @{$sections[-1]} == 2;

warn sprintf "failed to parse some parts of %s\n",
             compress_path(SSH_CONFIG_FILE) if $dirty;

@github_accounts = do {
    my %seen;
    (
        grep { !$seen{$_}++ }
             @github_accounts_from_config,
             @github_accounts
    )
};

undef @github_accounts_from_config;


print "Accounts: ", join(', ', @github_accounts), "\n" if @github_accounts;


my $errors = 0;

if (@github_accounts) {
    if (WIN32) {
        # Find ssh tools in msysgit
        require Config;
        my $pathsep = $Config::Config{path_sep};
        foreach my $p (split /\Q$pathsep\E/, $ENV{PATH}) {
            last if -e "$p\\ssh-keygen.exe";
            if (-e "$p\\Git.cmd" || -e "$p\\Git.exe") {
                $ENV{PATH} = "$p\\..\\bin$pathsep$ENV{PATH}";
                last;
            }
        }
    }
}

unless (-e SSH_DIR) {
    printf "Creating %s...\n", compress_path(SSH_DIR);
    mkdir SSH_DIR, 0700
        or die sprintf "can't create directory '%s': %s\n",
                compress_path(SSH_DIR), "$!";
}

foreach my $user (@github_accounts) {
    my $u = $github_accounts{$user};
    $u->{key_file} = ssh_file("id_$user\@github")
        unless defined $u->{key_file};

    next if -e $u->{key_file} || ! exists $u->{key_type};

    printf "Creating private key %s for user %s...\n",
           compress_path($u->{key_file}), $user;

    $u->{key_comment} = hostname."/$user\@github.com";

    system 'ssh-keygen',
           '-t', delete $u->{key_type},
           '-b', delete $u->{key_bits},
           '-C', $u->{key_comment},
           defined $u->{passphrase} ? ('-N', $u->{passphrase}) : (),
           '-f', $u->{key_file};
    if ($? >> 8 || ! (-e $u->{key_file} && -e ($u->{key_file}.".pub"))) {
        $errors++;
        next;
    }

    # If an SSH Agent is available, give him the key
    # The $SSH_AGENT_PID check is to exclude gnome-keyring that does not
    # behave properly (it doesn't allow to remove keys)
    #
    # I'm not sure this is really useful, so disable it for now.
    #if ($ENV{SSH_AUTH_SOCK} && $ENV{SSH_AGENT_PID}) {
    #    print "Adding the key to the SSH agent for 20 minutes...\n";
    #    system qw< ssh-add -t 1200 >, $u->{key_file};
    #}

    $u->{created}++;
}

die "errors while creating key\n" if $errors;

$errors = 0;



if (@github_accounts) {

    # Map pubkey to GitHub account
    my %github_pubkeys;

    foreach my $user (@github_accounts) {
        last if $offline;
        if (open my $f, '-|', qw<curl -s -f>, "https://github.com/$user.keys") {
            my $rows;
            while (<$f>) {
                $rows++;
                chomp;
                s/^\S+ +(\S+).*/$1/;
                # print "$user pubkey on GitHub: $_\n";
                $github_pubkeys{"$user:$_"}++;
                push @{ $github_pubkeys{$_} ||= [] }, $user;
            }
            close $f;
            # TODO check $?
            if (!$rows) {
                # curl exit codes:
                # 6: Couldn't resolve host
                # 7: Failed to connect to host
                # 22: HTTP status >= 400 (see option -f)
                my $rc = $? >> 8;
                #printf "%d\n", $rc;
                if ($rc == 6 || $rc == 7) {
                    print "Offline mode: not checking key registration on GitHub.\n" if !defined $offline;
                    $offline++;
                }
            }
            $offline = 0 unless defined $offline;
        } else {
            warn("curl failed: exit code ".($?>>8)."\n");
        }
    }

    foreach my $user (@github_accounts) {
        my $u = $github_accounts{$user};
        my $pub_key_file = $u->{key_file} . ".pub";
        if (-e $pub_key_file) {
            if (open my $f, '-|', qw<ssh-keygen -l -f>, $pub_key_file) {
                chomp(my $fingerprint = <$f>);
                close $f;
                if ($fingerprint =~ m/^\S+ +(\S+)/) {
                    $u->{fingerprint} = $1;
                    #print "$user: $1\n";
                }
            }
            if (open my $f, '<', $pub_key_file) {
                chomp(my $line = <$f>);
                close $f;
                if ($line =~ m/^\S+ +(\S+) /) {
                    $u->{pubkey} = my $pub_key_b64 = $1;
                    #print "$user pubkey: $pub_key_b64\n";
                    unless ($offline) {
                        if (exists $github_pubkeys{"$user:$pub_key_b64"}) {
                            print "$user: key is registered on GitHub.\n";
                            $u->{key_on_github}++;
                        } elsif (!$u->{created}) {
                            # Check if a key is shared by multiple users
                            if (exists $github_pubkeys{$pub_key_b64}) {
                                warn "$user: key is already attached to user @{ $github_pubkeys{$pub_key_b64} } on GitHub!\n";
                                $u->{key_on_github}++;
                            } else {
                                warn "$user: key not registered on GitHub!\n";
                            }
                        }
                    }
                }
            }
        }
    }


    # To rebuild __DATA__ (if GitHub ever revokes its host keys):
    #   ssh-keyscan -t dsa,rsa github.com gist.github.com ssh.github.com

    my $size = -e KNOWN_HOSTS_FILE
             ? (stat KNOWN_HOSTS_FILE)[7]
             : 0;

    if ($size == 291) {
        printf "No changes in %s.\n",
               compress_path(KNOWN_HOSTS_FILE);
    } else {
        printf "Saving GitHub hosts authentication keys in %s...\n",
               compress_path(KNOWN_HOSTS_FILE);

        chmod 0600, KNOWN_HOSTS_FILE if $size;
        if (open my $f, '>', KNOWN_HOSTS_FILE) {
            # Read line by line (up to an empty line)
            # to convert EOL to the platform native EOL
            while (<DATA>) {
                last unless /../;
                print $f $_;
            }
            close $f;
        } else {
            warn sprintf "could not open %s: %s",
                         compress_path(KNOWN_HOSTS_FILE),
                         $!;
        }
    }
} elsif (-e KNOWN_HOSTS_FILE) {
    # No more GitHub account, so remove the hosts file
    printf "Removing %s...\n", compress_path(KNOWN_HOSTS_FILE);
    unlink KNOWN_HOSTS_FILE;
}

# Create the new config section
if (@github_accounts) {

    my $SSH_V = `ssh -V 2>&1`;
    # '6.6.1p1' => 0x6611
    # '4.6p1'   => 0x4601
    my $SSH_VERSION = do {
        my @V = $SSH_V =~ /^OpenSSH_([0-9]+)\.([0-9]+)(?:\.([0-9]+))?p([0-9]+)/;
        ($V[0] << 12) | ($V[1] << 8) | (($V[2] || 0) << 4) | $V[3]
    };

    #printf "OpenSSH %04X\n", $SSH_VERSION;

    # Algorithms subset recommended by Stribika
    #  See https://stribika.github.io/2015/01/04/secure-secure-shell.html
    #  Last in each list is the minimum supported by GitHub
    # TODO: some algorithms are imported by OpenSSH from OpenSSL at runtime
    #       so we could check the output of `openssl list-cipher-algorithms`
    #       in the case `ssh -Q cipher` is not implemented (old OpenSSH).
    my %algorithms = (
        # Ciphers: ssh -Q cipher
        cipher => [
            (qw< chacha20-poly1305@openssh.com >)
             x!! ($SSH_VERSION >= 0x5000),
            (qw< aes256-gcm@openssh.com aes128-gcm@openssh.com >)
             x!! ($SSH_VERSION >= 0x5000 && $^O ne 'msys'),
            'aes256-ctr',
        ],
        # MACs: ssh -Q mac
        mac => [ qw<
            hmac-sha2-512-etm@openssh.com
            hmac-sha2-256-etm@openssh.com
            umac-128-etm@openssh.com
            hmac-sha2-512
        > ],
        # KexAlgorithms: ssh -Q kex
        #
        # diffie-hellman-group14-sha1 removed by GitHub on 2018-02-01
        # https://githubengineering.com/crypto-deprecation-notice/
        kex => [ qw<
            curve25519-sha256@libssh.org
            diffie-hellman-group-exchange-sha256
            diffie-hellman-group-exchange-sha1
        > ],
    );
    # Filter each list against what is supported by the ssh client
    while (my ($kind, $algos) = each %algorithms) {
        if ($SSH_VERSION > 0x5200 && open my $ssh_Q, '-|', "ssh -Q $kind 2>".File::Spec->devnull) {
            my %supported = map { chomp; ($_ => 1) } <$ssh_Q>;
            close $ssh_Q;
            if (%supported) {
                $algorithms{$kind} = join(',', grep { $supported{$_} } @$algos);
                next;
            }
            #warn "ssh -Q $kind: failure ($!)";
        }

        # For old OpenSSH that don't have -Q option:
        # - Detect supported cipher algorithms with 'ssh -c'
        # - Detect supported mac algorithms with 'ssh -m'
        my %kind2opt = (cipher => '-c', mac => '-m');
        if (my $opt = $kind2opt{$kind}) {
            for(my $i=0; $i<@$algos; $i++) {
                my $check = `ssh $opt $algos->[$i] -o XXX=xxx 2>&1`;
                # If the result is not "Unknown ...", the algorithm is
                # supported
                if (substr($check, 0, 7) eq 'Unknown') {
                    splice @$algos, $i, 1;
                    last if $i == @$algos;
                    redo
                }
            }
        }

        $algorithms{$kind} = @$algos ? join(',', @$algos) : '';
    }
    # hmac-sha1 is only for old OpenSSH that support none above
    $algorithms{'mac'} = 'hmac-sha1' unless length $algorithms{'mac'};

    my $known_hosts_file = compress_path KNOWN_HOSTS_FILE;

    # Store ControlPath in XDG_RUNTIME_DIR
    my $ControlPath_dir = '~/.ssh';
    if (my $rt_dir = $ENV{XDG_RUNTIME_DIR}) {
        use filetest 'access'; # Stricter check, but _ can't be used
        if (-d $rt_dir && -x $rt_dir && -w $rt_dir) {
            $ControlPath_dir = $rt_dir;
        }
    }
    my $ControlPath =
        # Not sure about the exact version for %n support
        $SSH_VERSION >= 0x6000
        ? "$ControlPath_dir/conn-\%n"
        : "$ControlPath_dir/conn-github";

    my @ghkg_config_lines = map { "$_\n" } split /\n/, <<EOF, -1;
# -- github-keygen - begin --
# Version: $VERSION

Host gist.github.com *.gist.github.com
HostName gist.github.com

# See https://docs.github.com/en/authentication/troubleshooting-ssh/using-ssh-over-the-https-port
Host ssh.github.com *.ssh.github.com 443.github.com *.443.github.com
HostName ssh.github.com
Port 443

# This rule must stay below more specific host rules to avoid
# "HostName" to be set to github.com
Host *.github.com
HostName github.com

Host github.com gist.github.com ssh.github.com 443.github.com *.github.com *.gist.github.com *.ssh.github.com *.443.github.com
User git
# Knwon options which are available only in some OpenSSH versions
IgnoreUnknown Protocol,UseRoaming,UseKeychain
# Force SSH2
Protocol 2
# Enforce host checks
StrictHostKeyChecking yes
UserKnownHostsFile ${known_hosts_file}
# Hosts added later (identified by IP) will be hashed
HashKnownHosts yes
# GitHub has not yet (2011-05) implemented SSHFP (RFC 4255)
VerifyHostKeyDNS no
# Enable only the required authentication
PubkeyAuthentication yes
PreferredAuthentications publickey
# Select algorithms recommended by Stribika
#  See https://stribika.github.io/2015/01/04/secure-secure-shell.html
#  Last in each list is the minimum supported by GitHub
KexAlgorithms $algorithms{kex}
Ciphers $algorithms{cipher}
MACs $algorithms{mac}
# Disallow server key using SHA-1
# https://www.openssh.com/txt/release-8.2
HostKeyAlgorithms -ssh-rsa
# Trust no one, especially the remote
ForwardAgent no
ForwardX11 no
PermitLocalCommand no
UseRoaming no
# Connexion sharing for 60 seconds, for speedup
ControlMaster auto
ControlPath ${ControlPath}
ControlPersist 60s
EOF

    foreach my $u (@github_accounts) {
        push @ghkg_config_lines,
            join(' ',
                'Host',
                (map { "$u.$_" } GITHUB_HOSTS),
                ($u eq $github_default ? (GITHUB_HOSTS) : ()),
            ) . "\n",
            "IdentitiesOnly yes\n",
            'IdentityFile '. compress_path($github_accounts{$u}->{key_file}) . "\n",
            "\n";
    }

    # Close the section
    push @ghkg_config_lines, "# -- github-keygen - end --\n";


    # Check against the man page that all the options we plan to use are supported
    # on this machine
    my $manfile;
    if (-x '/usr/bin/man' && ($manfile = qx{man -w ssh_config 2>/dev/null})) {
        chomp $manfile;
    } else {
        # On msysgit the man page is installed despites /usr/bin/man isn't
        foreach ('', '.gz') {
            my $f = "/usr/share/man/man5/ssh_config.5$_";
            if (-f $f) {
                $manfile = $f;
                last;
            }
        }
    }
    if ($manfile) {
        #print "ssh_config.5: $manfile\n";
        my $fh;
        if ($manfile =~ /\.gz$/) {
            open $fh, '-|', "zgrep '\\.It Cm' '$manfile'";
        } else {
            open $fh, '<', $manfile;
        }
        if ($fh) {
            my %supported_options;
            # UseRoaming was an undocumented option that is a security issue
            # if enabled when connecting to a malicious server.
            # http://www.openssh.com/txt/release-7.1p2
            # Special case for MacOS X Sierra that has 7.2p2 but no
            # UseRoaming: https://github.com/dolmen/github-keygen/issues/31
            $supported_options{useroaming} =
                $SSH_VERSION >= 0x5400
                && $SSH_VERSION < ($^O eq 'darwin' ? 0x7200 : 0x7300);
            # SSH protocol v1 removed in OpenSSH 7.6
            # https://www.openssh.com/txt/release-7.6
            $supported_options{protocol} =
                $SSH_VERSION < 0x7600;
            # We have to lower case the option names because the case in the
            # manual has not been conistent in OpenSSH history.
            while (<$fh>) {
                $supported_options{lc $1}++ if /^\.It Cm ([A-Z]\S+)/
            }
            close $fh;
            if (scalar(keys %supported_options) > 1) {
                foreach (@ghkg_config_lines) {
                    next unless /^([A-Z]\S+)/;
                    my $sup = $supported_options{lc $1};
                    unless ($sup) {
                        warn "ssh option '$1' is not available" if !defined $sup;
                        s/^/##/;
                    }
                }
            }
        }
    }

    # OpenSSH 6.6.1p1 from msys:
    # msys does not support passing file descriptors and ControlMaster relies
    # on that, so we comment all Control options
    if ($^O eq 'msys') {
        s/^(Control)/##$1/ for @ghkg_config_lines;
    }
    # OpenSSH 4.6p1 from msysgit: keep the poor algorithms list
    if ($SSH_VERSION < 0x5000) {
        s/^(KexAlgorithms|MACs|Control(?:Persist|Path)) /##$1 / for @ghkg_config_lines;
    }
    # Option UseRoaming appeared in 5.4 (but undocumented), is deprecated in 7.2 and
    # removed in 7.3
    if ($SSH_VERSION >= 0x7300) {
        # option is deprecated in 7.2, but removed in 7.3
        @ghkg_config_lines = grep !/^UseRoaming /, @ghkg_config_lines;
    }
    if ($SSH_VERSION < 0x5400) {
        s/^(UseRoaming )/##$1/ for @ghkg_config_lines;
    }

    # If no GHKG section existed, add it at the end of the file
    $ghkg_section_pos = scalar @sections unless defined $ghkg_section_pos;

    # But if the last section of the file is "Host *" (default settings for
    # all hosts), we want to be just before
    if ($ghkg_section_pos > 0 && $ghkg_section_pos == @sections) {
        $ghkg_section_pos--
            if $sections[-1][0] eq 'Host' && grep $_ eq '*', @{$sections[-1][1]}
    }

    # If not the last section, append "\n"
    push @ghkg_config_lines, "\n" if $ghkg_section_pos <= @sections;

    # Inject our section
    splice @sections, $ghkg_section_pos, 0, [ '', '', @ghkg_config_lines ]
}


# If we either deleted or created a GHKG section,
# rebuild the file content from @sections
if (defined $ghkg_section_pos) {
    undef @ssh_config_lines;
    while (my $s = shift @sections) {
        splice @$s, 0, 2;
        push @ssh_config_lines, @$s;
    }
}



# Workaround for perl 5.8
# (smartmatch is at least good at easily comparing arrays)
sub array_equals (\@\@)
{
    my ($a1, $a2) = @_;
    return '' if $#$a1 != $#$a2;
    for(my $i=$#$a1; $i>=0; $i--) {
        return '' if $a1->[$i] ne $a2->[$i]
    }
    return 1
}

if (@ssh_config_lines) {
    #if (@ssh_config_lines ~~ @ssh_config_lines_orig) {   # perl 5.10
    if (array_equals @ssh_config_lines, @ssh_config_lines_orig) {
        printf "No changes in %s.\n", compress_path(SSH_CONFIG_FILE);
    # :crlf layer is needed explicitely on msys
    } elsif (open my $f, WIN32 ? '>:crlf' : '>', SSH_CONFIG_FILE) {
        printf "Saving %s...\n", compress_path(SSH_CONFIG_FILE);
        print Text::Diff::diff(\@ssh_config_lines_orig, \@ssh_config_lines, { STYLE => 'Unified' }) if HAS_TEXT_DIFF;
        print $f @ssh_config_lines;
        close $f;
        print "Done.\n";
    } else {
    }
} else {
    if (-e SSH_CONFIG_FILE) {
        printf "Removing %s...\n", compress_path(SSH_CONFIG_FILE);
        print Text::Diff::diff(\@ssh_config_lines_orig, \@ssh_config_lines, { STYLE => 'Unified' }) if HAS_TEXT_DIFF;
        unlink SSH_CONFIG_FILE
            or warn sprintf("can't remove %s: %s\n",
                            SSH_CONFIG_FILE, $!);
        print "Done.\n";
    }
}

my @unregistered_users =
    grep {
        my $u = $github_accounts{$_};
        $u->{created} || (!$offline && !$u->{key_on_github})
    } @github_accounts;

if (@unregistered_users) {

    my @clip_cmd;

    # X11
    @clip_cmd = qw</usr/bin/xclip -selection clipboard>
        if exists $ENV{DISPLAY} && -x '/usr/bin/xclip';

    # Darwin
    @clip_cmd = qw</usr/bin/pbcopy> if -x '/usr/bin/pbcopy';

    if (@clip_cmd && @unregistered_users == 1 && !$offline) {
        my $user = shift @unregistered_users;
        # Copy the first key created to the clipboard
        my $pub_key_file = $github_accounts{$user}->{key_file}.".pub";
        # Read the public key from the file
        open my $pub, '<', $pub_key_file;
        my $pubkey = <$pub>;
        $pubkey =~ s/^(\S+ \S+).*/$1/;
        close $pub;

        open my $clip, '|-', @clip_cmd;
        print $clip $pubkey;
        close $clip;
        printf "\n"
             . "The public key %s for $user has been copied to the clipboard.\n"
             . "Paste it in your SSH settings at <https://github.com/settings/keys>.\n",
               compress_path($pub_key_file);
    } else {
        print "\n"
            . "You now have to copy the public key for each user to your SSH settings at\n"
            . "<https://github.com/settings/keys>.\n";
        # Help the user to copy the other keys
        foreach my $user (@unregistered_users) {
            my $pub_key = compress_path($github_accounts{$user}{key_file}).".pub";
            if (@clip_cmd) {
                print "  $user:  @clip_cmd < $pub_key\n";
            } else {
                print "  $user:  $pub_key\n";
            }
        }
        if ($offline) {
            print "Then run github-keygen online to check the registration works.\n";
        } else {
            print "Then re-run github-keygen to check the registration works.\n";
        }
    }
}

__END__
github.com ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIOMqqnkVzrm0SdG6UOoqKLsabgH5C9okWi0dh2l9GKJl
gist.github.com ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIOMqqnkVzrm0SdG6UOoqKLsabgH5C9okWi0dh2l9GKJl
[ssh.github.com]:443 ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIOMqqnkVzrm0SdG6UOoqKLsabgH5C9okWi0dh2l9GKJl

=head1 NAME

github-keygen - GitHub SSH setup tool

=head1 SYNOPSIS

    # Get github-keygen
    git clone https://github.com/dolmen/github-keygen

    # Manage SSH keys
    github-keygen [-R]      [-t <key-type>] [-b <key-bits>]
                  [ <user1> [-t <key-type>] [-b <key-bits>] [-d] [-r]
                    [ <user2> ... ] ]

    # Use an account
    git clone <user>.github.com:<repo-owner>/<repo>

=head1 DESCRIPTION

This script ease initial environment setup for secure GitHub exchanges, but it
does much more than that:

=over 4

=item *

Create a new SSH private key

=item *

Setup a very secure SSH configuration for GitHub, independent of your other SSH
settings:

=over 4

=item -

Enable only the authentication method used with GitHub (publickey)

=item -

Disable bad things that could come from the GitHub hosts ("Trust no-one")

=back

=item *

Create unique host aliases for github.com/gist.github.com that you'll be able
to use in Git URLs to connect to a particular account. This gives uses the
flexibility to use multiple GitHub accounts.

    <account>.github.com:<repo-owner>/<repo>.git
    github.com:<repo-owner>/<repo>.git

in addition to:

    git@github.com:<repo-owner>/<repo>.git

=back

This script will:

=over 4

=item *

Create a new SSH key dedicated only to your GitHub connections in
F<~/.ssh/id_I<E<lt>github-accountE<gt>>@github>

=item *

Create the SSH configuration optimized for GitHub and dedicated to GitHub
(do not impact your other SSH configurations) in F<~/.ssh/config> (unless the
file already exists)

=item *

Install the GitHub SSH host authentication fingerprints in
F<~/.ssh/known_hosts_github>

=back

=head1 OPTIONS

=head2 GLOBAL OPTIONS

Global options are given just after the command name, and before the first
account name.

=over 4

=item -R

Remove all accounts, except those following on the command-line.

=item -t I<key-type>

Set default key type for key creation. Default is C<rsa>.

=item -b I<key-bits>

Set default key bits for key creation. Default is C<2048>.

=back

=head2 ACCOUNT OPTIONS

Account options are given after each account name.

=over 4

=item -d

Set this account as the default for C<github.com>/C<gist.github.com> (when you
do not use a host alias).

=item -r

Remove the account from F<~/.ssh/config>. The private key will be kept, but not
referenced anymore in F<~/.ssh/config>.

=item -i I<key-file>

The key is created only if it doesn't already exists.

If only a filename is given, it will be relative to F<~/.ssh/>, else if a
relative path is given it will be relative to the current directory. Absolute
paths are kept as is.

=back

Key creations parameters (see L<ssh-keygen(1)>):

=over 4

=item -t I<key-type>

=item -b I<key-bits>

=item -p I<passphrase>

=item -C I<comment>

Default comment is C<I<hostname>/I<account>@github.com>.

=item -i I<key-file>

Default is F<~/.ssh/id_I<account>@github.com>.

=back

=head1 EXAMPLES

    # Remove all previous gihub-keygen config
    github-keygen -R

    # Add a GitHub account
    github-keygen account1

    # Add an other GitHub account
    github-keygen account2

    # Add a third GitHub account with key file
    github-keygen account3 -i ./id_account3

    # Remove account2
    github-keygen account2 -r

    # Clone repo 'user2/project1' with account3
    git clone account3.github.com:user2/project1.git
    cd project1

    # Add a remote for pushing with account2
    git remote add gh-account2 account2.github.com:user2/project1.git

    # Remove all except account3
    github-keygen -R account3

    # Uninstall
    github-keygen -R

=head1 SEE ALSO

=over 4

=item *

L<ssh-keygen(1)>

=item *

L<ssh_config(5)>

=item *

L<https://docs.github.com/en/get-started/quickstart/set-up-git#platform-linux>

=item *

L<https://docs.github.com/en/authentication>

=item *

L<https://docs.github.com/en/authentication/connecting-to-github-with-ssh/working-with-ssh-key-passphrases>

=back

=head1 AUTHOR

Olivier MenguE<eacute>, L<mailto:dolmen@cpan.org>.

=head1 COPYRIGHT & LICENSE

Copyright E<copy> 2011-2022 Olivier MenguE<eacute>.

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see L<http://www.gnu.org/licenses/>.

=cut

# vim: set et sw=4 sts=4: