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

   1
   2 require 5;
   3 package Pod::Simple;
   4 use strict;
   5 use Carp ();
   6 BEGIN           { *DEBUG = sub () {0} unless defined &DEBUG }
   7 use integer;
   8 use Pod::Escapes 1.04 ();
   9 use Pod::Simple::LinkSection ();
  10 use Pod::Simple::BlackBox ();
  11 #use utf8;
  12
  13 use vars qw(
  14   $VERSION @ISA
  15   @Known_formatting_codes  @Known_directives
  16   %Known_formatting_codes  %Known_directives
  17   $NL
  18 );
  19
  20 @ISA = ('Pod::Simple::BlackBox');
  21 $VERSION = '3.10';
  22
  23 @Known_formatting_codes = qw(I B C L E F S X Z);
  24 %Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
  25 @Known_directives       = qw(head1 head2 head3 head4 item over back);
  26 %Known_directives       = map(($_=>'Plain'), @Known_directives);
  27 $NL = $/ unless defined $NL;
  28
  29 #-----------------------------------------------------------------------------
  30 # Set up some constants:
  31
  32 BEGIN {
  33   if(defined &ASCII)    { }
  34   elsif(chr(65) eq 'A') { *ASCII = sub () {1}  }
  35   else                  { *ASCII = sub () {''} }
  36
  37   unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} }
  38   DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n";
  39   unless(MANY_LINES() >= 1) {
  40     die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting";
  41   }
  42   if(defined &UNICODE) { }
  43   elsif($] >= 5.008)   { *UNICODE = sub() {1}  }
  44   else                 { *UNICODE = sub() {''} }
  45 }
  46 if(DEBUG > 2) {
  47   print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n";
  48   print "# We are under a Unicode-safe Perl.\n";
  49 }
  50
  51 # Design note:
  52 # This is a parser for Pod.  It is not a parser for the set of Pod-like
  53 #  languages which happens to contain Pod -- it is just for Pod, plus possibly
  54 #  some extensions.
  55
  56 # @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
  57 #@ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @ @
  58 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  59
  60 __PACKAGE__->_accessorize(
  61   'nbsp_for_S',        # Whether to map S<...>'s to \xA0 characters
  62   'source_filename',   # Filename of the source, for use in warnings
  63   'source_dead',       # Whether to consider this parser's source dead
  64
  65   'output_fh',         # The filehandle we're writing to, if applicable.
  66                        # Used only in some derived classes.
  67
  68   'hide_line_numbers', # For some dumping subclasses: whether to pointedly
  69                        # suppress the start_line attribute
  70
  71   'line_count',        # the current line number
  72   'pod_para_count',    # count of pod paragraphs seen so far
  73
  74   'no_whining',        # whether to suppress whining
  75   'no_errata_section', # whether to suppress the errata section
  76   'complain_stderr',   # whether to complain to stderr
  77
  78   'doc_has_started',   # whether we've fired the open-Document event yet
  79
  80   'bare_output',       # For some subclasses: whether to prepend
  81                        #  header-code and postpend footer-code
  82
  83   'fullstop_space_harden', # Whether to turn ".  " into ".[nbsp] ";
  84
  85   'nix_X_codes',       # whether to ignore X<...> codes
  86   'merge_text',        # whether to avoid breaking a single piece of
  87                        #  text up into several events
  88
  89   'preserve_whitespace', # whether to try to keep whitespace as-is
  90   'strip_verbatim_indent', # What indent to strip from verbatim
  91
  92  'content_seen',      # whether we've seen any real Pod content
  93  'errors_seen',       # TODO: document.  whether we've seen any errors (fatal or not)
  94
  95  'codes_in_verbatim', # for PseudoPod extensions
  96
  97  'code_handler',      # coderef to call when a code (non-pod) line is seen
  98  'cut_handler',       # coderef to call when a =cut line is seen
  99  #Called like:
 100  # $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
 101  #  $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
 102
 103 );
 104
 105 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 106
 107 sub any_errata_seen {  # good for using as an exit() value...
 108   return shift->{'errors_seen'} || 0;
 109 }
 110
 111 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 112 # Pull in some functions that, for some reason, I expect to see here too:
 113 BEGIN {
 114   *pretty        = \&Pod::Simple::BlackBox::pretty;
 115   *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol;
 116 }
 117
 118 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 119
 120 sub version_report {
 121   my $class = ref($_[0]) || $_[0];
 122   if($class eq __PACKAGE__) {
 123     return "$class $VERSION";
 124   } else {
 125     my $v = $class->VERSION;
 126     return "$class $v (" . __PACKAGE__ . " $VERSION)";
 127   }
 128 }
 129
 130 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 131
 132 #sub curr_open { # read-only list accessor
 133 #  return @{ $_[0]{'curr_open'} || return() };
 134 #}
 135 #sub _curr_open_listref { $_[0]{'curr_open'} ||= [] }
 136
 137
 138 sub output_string {
 139   # Works by faking out output_fh.  Simplifies our code.
 140   #
 141   my $this = shift;
 142   return $this->{'output_string'} unless @_;  # GET.
 143
 144   require Pod::Simple::TiedOutFH;
 145   my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] );
 146   $$x = '' unless defined $$x;
 147   DEBUG > 4 and print "# Output string set to $x ($$x)\n";
 148   $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]);
 149   return
 150     $this->{'output_string'} = $_[0];
 151     #${ ${ $this->{'output_fh'} } };
 152 }
 153
 154 sub abandon_output_string { $_[0]->abandon_output_fh; delete $_[0]{'output_string'} }
 155 sub abandon_output_fh     { $_[0]->output_fh(undef) }
 156 # These don't delete the string or close the FH -- they just delete our
 157 #  references to it/them.
 158 # TODO: document these
 159
 160 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 161
 162 sub new {
 163   # takes no parameters
 164   my $class = ref($_[0]) || $_[0];
 165   #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc "
 166   #  . __PACKAGE__ );
 167   return bless {
 168     'accept_codes'      => { map( ($_=>$_), @Known_formatting_codes ) },
 169     'accept_directives' => { %Known_directives },
 170     'accept_targets'    => {},
 171   }, $class;
 172 }
 173
 174
 175
 176 # TODO: an option for whether to interpolate E<...>'s, or just resolve to codes.
 177
 178 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 179
 180 sub _handle_element_start {     # OVERRIDE IN DERIVED CLASS
 181   my($self, $element_name, $attr_hash_r) = @_;
 182   return;
 183 }
 184
 185 sub _handle_element_end {       # OVERRIDE IN DERIVED CLASS
 186   my($self, $element_name) = @_;
 187   return;
 188 }
 189
 190 sub _handle_text          {     # OVERRIDE IN DERIVED CLASS
 191   my($self, $text) = @_;
 192   return;
 193 }
 194
 195 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 196 #
 197 # And now directives (not targets)
 198
 199 sub accept_directive_as_verbatim  { shift->_accept_directives('Verbatim', @_) }
 200 sub accept_directive_as_data      { shift->_accept_directives('Data',     @_) }
 201 sub accept_directive_as_processed { shift->_accept_directives('Plain',    @_) }
 202
 203 sub _accept_directives {
 204   my($this, $type) = splice @_,0,2;
 205   foreach my $d (@_) {
 206     next unless defined $d and length $d;
 207     Carp::croak "\"$d\" isn't a valid directive name"
 208      unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
 209     Carp::croak "\"$d\" is already a reserved Pod directive name"
 210      if exists $Known_directives{$d};
 211     $this->{'accept_directives'}{$d} = $type;
 212     DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n";
 213   }
 214   DEBUG > 6 and print "$this\'s accept_directives : ",
 215    pretty($this->{'accept_directives'}), "\n";
 216
 217   return sort keys %{ $this->{'accept_directives'} } if wantarray;
 218   return;
 219 }
 220
 221 #--------------------------------------------------------------------------
 222 # TODO: document these:
 223
 224 sub unaccept_directive { shift->unaccept_directives(@_) };
 225
 226 sub unaccept_directives {
 227   my $this = shift;
 228   foreach my $d (@_) {
 229     next unless defined $d and length $d;
 230     Carp::croak "\"$d\" isn't a valid directive name"
 231      unless $d =~ m/^[a-zA-Z][a-zA-Z0-9]*$/s;
 232     Carp::croak "But you must accept \"$d\" directives -- it's a builtin!"
 233      if exists $Known_directives{$d};
 234     delete $this->{'accept_directives'}{$d};
 235     DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n";
 236   }
 237   return sort keys %{ $this->{'accept_directives'} } if wantarray;
 238   return
 239 }
 240
 241 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 242 #
 243 # And now targets (not directives)
 244
 245 sub accept_target         { shift->accept_targets(@_)         } # alias
 246 sub accept_target_as_text { shift->accept_targets_as_text(@_) } # alias
 247
 248
 249 sub accept_targets         { shift->_accept_targets('1', @_) }
 250
 251 sub accept_targets_as_text { shift->_accept_targets('force_resolve', @_) }
 252  # forces them to be processed, even when there's no ":".
 253
 254 sub _accept_targets {
 255   my($this, $type) = splice @_,0,2;
 256   foreach my $t (@_) {
 257     next unless defined $t and length $t;
 258     # TODO: enforce some limitations on what a target name can be?
 259     $this->{'accept_targets'}{$t} = $type;
 260     DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n";
 261   }
 262   return sort keys %{ $this->{'accept_targets'} } if wantarray;
 263   return;
 264 }
 265
 266 #--------------------------------------------------------------------------
 267 sub unaccept_target         { shift->unaccept_targets(@_) }
 268
 269 sub unaccept_targets {
 270   my $this = shift;
 271   foreach my $t (@_) {
 272     next unless defined $t and length $t;
 273     # TODO: enforce some limitations on what a target name can be?
 274     delete $this->{'accept_targets'}{$t};
 275     DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n";
 276   }
 277   return sort keys %{ $this->{'accept_targets'} } if wantarray;
 278   return;
 279 }
 280
 281 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 282 #
 283 # And now codes (not targets or directives)
 284
 285 sub accept_code { shift->accept_codes(@_) } # alias
 286
 287 sub accept_codes {  # Add some codes
 288   my $this = shift;
 289
 290   foreach my $new_code (@_) {
 291     next unless defined $new_code and length $new_code;
 292     if(ASCII) {
 293       # A good-enough check that it's good as an XML Name symbol:
 294       Carp::croak "\"$new_code\" isn't a valid element name"
 295         if $new_code =~
 296           m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
 297             # Characters under 0x80 that aren't legal in an XML Name.
 298         or $new_code =~ m/^[-\.0-9]/s
 299         or $new_code =~ m/:[-\.0-9]/s;
 300             # The legal under-0x80 Name characters that
 301             #  an XML Name still can't start with.
 302     }
 303
 304     $this->{'accept_codes'}{$new_code} = $new_code;
 305
 306     # Yes, map to itself -- just so that when we
 307     #  see "=extend W [whatever] thatelementname", we say that W maps
 308     #  to whatever $this->{accept_codes}{thatelementname} is,
 309     #  i.e., "thatelementname".  Then when we go re-mapping,
 310     #  a "W" in the treelet turns into "thatelementname".  We only
 311     #  remap once.
 312     # If we say we accept "W", then a "W" in the treelet simply turns
 313     #  into "W".
 314   }
 315
 316   return;
 317 }
 318
 319 #--------------------------------------------------------------------------
 320 sub unaccept_code { shift->unaccept_codes(@_) }
 321
 322 sub unaccept_codes { # remove some codes
 323   my $this = shift;
 324
 325   foreach my $new_code (@_) {
 326     next unless defined $new_code and length $new_code;
 327     if(ASCII) {
 328       # A good-enough check that it's good as an XML Name symbol:
 329       Carp::croak "\"$new_code\" isn't a valid element name"
 330         if $new_code =~
 331           m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/
 332             # Characters under 0x80 that aren't legal in an XML Name.
 333         or $new_code =~ m/^[-\.0-9]/s
 334         or $new_code =~ m/:[-\.0-9]/s;
 335             # The legal under-0x80 Name characters that
 336             #  an XML Name still can't start with.
 337     }
 338
 339     Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!"
 340      if grep $new_code eq $_, @Known_formatting_codes;
 341
 342     delete $this->{'accept_codes'}{$new_code};
 343
 344     DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n";
 345   }
 346
 347   return;
 348 }
 349
 350
 351 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 352 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 353
 354 sub parse_string_document {
 355   my $self = shift;
 356   my @lines;
 357   foreach my $line_group (@_) {
 358     next unless defined $line_group and length $line_group;
 359     pos($line_group) = 0;
 360     while($line_group =~
 361       m/([^\n\r]*)((?:\r?\n)?)/g
 362     ) {
 363       #print(">> $1\n"),
 364       $self->parse_lines($1)
 365        if length($1) or length($2)
 366         or pos($line_group) != length($line_group);
 367        # I.e., unless it's a zero-length "empty line" at the very
 368        #  end of "foo\nbar\n" (i.e., between the \n and the EOS).
 369     }
 370   }
 371   $self->parse_lines(undef); # to signal EOF
 372   return $self;
 373 }
 374
 375 sub _init_fh_source {
 376   my($self, $source) = @_;
 377
 378   #DEBUG > 1 and print "Declaring $source as :raw for starters\n";
 379   #$self->_apply_binmode($source, ':raw');
 380   #binmode($source, ":raw");
 381
 382   return;
 383 }
 384
 385 #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
 386 #
 387
 388 sub parse_file {
 389   my($self, $source) = (@_);
 390
 391   if(!defined $source) {
 392     Carp::croak("Can't use empty-string as a source for parse_file");
 393   } elsif(ref(\$source) eq 'GLOB') {
 394     $self->{'source_filename'} = '' . ($source);
 395   } elsif(ref $source) {
 396     $self->{'source_filename'} = '' . ($source);
 397   } elsif(!length $source) {
 398     Carp::croak("Can't use empty-string as a source for parse_file");
 399   } else {
 400     {
 401       local *PODSOURCE;
 402       open(PODSOURCE, "<$source") || Carp::croak("Can't open $source: $!");
 403       $self->{'source_filename'} = $source;
 404       $source = *PODSOURCE{IO};
 405     }
 406     $self->_init_fh_source($source);
 407   }
 408   # By here, $source is a FH.
 409
 410   $self->{'source_fh'} = $source;
 411
 412   my($i, @lines);
 413   until( $self->{'source_dead'} ) {
 414     splice @lines;
 415     for($i = MANY_LINES; $i--;) {  # read those many lines at a time
 416       local $/ = $NL;
 417       push @lines, scalar(<$source>);  # readline
 418       last unless defined $lines[-1];
 419        # but pass thru the undef, which will set source_dead to true
 420     }
 421     $self->parse_lines(@lines);
 422   }
 423   delete($self->{'source_fh'}); # so it can be GC'd
 424   return $self;
 425 }
 426
 427 #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
 428
 429 sub parse_from_file {
 430   # An emulation of Pod::Parser's interface, for the sake of Perldoc.
 431   # Basically just a wrapper around parse_file.
 432
 433   my($self, $source, $to) = @_;
 434   $self = $self->new unless ref($self); # so we tolerate being a class method
 435
 436   if(!defined $source)             { $source = *STDIN{IO}
 437   } elsif(ref(\$source) eq 'GLOB') { # stet
 438   } elsif(ref($source)           ) { # stet
 439   } elsif(!length $source
 440      or $source eq '-' or $source =~ m/^<&(STDIN|0)$/i
 441   ) {
 442     $source = *STDIN{IO};
 443   }
 444
 445   if(!defined $to) {             $self->output_fh( *STDOUT{IO}   );
 446   } elsif(ref(\$to) eq 'GLOB') { $self->output_fh( $to );
 447   } elsif(ref($to)) {            $self->output_fh( $to );
 448   } elsif(!length $to
 449      or $to eq '-' or $to =~ m/^>&?(?:STDOUT|1)$/i
 450   ) {
 451     $self->output_fh( *STDOUT{IO} );
 452   } else {
 453     require Symbol;
 454     my $out_fh = Symbol::gensym();
 455     DEBUG and print "Write-opening to $to\n";
 456     open($out_fh, ">$to")  or  Carp::croak "Can't write-open $to: $!";
 457     binmode($out_fh)
 458      if $self->can('write_with_binmode') and $self->write_with_binmode;
 459     $self->output_fh($out_fh);
 460   }
 461
 462   return $self->parse_file($source);
 463 }
 464
 465 #-----------------------------------------------------------------------------
 466
 467 sub whine {
 468   #my($self,$line,$complaint) = @_;
 469   my $self = shift(@_);
 470   ++$self->{'errors_seen'};
 471   if($self->{'no_whining'}) {
 472     DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n";
 473     return;
 474   }
 475   return $self->_complain_warn(@_) if $self->{'complain_stderr'};
 476   return $self->_complain_errata(@_);
 477 }
 478
 479 sub scream {    # like whine, but not suppressable
 480   #my($self,$line,$complaint) = @_;
 481   my $self = shift(@_);
 482   ++$self->{'errors_seen'};
 483   return $self->_complain_warn(@_) if $self->{'complain_stderr'};
 484   return $self->_complain_errata(@_);
 485 }
 486
 487 sub _complain_warn {
 488   my($self,$line,$complaint) = @_;
 489   return printf STDERR "%s around line %s: %s\n",
 490     $self->{'source_filename'} || 'Pod input', $line, $complaint;
 491 }
 492
 493 sub _complain_errata {
 494   my($self,$line,$complaint) = @_;
 495   if( $self->{'no_errata_section'} ) {
 496     DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n";
 497   } else {
 498     DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n";
 499     push @{$self->{'errata'}{$line}}, $complaint
 500       # for a report to be generated later!
 501   }
 502   return 1;
 503 }
 504
 505 #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 506
 507 sub _get_initial_item_type {
 508   # A hack-wrapper here for when you have like "=over\n\n=item 456\n\n"
 509   my($self, $para) = @_;
 510   return $para->[1]{'~type'}  if $para->[1]{'~type'};
 511
 512   return $para->[1]{'~type'} = 'text'
 513    if join("\n", @{$para}[2 .. $#$para]) =~ m/^\s*(\d+)\.?\s*$/s and $1 ne '1';
 514   # Else fall thru to the general case:
 515   return $self->_get_item_type($para);
 516 }
 517
 518
 519
 520 sub _get_item_type {       # mutates the item!!
 521   my($self, $para) = @_;
 522   return $para->[1]{'~type'} if $para->[1]{'~type'};
 523
 524
 525   # Otherwise we haven't yet been to this node.  Maybe alter it...
 526
 527   my $content = join "\n", @{$para}[2 .. $#$para];
 528
 529   if($content =~ m/^\s*\*\s*$/s or $content =~ m/^\s*$/s) {
 530     # Like: "=item *", "=item   *   ", "=item"
 531     splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
 532     $para->[1]{'~orig_content'} = $content;
 533     return $para->[1]{'~type'} = 'bullet';
 534
 535   } elsif($content =~ m/^\s*\*\s+(.+)/s) {  # tolerance
 536
 537     # Like: "=item * Foo bar baz";
 538     $para->[1]{'~orig_content'}      = $content;
 539     $para->[1]{'~_freaky_para_hack'} = $1;
 540     DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n";
 541     splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
 542     return $para->[1]{'~type'} = 'bullet';
 543
 544   } elsif($content =~ m/^\s*(\d+)\.?\s*$/s) {
 545     # Like: "=item 1.", "=item    123412"
 546
 547     $para->[1]{'~orig_content'} = $content;
 548     $para->[1]{'number'} = $1;  # Yes, stores the number there!
 549
 550     splice @$para, 2; # so it ends up just being ['=item', { attrhash } ]
 551     return $para->[1]{'~type'} = 'number';
 552
 553   } else {
 554     # It's anything else.
 555     return $para->[1]{'~type'} = 'text';
 556
 557   }
 558 }
 559
 560 #-----------------------------------------------------------------------------
 561
 562 sub _make_treelet {
 563   my $self = shift;  # and ($para, $start_line)
 564   my $treelet;
 565   if(!@_) {
 566     return [''];
 567   } if(ref $_[0] and ref $_[0][0] and $_[0][0][0] eq '~Top') {
 568     # Hack so we can pass in fake-o pre-cooked paragraphs:
 569     #  just have the first line be a reference to a ['~Top', {}, ...]
 570     # We use this feechure in gen_errata and stuff.
 571
 572     DEBUG and print "Applying precooked treelet hack to $_[0][0]\n";
 573     $treelet = $_[0][0];
 574     splice @$treelet, 0, 2;  # lop the top off
 575     return $treelet;
 576   } else {
 577     $treelet = $self->_treelet_from_formatting_codes(@_);
 578   }
 579
 580   if( $self->_remap_sequences($treelet) ) {
 581     $self->_treat_Zs($treelet);  # Might as well nix these first
 582     $self->_treat_Ls($treelet);  # L has to precede E and S
 583     $self->_treat_Es($treelet);
 584     $self->_treat_Ss($treelet);  # S has to come after E
 585
 586     $self->_wrap_up($treelet); # Nix X's and merge texties
 587
 588   } else {
 589     DEBUG and print "Formatless treelet gets fast-tracked.\n";
 590      # Very common case!
 591   }
 592
 593   splice @$treelet, 0, 2;  # lop the top off
 594
 595   return $treelet;
 596 }
 597
 598 #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
 599
 600 sub _wrap_up {
 601   my($self, @stack) = @_;
 602   my $nixx  = $self->{'nix_X_codes'};
 603   my $merge = $self->{'merge_text' };
 604   return unless $nixx or $merge;
 605
 606   DEBUG > 2 and print "\nStarting _wrap_up traversal.\n",
 607    $merge ? (" Merge mode on\n") : (),
 608    $nixx  ? (" Nix-X mode on\n") : (),
 609   ;
 610
 611
 612   my($i, $treelet);
 613   while($treelet = shift @stack) {
 614     DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
 615     for($i = 2; $i < @$treelet; ++$i) { # iterate over children
 616       DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n";
 617       if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') {
 618         DEBUG > 3 and print "   Nixing X node at $i\n";
 619         splice(@$treelet, $i, 1); # just nix this node (and its descendants)
 620         # no need to back-update the counter just yet
 621         redo;
 622
 623       } elsif($merge and $i != 2 and  # non-initial
 624          !ref $treelet->[$i] and !ref $treelet->[$i - 1]
 625       ) {
 626         DEBUG > 3 and print "   Merging ", $i-1,
 627          ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n";
 628         $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0];
 629         DEBUG > 4 and print "    Now: ", $i-1, ":[$treelet->[$i-1]]\n";
 630         --$i;
 631         next;
 632         # since we just pulled the possibly last node out from under
 633         #  ourselves, we can't just redo()
 634
 635       } elsif( ref $treelet->[$i] ) {
 636         DEBUG > 4 and print "  Enqueuing ", pretty($treelet->[$i]), " for traversal.\n";
 637         push @stack, $treelet->[$i];
 638
 639         if($treelet->[$i][0] eq 'L') {
 640           my $thing;
 641           foreach my $attrname ('section', 'to') {
 642             if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
 643               unshift @stack, $thing;
 644               DEBUG > 4 and print "  +Enqueuing ",
 645                pretty( $treelet->[$i][1]{$attrname} ),
 646                " as an attribute value to tweak.\n";
 647             }
 648           }
 649         }
 650       }
 651     }
 652   }
 653   DEBUG > 2 and print "End of _wrap_up traversal.\n\n";
 654
 655   return;
 656 }
 657
 658 #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
 659
 660 sub _remap_sequences {
 661   my($self,@stack) = @_;
 662
 663   if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) {
 664     # VERY common case: abort it.
 665     DEBUG and print "Skipping _remap_sequences: formatless treelet.\n";
 666     return 0;
 667   }
 668
 669   my $map = ($self->{'accept_codes'} || die "NO accept_codes in $self?!?");
 670
 671   my $start_line = $stack[0][1]{'start_line'};
 672   DEBUG > 2 and printf
 673    "\nAbout to start _remap_sequences on treelet from line %s.\n",
 674    $start_line || '[?]'
 675   ;
 676   DEBUG > 3 and print " Map: ",
 677     join('; ', map "$_=" . (
 678         ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_}
 679       ),
 680       sort keys %$map ),
 681     ("B~C~E~F~I~L~S~X~Z" eq join '~', sort keys %$map)
 682      ? "  (all normal)\n" : "\n"
 683   ;
 684
 685   # A recursive algorithm implemented iteratively!  Whee!
 686
 687   my($is, $was, $i, $treelet); # scratch
 688   while($treelet = shift @stack) {
 689     DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n";
 690     for($i = 2; $i < @$treelet; ++$i) { # iterate over children
 691       next unless ref $treelet->[$i];  # text nodes are uninteresting
 692
 693       DEBUG > 4 and print "  Noting child $i : $treelet->[$i][0]<...>\n";
 694
 695       $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] };
 696       if( DEBUG > 3 ) {
 697         if(!defined $is) {
 698           print "   Code $was<> is UNKNOWN!\n";
 699         } elsif($is eq $was) {
 700           DEBUG > 4 and print "   Code $was<> stays the same.\n";
 701         } else  {
 702           print "   Code $was<> maps to ",
 703            ref($is)
 704             ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" )
 705             : "tag $is<...>.\n";
 706         }
 707       }
 708
 709       if(!defined $is) {
 710         $self->whine($start_line, "Deleting unknown formatting code $was<>");
 711         $is = $treelet->[$i][0] = '1';  # But saving the children!
 712         # I could also insert a leading "$was<" and tailing ">" as
 713         # children of this node, but something about that seems icky.
 714       }
 715       if(ref $is) {
 716         my @dynasty = @$is;
 717         DEBUG > 4 and print "    Renaming $was node to $dynasty[-1]\n";
 718         $treelet->[$i][0] = pop @dynasty;
 719         my $nugget;
 720         while(@dynasty) {
 721           DEBUG > 4 and printf
 722            "    Grafting a new %s node between %s and %s\n",
 723            $dynasty[-1], $treelet->[0], $treelet->[$i][0],
 724           ;
 725
 726           #$nugget = ;
 727           splice @$treelet, $i, 1, [pop(@dynasty), {}, $treelet->[$i]];
 728             # relace node with a new parent
 729         }
 730       } elsif($is eq '0') {
 731         splice(@$treelet, $i, 1); # just nix this node (and its descendants)
 732         --$i;  # back-update the counter
 733       } elsif($is eq '1') {
 734         splice(@$treelet, $i, 1 # replace this node with its children!
 735           => splice @{ $treelet->[$i] },2
 736               # (not catching its first two (non-child) items)
 737         );
 738         --$i;  # back up for new stuff
 739       } else {
 740         # otherwise it's unremarkable
 741         unshift @stack, $treelet->[$i];  # just recurse
 742       }
 743     }
 744   }
 745
 746   DEBUG > 2 and print "End of _remap_sequences traversal.\n\n";
 747
 748   if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) {
 749     DEBUG and print "Noting that the treelet is now formatless.\n";
 750     return 0;
 751   }
 752   return 1;
 753 }
 754
 755 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
 756
 757 sub _ponder_extend {
 758
 759   # "Go to an extreme, move back to a more comfortable place"
 760   #  -- /Oblique Strategies/,  Brian Eno and Peter Schmidt
 761
 762   my($self, $para) = @_;
 763   my $content = join ' ', splice @$para, 2;
 764   $content =~ s/^\s+//s;
 765   $content =~ s/\s+$//s;
 766
 767   DEBUG > 2 and print "Ogling extensor: =extend $content\n";
 768
 769   if($content =~
 770     m/^
 771       (\S+)         # 1 : new item
 772       \s+
 773       (\S+)         # 2 : fallback(s)
 774       (?:\s+(\S+))? # 3 : element name(s)
 775       \s*
 776       $
 777     /xs
 778   ) {
 779     my $new_letter = $1;
 780     my $fallbacks_one = $2;
 781     my $elements_one;
 782     $elements_one = defined($3) ? $3 : $1;
 783
 784     DEBUG > 2 and print "Extensor has good syntax.\n";
 785
 786     unless($new_letter =~ m/^[A-Z]$/s or $new_letter) {
 787       DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n";
 788       $self->whine(
 789         $para->[1]{'start_line'},
 790         "You can extend only formatting codes A-Z, not like \"$new_letter\""
 791       );
 792       return;
 793     }
 794
 795     if(grep $new_letter eq $_, @Known_formatting_codes) {
 796       DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n";
 797       $self->whine(
 798         $para->[1]{'start_line'},
 799         "You can't extend an established code like \"$new_letter\""
 800       );
 801
 802       #TODO: or allow if last bit is same?
 803
 804       return;
 805     }
 806
 807     unless($fallbacks_one =~ m/^[A-Z](,[A-Z])*$/s  # like "B", "M,I", etc.
 808       or $fallbacks_one eq '0' or $fallbacks_one eq '1'
 809     ) {
 810       $self->whine(
 811         $para->[1]{'start_line'},
 812         "Format for second =extend parameter must be like"
 813         . " M or 1 or 0 or M,N or M,N,O but you have it like "
 814         . $fallbacks_one
 815       );
 816       return;
 817     }
 818
 819     unless($elements_one =~ m/^[^ ,]+(,[^ ,]+)*$/s) { # like "B", "M,I", etc.
 820       $self->whine(
 821         $para->[1]{'start_line'},
 822         "Format for third =extend parameter: like foo or bar,Baz,qu:ux but not like "
 823         . $elements_one
 824       );
 825       return;
 826     }
 827
 828     my @fallbacks  = split ',', $fallbacks_one,  -1;
 829     my @elements   = split ',', $elements_one, -1;
 830
 831     foreach my $f (@fallbacks) {
 832       next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1';
 833       DEBUG > 2 and print "  Can't fall back on unknown code $f\n";
 834       $self->whine(
 835         $para->[1]{'start_line'},
 836         "Can't use unknown formatting code '$f' as a fallback for '$new_letter'"
 837       );
 838       return;
 839     }
 840
 841     DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n",
 842      @fallbacks, @elements;
 843
 844     my $canonical_form;
 845     foreach my $e (@elements) {
 846       if(exists $self->{'accept_codes'}{$e}) {
 847         DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n";
 848         $canonical_form = $e;
 849         last; # first acceptable elementname wins!
 850       } else {
 851         DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n";
 852       }
 853     }
 854
 855
 856     if( defined $canonical_form ) {
 857       # We found a good N => elementname mapping
 858       $self->{'accept_codes'}{$new_letter} = $canonical_form;
 859       DEBUG > 2 and print
 860        "Extensor maps $new_letter => known element $canonical_form.\n";
 861     } else {
 862       # We have to use the fallback(s), which might be '0', or '1'.
 863       $self->{'accept_codes'}{$new_letter}
 864         = (@fallbacks == 1) ? $fallbacks[0] : \@fallbacks;
 865       DEBUG > 2 and print
 866        "Extensor maps $new_letter => fallbacks @fallbacks.\n";
 867     }
 868
 869   } else {
 870     DEBUG > 2 and print "Extensor has bad syntax.\n";
 871     $self->whine(
 872       $para->[1]{'start_line'},
 873       "Unknown =extend syntax: $content"
 874     )
 875   }
 876   return;
 877 }
 878
 879
 880 #:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.:.
 881
 882 sub _treat_Zs {  # Nix Z<...>'s
 883   my($self,@stack) = @_;
 884
 885   my($i, $treelet);
 886   my $start_line = $stack[0][1]{'start_line'};
 887
 888   # A recursive algorithm implemented iteratively!  Whee!
 889
 890   while($treelet = shift @stack) {
 891     for($i = 2; $i < @$treelet; ++$i) { # iterate over children
 892       next unless ref $treelet->[$i];  # text nodes are uninteresting
 893       unless($treelet->[$i][0] eq 'Z') {
 894         unshift @stack, $treelet->[$i]; # recurse
 895         next;
 896       }
 897
 898       DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n";
 899
 900       # bitch UNLESS it's empty
 901       unless(  @{$treelet->[$i]} == 2
 902            or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
 903       ) {
 904         $self->whine( $start_line, "A non-empty Z<>" );
 905       }      # but kill it anyway
 906
 907       splice(@$treelet, $i, 1); # thereby just nix this node.
 908       --$i;
 909
 910     }
 911   }
 912
 913   return;
 914 }
 915
 916 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
 917
 918 # Quoting perlpodspec:
 919
 920 # In parsing an L<...> code, Pod parsers must distinguish at least four
 921 # attributes:
 922
 923 ############# Not used.  Expressed via the element children plus
 924 #############  the value of the "content-implicit" flag.
 925 # First:
 926 # The link-text. If there is none, this must be undef. (E.g., in "L<Perl
 927 # Functions|perlfunc>", the link-text is "Perl Functions". In
 928 # "L<Time::HiRes>" and even "L<|Time::HiRes>", there is no link text. Note
 929 # that link text may contain formatting.)
 930 #
 931
 932 ############# The element children
 933 # Second:
 934 # The possibly inferred link-text -- i.e., if there was no real link text,
 935 # then this is the text that we'll infer in its place. (E.g., for
 936 # "L<Getopt::Std>", the inferred link text is "Getopt::Std".)
 937 #
 938
 939 ############# The "to" attribute (which might be text, or a treelet)
 940 # Third:
 941 # The name or URL, or undef if none. (E.g., in "L<Perl
 942 # Functions|perlfunc>", the name -- also sometimes called the page -- is
 943 # "perlfunc". In "L</CAVEATS>", the name is undef.)
 944 #
 945
 946 ############# The "section" attribute (which might be next, or a treelet)
 947 # Fourth:
 948 # The section (AKA "item" in older perlpods), or undef if none. E.g., in
 949 # Getopt::Std/DESCRIPTION, "DESCRIPTION" is the section. (Note that this
 950 # is not the same as a manpage section like the "5" in "man 5 crontab".
 951 # "Section Foo" in the Pod sense means the part of the text that's
 952 # introduced by the heading or item whose text is "Foo".)
 953 #
 954 # Pod parsers may also note additional attributes including:
 955 #
 956
 957 ############# The "type" attribute.
 958 # Fifth:
 959 # A flag for whether item 3 (if present) is a URL (like
 960 # "http://lists.perl.org" is), in which case there should be no section
 961 # attribute; a Pod name (like "perldoc" and "Getopt::Std" are); or
 962 # possibly a man page name (like "crontab(5)" is).
 963 #
 964
 965 ############# Not implemented, I guess.
 966 # Sixth:
 967 # The raw original L<...> content, before text is split on "|", "/", etc,
 968 # and before E<...> codes are expanded.
 969
 970
 971 # For L<...> codes without a "name|" part, only E<...> and Z<> codes may
 972 # occur -- no other formatting codes. That is, authors should not use
 973 # "L<B<Foo::Bar>>".
 974 #
 975 # Note, however, that formatting codes and Z<>'s can occur in any and all
 976 # parts of an L<...> (i.e., in name, section, text, and url).
 977
 978 sub _treat_Ls {  # Process our dear dear friends, the L<...> sequences
 979
 980   # L<name>
 981   # L<name/"sec"> or L<name/sec>
 982   # L</"sec"> or L</sec> or L<"sec">
 983   # L<text|name>
 984   # L<text|name/"sec"> or L<text|name/sec>
 985   # L<text|/"sec"> or L<text|/sec> or L<text|"sec">
 986   # L<scheme:...>
 987   # Ltext|scheme:...>
 988
 989   my($self,@stack) = @_;
 990
 991   my($i, $treelet);
 992   my $start_line = $stack[0][1]{'start_line'};
 993
 994   # A recursive algorithm implemented iteratively!  Whee!
 995
 996   while($treelet = shift @stack) {
 997     for(my $i = 2; $i < @$treelet; ++$i) {
 998       # iterate over children of current tree node
 999       next unless ref $treelet->[$i];  # text nodes are uninteresting
1000       unless($treelet->[$i][0] eq 'L') {
1001         unshift @stack, $treelet->[$i]; # recurse
1002         next;
1003       }
1004
1005
1006       # By here, $treelet->[$i] is definitely an L node
1007       my $ell = $treelet->[$i];
1008       DEBUG > 1 and print "Ogling L node $ell\n";
1009
1010       # bitch if it's empty
1011       if(  @{$ell} == 2
1012        or (@{$ell} == 3 and $ell->[2] eq '')
1013       ) {
1014         $self->whine( $start_line, "An empty L<>" );
1015         $treelet->[$i] = 'L<>';  # just make it a text node
1016         next;  # and move on
1017       }
1018
1019       # Catch URLs:
1020
1021       # there are a number of possible cases:
1022       # 1) text node containing url: http://foo.com
1023       #   -> [ 'http://foo.com' ]
1024       # 2) text node containing url and text: foo|http://foo.com
1025       #   -> [ 'foo|http://foo.com' ]
1026       # 3) text node containing url start: mailto:xE<at>foo.com
1027       #   -> [ 'mailto:x', [ E ... ], 'foo.com' ]
1028       # 4) text node containing url start and text: foo|mailto:xE<at>foo.com
1029       #   -> [ 'foo|mailto:x', [ E ... ], 'foo.com' ]
1030       # 5) other nodes containing text and url start: OE<39>Malley|http://foo.com
1031       #   -> [ 'O', [ E ... ], 'Malley', '|http://foo.com' ]
1032       # ... etc.
1033
1034       # anything before the url is part of the text.
1035       # anything after it is part of the url.
1036       # the url text node itself may contain parts of both.
1037
1038       if (my ($url_index, $text_part, $url_part) =
1039         # grep is no good here; we want to bail out immediately so that we can
1040         # use $1, $2, etc. without having to do the match twice.
1041         sub {
1042           for (2..$#$ell) {
1043             next if ref $ell->[$_];
1044             next unless $ell->[$_] =~ m/^(?:([^|]*)\|)?(\w+:[^:\s]\S*)$/s;
1045             return ($_, $1, $2);
1046           }
1047           return;
1048         }->()
1049       ) {
1050         $ell->[1]{'type'} = 'url';
1051
1052         my @text = @{$ell}[2..$url_index-1];
1053         push @text, $text_part if defined $text_part;
1054
1055         my @url  = @{$ell}[$url_index+1..$#$ell];
1056         unshift @url, $url_part;
1057
1058         unless (@text) {
1059           $ell->[1]{'content-implicit'} = 'yes';
1060           @text = @url;
1061         }
1062
1063         $ell->[1]{to} = Pod::Simple::LinkSection->new(
1064           @url == 1
1065           ? $url[0]
1066           : [ '', {}, @url ],
1067         );
1068
1069         splice @$ell, 2, $#$ell, @text;
1070
1071         next;
1072       }
1073
1074       # Catch some very simple and/or common cases
1075       if(@{$ell} == 3 and ! ref $ell->[2]) {
1076         my $it = $ell->[2];
1077         if($it =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s) { # man sections
1078           # Hopefully neither too broad nor too restrictive a RE
1079           DEBUG > 1 and print "Catching \"$it\" as manpage link.\n";
1080           $ell->[1]{'type'} = 'man';
1081           # This's the only place where man links can get made.
1082           $ell->[1]{'content-implicit'} = 'yes';
1083           $ell->[1]{'to'  } =
1084             Pod::Simple::LinkSection->new( $it ); # treelet!
1085
1086           next;
1087         }
1088         if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) {
1089           # Extremely forgiving idea of what constitutes a bare
1090           #  modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala>
1091           DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n";
1092           $ell->[1]{'type'} = 'pod';
1093           $ell->[1]{'content-implicit'} = 'yes';
1094           $ell->[1]{'to'  } =
1095             Pod::Simple::LinkSection->new( $it ); # treelet!
1096           next;
1097         }
1098         # else fall thru...
1099       }
1100
1101
1102
1103       # ...Uhoh, here's the real L<...> parsing stuff...
1104       # "With the ill behavior, with the ill behavior, with the ill behavior..."
1105
1106       DEBUG > 1 and print "Running a real parse on this non-trivial L\n";
1107
1108
1109       my $link_text; # set to an arrayref if found
1110       my @ell_content = @$ell;
1111       splice @ell_content,0,2; # Knock off the 'L' and {} bits
1112
1113       DEBUG > 3 and print " Ell content to start: ",
1114        pretty(@ell_content), "\n";
1115
1116
1117       # Look for the "|" -- only in CHILDREN (not all underlings!)
1118       # Like L<I like the strictness|strict>
1119       DEBUG > 3 and
1120          print "  Peering at L content for a '|' ...\n";
1121       for(my $j = 0; $j < @ell_content; ++$j) {
1122         next if ref $ell_content[$j];
1123         DEBUG > 3 and
1124          print "    Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n";
1125
1126         if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) {
1127           my @link_text = ($1);   # might be 0-length
1128           $ell_content[$j] = $2;  # might be 0-length
1129
1130           DEBUG > 3 and
1131            print "     FOUND a '|' in it.  Splitting into [$1] + [$2]\n";
1132
1133           unshift @link_text, splice @ell_content, 0, $j;
1134             # leaving only things at J and after
1135           @ell_content =  grep ref($_)||length($_), @ell_content ;
1136           $link_text   = [grep ref($_)||length($_), @link_text  ];
1137           DEBUG > 3 and printf
1138            "  So link text is %s\n  and remaining ell content is %s\n",
1139             pretty($link_text), pretty(@ell_content);
1140           last;
1141         }
1142       }
1143
1144
1145       # Now look for the "/" -- only in CHILDREN (not all underlings!)
1146       # And afterward, anything left in @ell_content will be the raw name
1147       # Like L<Foo::Bar/Object Methods>
1148       my $section_name;  # set to arrayref if found
1149       DEBUG > 3 and print "  Peering at L-content for a '/' ...\n";
1150       for(my $j = 0; $j < @ell_content; ++$j) {
1151         next if ref $ell_content[$j];
1152         DEBUG > 3 and
1153          print "    Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n";
1154
1155         if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) {
1156           my @section_name = ($2); # might be 0-length
1157           $ell_content[$j] =  $1;  # might be 0-length
1158
1159           DEBUG > 3 and
1160            print "     FOUND a '/' in it.",
1161              "  Splitting to page [...$1] + section [$2...]\n";
1162
1163           push @section_name, splice @ell_content, 1+$j;
1164             # leaving only things before and including J
1165
1166           @ell_content  = grep ref($_)||length($_), @ell_content  ;
1167           @section_name = grep ref($_)||length($_), @section_name ;
1168
1169           # Turn L<.../"foo"> into L<.../foo>
1170           if(@section_name
1171             and !ref($section_name[0]) and !ref($section_name[-1])
1172             and $section_name[ 0] =~ m/^\"/s
1173             and $section_name[-1] =~ m/\"$/s
1174             and !( # catch weird degenerate case of L<"> !
1175               @section_name == 1 and $section_name[0] eq '"'
1176             )
1177           ) {
1178             $section_name[ 0] =~ s/^\"//s;
1179             $section_name[-1] =~ s/\"$//s;
1180             DEBUG > 3 and
1181              print "     Quotes removed: ", pretty(@section_name), "\n";
1182           } else {
1183             DEBUG > 3 and
1184              print "     No need to remove quotes in ", pretty(@section_name), "\n";
1185           }
1186
1187           $section_name = \@section_name;
1188           last;
1189         }
1190       }
1191
1192       # Turn L<"Foo Bar"> into L</Foo Bar>
1193       if(!$section_name and @ell_content
1194          and !ref($ell_content[0]) and !ref($ell_content[-1])
1195          and $ell_content[ 0] =~ m/^\"/s
1196          and $ell_content[-1] =~ m/\"$/s
1197          and !( # catch weird degenerate case of L<"> !
1198            @ell_content == 1 and $ell_content[0] eq '"'
1199          )
1200       ) {
1201         $section_name = [splice @ell_content];
1202         $section_name->[ 0] =~ s/^\"//s;
1203         $section_name->[-1] =~ s/\"$//s;
1204       }
1205
1206       # Turn L<Foo Bar> into L</Foo Bar>.
1207       if(!$section_name and !$link_text and @ell_content
1208          and grep !ref($_) && m/ /s, @ell_content
1209       ) {
1210         $section_name = [splice @ell_content];
1211         # That's support for the now-deprecated syntax.
1212         # (Maybe generate a warning eventually?)
1213         # Note that it deliberately won't work on L<...|Foo Bar>
1214       }
1215
1216
1217       # Now make up the link_text
1218       # L<Foo>     -> L<Foo|Foo>
1219       # L</Bar>    -> L<"Bar"|Bar>
1220       # L<Foo/Bar> -> L<"Bar" in Foo/Foo>
1221       unless($link_text) {
1222         $ell->[1]{'content-implicit'} = 'yes';
1223         $link_text = [];
1224         push @$link_text, '"', @$section_name, '"' if $section_name;
1225
1226         if(@ell_content) {
1227           $link_text->[-1] .= ' in ' if $section_name;
1228           push @$link_text, @ell_content;
1229         }
1230       }
1231
1232
1233       # And the E resolver will have to deal with all our treeletty things:
1234
1235       if(@ell_content == 1 and !ref($ell_content[0])
1236          and $ell_content[0] =~ m/^[-a-zA-Z0-9]+\([-a-zA-Z0-9]+\)$/s
1237       ) {
1238         $ell->[1]{'type'}    = 'man';
1239         DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n";
1240       } else {
1241         $ell->[1]{'type'}    = 'pod';
1242         DEBUG > 3 and print "Considering this a pod link (not man or url).\n";
1243       }
1244
1245       if( defined $section_name ) {
1246         $ell->[1]{'section'} = Pod::Simple::LinkSection->new(
1247           ['', {}, @$section_name]
1248         );
1249         DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n";
1250       }
1251
1252       if( @ell_content ) {
1253         $ell->[1]{'to'} = Pod::Simple::LinkSection->new(
1254           ['', {}, @ell_content]
1255         );
1256         DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n";
1257       }
1258
1259       # And update children to be the link-text:
1260       @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : '');
1261
1262       DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n";
1263
1264       unshift @stack, $treelet->[$i]; # might as well recurse
1265     }
1266   }
1267
1268   return;
1269 }
1270
1271 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
1272
1273 sub _treat_Es {
1274   my($self,@stack) = @_;
1275
1276   my($i, $treelet, $content, $replacer, $charnum);
1277   my $start_line = $stack[0][1]{'start_line'};
1278
1279   # A recursive algorithm implemented iteratively!  Whee!
1280
1281
1282   # Has frightening side effects on L nodes' attributes.
1283
1284   #my @ells_to_tweak;
1285
1286   while($treelet = shift @stack) {
1287     for(my $i = 2; $i < @$treelet; ++$i) { # iterate over children
1288       next unless ref $treelet->[$i];  # text nodes are uninteresting
1289       if($treelet->[$i][0] eq 'L') {
1290         # SPECIAL STUFF for semi-processed L<>'s
1291
1292         my $thing;
1293         foreach my $attrname ('section', 'to') {
1294           if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) {
1295             unshift @stack, $thing;
1296             DEBUG > 2 and print "  Enqueuing ",
1297              pretty( $treelet->[$i][1]{$attrname} ),
1298              " as an attribute value to tweak.\n";
1299           }
1300         }
1301
1302         unshift @stack, $treelet->[$i]; # recurse
1303         next;
1304       } elsif($treelet->[$i][0] ne 'E') {
1305         unshift @stack, $treelet->[$i]; # recurse
1306         next;
1307       }
1308
1309       DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n";
1310
1311       # bitch if it's empty
1312       if(  @{$treelet->[$i]} == 2
1313        or (@{$treelet->[$i]} == 3 and $treelet->[$i][2] eq '')
1314       ) {
1315         $self->whine( $start_line, "An empty E<>" );
1316         $treelet->[$i] = 'E<>'; # splice in a literal
1317         next;
1318       }
1319
1320       # bitch if content is weird
1321       unless(@{$treelet->[$i]} == 3 and !ref($content = $treelet->[$i][2])) {
1322         $self->whine( $start_line, "An E<...> surrounding strange content" );
1323         $replacer = $treelet->[$i]; # scratch
1324         splice(@$treelet, $i, 1,   # fake out a literal
1325           'E<',
1326           splice(@$replacer,2), # promote its content
1327           '>'
1328         );
1329         # Don't need to do --$i, as the 'E<' we just added isn't interesting.
1330         next;
1331       }
1332
1333       DEBUG > 1 and print "Ogling E<$content>\n";
1334
1335       $charnum  = Pod::Escapes::e2charnum($content);
1336       DEBUG > 1 and print " Considering E<$content> with char ",
1337         defined($charnum) ? $charnum : "undef", ".\n";
1338
1339       if(!defined( $charnum )) {
1340         DEBUG > 1 and print "I don't know how to deal with E<$content>.\n";
1341         $self->whine( $start_line, "Unknown E content in E<$content>" );
1342         $replacer = "E<$content>"; # better than nothing
1343       } elsif($charnum >= 255 and !UNICODE) {
1344         $replacer = ASCII ? "\xA4" : "?";
1345         DEBUG > 1 and print "This Perl version can't handle ",
1346           "E<$content> (chr $charnum), so replacing with $replacer\n";
1347       } else {
1348         $replacer = Pod::Escapes::e2char($content);
1349         DEBUG > 1 and print " Replacing E<$content> with $replacer\n";
1350       }
1351
1352       splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho
1353     }
1354   }
1355
1356   return;
1357 }
1358
1359
1360 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
1361
1362 sub _treat_Ss {
1363   my($self,$treelet) = @_;
1364
1365   _change_S_to_nbsp($treelet,0) if $self->{'nbsp_for_S'};
1366
1367   # TODO: or a change_nbsp_to_S
1368   #  Normalizing nbsp's to S is harder: for each text node, make S content
1369   #  out of anything matching m/([^ \xA0]*(?:\xA0+[^ \xA0]*)+)/
1370
1371
1372   return;
1373 }
1374
1375
1376 sub _change_S_to_nbsp { #  a recursive function
1377   # Sanely assumes that the top node in the excursion won't be an S node.
1378   my($treelet, $in_s) = @_;
1379
1380   my $is_s = ('S' eq $treelet->[0]);
1381   $in_s ||= $is_s; # So in_s is on either by this being an S element,
1382                    #  or by an ancestor being an S element.
1383
1384   for(my $i = 2; $i < @$treelet; ++$i) {
1385     if(ref $treelet->[$i]) {
1386       if( _change_S_to_nbsp( $treelet->[$i], $in_s ) ) {
1387         my $to_pull_up = $treelet->[$i];
1388         splice @$to_pull_up,0,2;   # ...leaving just its content
1389         splice @$treelet, $i, 1, @$to_pull_up;  # Pull up content
1390         $i +=  @$to_pull_up - 1;   # Make $i skip the pulled-up stuff
1391       }
1392     } else {
1393       $treelet->[$i] =~ s/\s/\xA0/g if ASCII and $in_s;
1394        # (If not in ASCIIland, we can't assume that \xA0 == nbsp.)
1395
1396        # Note that if you apply nbsp_for_S to text, and so turn
1397        # "foo S<bar baz> quux" into "foo bar&#160;faz quux", you
1398        # end up with something that fails to say "and don't hyphenate
1399        # any part of 'bar baz'".  However, hyphenation is such a vexing
1400        # problem anyway, that most Pod renderers just don't render it
1401        # at all.  But if you do want to implement hyphenation, I guess
1402        # that you'd better have nbsp_for_S off.
1403     }
1404   }
1405
1406   return $is_s;
1407 }
1408
1409 #-----------------------------------------------------------------------------
1410
1411 sub _accessorize {  # A simple-minded method-maker
1412   no strict 'refs';
1413   foreach my $attrname (@_) {
1414     next if $attrname =~ m/::/; # a hack
1415     *{caller() . '::' . $attrname} = sub {
1416       use strict;
1417       $Carp::CarpLevel = 1,  Carp::croak(
1418        "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
1419       ) unless (@_ == 1 or @_ == 2) and ref $_[0];
1420       (@_ == 1) ?  $_[0]->{$attrname}
1421                 : ($_[0]->{$attrname} = $_[1]);
1422     };
1423   }
1424   # Ya know, they say accessories make the ensemble!
1425   return;
1426 }
1427
1428 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
1429 # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
1430 #=============================================================================
1431
1432 sub filter {
1433   my($class, $source) = @_;
1434   my $new = $class->new;
1435   $new->output_fh(*STDOUT{IO});
1436
1437   if(ref($source || '') eq 'SCALAR') {
1438     $new->parse_string_document( $$source );
1439   } elsif(ref($source)) {  # it's a file handle
1440     $new->parse_file($source);
1441   } else {  # it's a filename
1442     $new->parse_file($source);
1443   }
1444
1445   return $new;
1446 }
1447
1448
1449 #-----------------------------------------------------------------------------
1450
1451 sub _out {
1452   # For use in testing: Class->_out($source)
1453   #  returns the transformation of $source
1454
1455   my $class = shift(@_);
1456
1457   my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
1458
1459   DEBUG and print "\n\n", '#' x 76,
1460    "\nAbout to parse source: {{\n$_[0]\n}}\n\n";
1461
1462
1463   my $parser = ref $class && $class->isa(__PACKAGE__) ? $class : $class->new;
1464   $parser->hide_line_numbers(1);
1465
1466   my $out = '';
1467   $parser->output_string( \$out );
1468   DEBUG and print " _out to ", \$out, "\n";
1469
1470   $mutor->($parser) if $mutor;
1471
1472   $parser->parse_string_document( $_[0] );
1473   # use Data::Dumper; print Dumper($parser), "\n";
1474   return $out;
1475 }
1476
1477
1478 sub _duo {
1479   # For use in testing: Class->_duo($source1, $source2)
1480   #  returns the parse trees of $source1 and $source2.
1481   # Good in things like: &ok( Class->duo(... , ...) );
1482
1483   my $class = shift(@_);
1484
1485   Carp::croak "But $class->_duo is useful only in list context!"
1486    unless wantarray;
1487
1488   my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE';
1489
1490   Carp::croak "But $class->_duo takes two parameters, not: @_"
1491    unless @_ == 2;
1492
1493   my(@out);
1494
1495   while( @_ ) {
1496     my $parser = $class->new;
1497
1498     push @out, '';
1499     $parser->output_string( \( $out[-1] ) );
1500
1501     DEBUG and print " _duo out to ", $parser->output_string(),
1502       " = $parser->{'output_string'}\n";
1503
1504     $parser->hide_line_numbers(1);
1505     $mutor->($parser) if $mutor;
1506     $parser->parse_string_document( shift( @_ ) );
1507     # use Data::Dumper; print Dumper($parser), "\n";
1508   }
1509
1510   return @out;
1511 }
1512
1513
1514
1515 #-----------------------------------------------------------------------------
1516 1;
1517 __END__
1518
1519 TODO:
1520 A start_formatting_code and end_formatting_code methods, which in the
1521 base class call start_L, end_L, start_C, end_C, etc., if they are
1522 defined.
1523
1524 have the POD FORMATTING ERRORS section note the localtime, and the
1525 version of Pod::Simple.
1526
1527 option to delete all E<shy>s?
1528 option to scream if under-0x20 literals are found in the input, or
1529 under-E<32> E codes are found in the tree. And ditto \x7f-\x9f
1530
1531 Option to turn highbit characters into their compromised form? (applies
1532 to E parsing too)
1533
1534 TODO: BOM/encoding things.
1535
1536 TODO: ascii-compat things in the XML classes?
1537