summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Pod/Simple
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod/Simple')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm1946
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/Checker.pm196
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/Debug.pm178
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm155
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm170
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/HTML.pm979
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm1372
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/HTMLLegacy.pm104
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm174
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/Methody.pm152
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/Progress.pm93
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm844
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm120
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm161
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm128
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm163
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/RTF.pm699
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/Search.pm1043
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm180
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod946
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/Text.pm185
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm112
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm105
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm35
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm63
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm44
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm717
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm185
28 files changed, 11249 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm
new file mode 100755
index 00000000000..c227d4cf460
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm
@@ -0,0 +1,1946 @@
+
+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.13';
+#use constant DEBUG => 7;
+BEGIN {
+ require Pod::Simple;
+ *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+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'};
+ $self->{'line_count'} ||= 0;
+
+ my $scratch;
+
+ DEBUG > 4 and
+ print "# Parsing starting at line ", $self->{'line_count'}, ".\n";
+
+ DEBUG > 5 and
+ print "# 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 "# Source is dead.\n";
+ last;
+ }
+
+ unless( defined $source_line ) {
+ DEBUG > 4 and print "# 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 "First line: [$source_line]\n";
+
+ if( ($line = $source_line) =~ s/^\xEF\xBB\xBF//s ) {
+ DEBUG and print "UTF-8 BOM seen. Faking a '=encode utf8'.\n";
+ $self->_handle_encoding_line( "=encode utf8" );
+ $line =~ tr/\n\r//d;
+
+ } elsif( $line =~ s/^\xFE\xFF//s ) {
+ DEBUG and print "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 "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 "First line is BOM-less.\n";
+ ($line = $source_line) =~ tr/\n\r//d;
+ }
+ }
+
+
+ DEBUG > 5 and print "# Parsing line: [$line]\n";
+
+ if(!$self->{'in_pod'}) {
+ if($line =~ m/^=([a-zA-Z]+)/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 "# 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 "# Setting fname to \"$fname\"\n";
+ DEBUG > 1 and print "# 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 ) {
+ $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 "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(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
+ DEBUG > 1 and print "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 "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 "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 "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 "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 "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 "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(pretty(@$paras), "\n");
+ return $self;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _handle_encoding_line {
+ my($self, $line) = @_;
+
+ # 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 "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 "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 $enc_error;
+ }
+ } elsif (
+ # OK, let's turn on the encoding
+ do {
+ DEBUG > 1 and print " Setting encoding to $e\n";
+ $self->{'encoding'} = $e;
+ 1;
+ }
+ and $e eq 'HACKRAW'
+ ) {
+ DEBUG and print " 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"
+ );
+
+ } else {
+ my @supported = Pod::Simple::Transcode::->all_encodings;
+
+ # Note unsupported, and complain
+ DEBUG and print " 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;
+
+ return '=encoding ALREADYDONE';
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+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 "Ogling encoding directive: =encoding $content\n";
+
+ if($content eq 'ALREADYDONE') {
+ # It's already been handled. Check for errors.
+ if(! $self->{'encoding_command_statuses'} ) {
+ DEBUG > 2 and print " 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 " (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 "\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 "# 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 "# 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: winge 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 "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 "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 "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 "'=$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 = $curr_open->[-1])->[0] eq '=over') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "'=item' outside of any '=over'"
+ );
+ unshift @$paras,
+ ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
+ $para
+ ;
+ 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 " Item is of type ", $para->[0], " under $over_type\n";
+
+ if($item_type eq 'text') {
+ # Nothing special needs doing for 'text'
+ } elsif($item_type eq 'number' or $item_type eq 'bullet') {
+ die "Unknown item type $item_type"
+ unless $item_type eq 'number' or $item_type eq 'bullet';
+ # Undo our clobbering:
+ push @$para, $para->[1]{'~orig_content'};
+ delete $para->[1]{'number'};
+ # Only a PROPER item-number element is allowed
+ # to have a number attribute.
+ } else {
+ die "Unhandled item type $item_type"; # should never happen
+ }
+
+ # =item-text thingies don't need any assimilation, it seems.
+
+ } elsif($over_type eq 'number') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
+
+ if($item_type eq 'bullet') {
+ # Hm, it's not numeric. Correct for this.
+ $para->[1]{'number'} = $expected_value;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item $expected_value'"
+ );
+ push @$para, $para->[1]{'~orig_content'};
+ # restore the bullet, blocking the assimilation of next para
+
+ } elsif($item_type eq 'text') {
+ # Hm, it's not numeric. Correct for this.
+ $para->[1]{'number'} = $expected_value;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item $expected_value'"
+ );
+ # Text content will still be there and will block next ~Para
+
+ } elsif($item_type ne 'number') {
+ die "Unknown item type $item_type"; # should never happen
+
+ } elsif($expected_value == $para->[1]{'number'}) {
+ DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
+
+ } else {
+ DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
+ " instead of the expected value of $expected_value\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You have '=item " . $para->[1]{'number'} .
+ "' instead of the expected '=item $expected_value'"
+ );
+ $para->[1]{'number'} = $expected_value; # correcting!!
+ }
+
+ if(@$para == 2) {
+ # For the cases where we /didn't/ push to @$para
+ if($paras->[0][0] eq '~Para') {
+ DEBUG and print "Assimilating following ~Para content into $over_type item\n";
+ push @$para, splice @{shift @$paras},2;
+ } else {
+ DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
+ push @$para, ''; # Just so it's not contentless
+ }
+ }
+
+
+ } elsif($over_type eq 'bullet') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ if($item_type eq 'bullet') {
+ # as expected!
+
+ if( $para->[1]{'~_freaky_para_hack'} ) {
+ DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
+ push @$para, delete $para->[1]{'~_freaky_para_hack'};
+ }
+
+ } elsif($item_type eq 'number') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item *'"
+ );
+ push @$para, $para->[1]{'~orig_content'};
+ # and block assimilation of the next paragraph
+ delete $para->[1]{'number'};
+ # Only a PROPER item-number element is allowed
+ # to have a number attribute.
+ } elsif($item_type eq 'text') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item *'"
+ );
+ # But doesn't need processing. But it'll block assimilation
+ # of the next para.
+ } else {
+ die "Unhandled item type $item_type"; # should never happen
+ }
+
+ if(@$para == 2) {
+ # For the cases where we /didn't/ push to @$para
+ if($paras->[0][0] eq '~Para') {
+ DEBUG and print "Assimilating following ~Para content into $over_type item\n";
+ push @$para, splice @{shift @$paras},2;
+ } else {
+ DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
+ push @$para, ''; # Just so it's not contentless
+ }
+ }
+
+ } else {
+ die "Unhandled =over type \"$over_type\"?";
+ # Shouldn't happen!
+ }
+
+ $para_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; # and skip
+ } 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 " Pondering known directive ${$para}[0] as $para_type\n";
+ } else {
+ # An unknown directive!
+ DEBUG > 1 and printf "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 "Treating $para_type paragraph as such because stack is empty.\n";
+ } else {
+ my @fors = grep $_->[0] eq '=for', @$curr_open;
+ DEBUG > 1 and print "Containing fors: ",
+ join(',', map $_->[1]{'target'}, @fors), "\n";
+
+ if(! @fors) {
+ DEBUG and print "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 "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 "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n";
+ }
+ } else {
+ DEBUG and print "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 "\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 "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 "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 "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 " Considering whether =begin $content matches $target_name\n";
+ next unless $self->{'accept_targets'}{$target_name};
+
+ DEBUG > 2 and
+ print " 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 " But the leading ! means that this is a NON-match!\n";
+ } else {
+ $dont_ignore = 1;
+ $para->[1]{'target_matching'} = '!';
+ DEBUG > 2 and print " 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 " Making note to ", $dont_ignore ? 'not ' : '',
+ "ignore contents of this region\n";
+ DEBUG > 1 and $dont_ignore and print " Making note to treat contents as ",
+ ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n";
+ DEBUG > 1 and print " (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 "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 "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 "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 "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 "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 "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 "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' );
+ }
+ DEBUG > 1 and print "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 "Stack is nonempty at end-document: (",
+ $self->_dump_curr_open(), ")\n";
+
+ DEBUG > 9 and print "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 "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 "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 "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 is always ignored.
+ 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. TODO: make this an option?
+ 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 "=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 "=back happily closes matching =over\n";
+ # Expected case: we're closing the most recently opened thing
+ #my $over = pop @$curr_open;
+ $self->{'content_seen'} ||= 1;
+ $self->_handle_element_end( my $scratch =
+ 'over-' . ( (pop @$curr_open)->[1]{'~type'} )
+ );
+ } else {
+ DEBUG > 1 and print "=back found without a matching =over. Stack: (",
+ join(', ', map $_->[0], @$curr_open), ").\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ '=back without =over'
+ );
+ return 1; # and ignore it
+ }
+}
+
+sub _ponder_item {
+ my ($self,$para,$curr_open,$paras) = @_;
+ my $over;
+ unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "'=item' outside of any '=over'"
+ );
+ unshift @$paras,
+ ['=over', {'start_line' => $para->[1]{'start_line'}}, ''],
+ $para
+ ;
+ return 1;
+ }
+
+
+ my $over_type = $over->[1]{'~type'};
+
+ if(!$over_type) {
+ # Shouldn't happen1
+ die "Typeless over in stack, starting at line "
+ . $over->[1]{'start_line'};
+
+ } elsif($over_type eq 'block') {
+ unless($curr_open->[-1][1]{'~bitched_about'}) {
+ $curr_open->[-1][1]{'~bitched_about'} = 1;
+ $self->whine(
+ $curr_open->[-1][1]{'start_line'},
+ "You can't have =items (as at line "
+ . $para->[1]{'start_line'}
+ . ") unless the first thing after the =over is an =item"
+ );
+ }
+ # Just turn it into a paragraph and reconsider it
+ $para->[0] = '~Para';
+ unshift @$paras, $para;
+ return 1;
+
+ } elsif($over_type eq 'text') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ if($item_type eq 'text') {
+ # Nothing special needs doing for 'text'
+ } elsif($item_type eq 'number' or $item_type eq 'bullet') {
+ die "Unknown item type $item_type"
+ unless $item_type eq 'number' or $item_type eq 'bullet';
+ # Undo our clobbering:
+ push @$para, $para->[1]{'~orig_content'};
+ delete $para->[1]{'number'};
+ # Only a PROPER item-number element is allowed
+ # to have a number attribute.
+ } else {
+ die "Unhandled item type $item_type"; # should never happen
+ }
+
+ # =item-text thingies don't need any assimilation, it seems.
+
+ } elsif($over_type eq 'number') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ my $expected_value = ++ $curr_open->[-1][1]{'~counter'};
+
+ if($item_type eq 'bullet') {
+ # Hm, it's not numeric. Correct for this.
+ $para->[1]{'number'} = $expected_value;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item $expected_value'"
+ );
+ push @$para, $para->[1]{'~orig_content'};
+ # restore the bullet, blocking the assimilation of next para
+
+ } elsif($item_type eq 'text') {
+ # Hm, it's not numeric. Correct for this.
+ $para->[1]{'number'} = $expected_value;
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item $expected_value'"
+ );
+ # Text content will still be there and will block next ~Para
+
+ } elsif($item_type ne 'number') {
+ die "Unknown item type $item_type"; # should never happen
+
+ } elsif($expected_value == $para->[1]{'number'}) {
+ DEBUG > 1 and print " Numeric item has the expected value of $expected_value\n";
+
+ } else {
+ DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'},
+ " instead of the expected value of $expected_value\n";
+ $self->whine(
+ $para->[1]{'start_line'},
+ "You have '=item " . $para->[1]{'number'} .
+ "' instead of the expected '=item $expected_value'"
+ );
+ $para->[1]{'number'} = $expected_value; # correcting!!
+ }
+
+ if(@$para == 2) {
+ # For the cases where we /didn't/ push to @$para
+ if($paras->[0][0] eq '~Para') {
+ DEBUG and print "Assimilating following ~Para content into $over_type item\n";
+ push @$para, splice @{shift @$paras},2;
+ } else {
+ DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
+ push @$para, ''; # Just so it's not contentless
+ }
+ }
+
+
+ } elsif($over_type eq 'bullet') {
+ my $item_type = $self->_get_item_type($para);
+ # That kills the content of the item if it's a number or bullet.
+ DEBUG and print " Item is of type ", $para->[0], " under $over_type\n";
+
+ if($item_type eq 'bullet') {
+ # as expected!
+
+ if( $para->[1]{'~_freaky_para_hack'} ) {
+ DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n";
+ push @$para, delete $para->[1]{'~_freaky_para_hack'};
+ }
+
+ } elsif($item_type eq 'number') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item *'"
+ );
+ push @$para, $para->[1]{'~orig_content'};
+ # and block assimilation of the next paragraph
+ delete $para->[1]{'number'};
+ # Only a PROPER item-number element is allowed
+ # to have a number attribute.
+ } elsif($item_type eq 'text') {
+ $self->whine(
+ $para->[1]{'start_line'},
+ "Expected '=item *'"
+ );
+ # But doesn't need processing. But it'll block assimilation
+ # of the next para.
+ } else {
+ die "Unhandled item type $item_type"; # should never happen
+ }
+
+ if(@$para == 2) {
+ # For the cases where we /didn't/ push to @$para
+ if($paras->[0][0] eq '~Para') {
+ DEBUG and print "Assimilating following ~Para content into $over_type item\n";
+ push @$para, splice @{shift @$paras},2;
+ } else {
+ DEBUG and print "Can't assimilate following ", $paras->[0][0], "\n";
+ push @$para, ''; # Just so it's not contentless
+ }
+ }
+
+ } else {
+ die "Unhandled =over type \"$over_type\"?";
+ # Shouldn't happen!
+ }
+ $para->[0] .= '-' . $over_type;
+
+ return;
+}
+
+sub _ponder_Plain {
+ my ($self,$para) = @_;
+ DEBUG and print " giving plain treatment...\n";
+ unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' )
+ or $para->[1]{'~cooked'}
+ ) {
+ push @$para,
+ @{$self->_make_treelet(
+ join("\n", splice(@$para, 2)),
+ $para->[1]{'start_line'}
+ )};
+ }
+ # Empty paragraphs don't need a treelet for any reason I can see.
+ # And precooked paragraphs already have a treelet.
+ return;
+}
+
+sub _ponder_Verbatim {
+ my ($self,$para) = @_;
+ DEBUG and print " giving verbatim treatment...\n";
+
+ $para->[1]{'xml:space'} = 'preserve';
+
+ 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/^\E$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 " giving data treatment...\n";
+ $para->[1]{'xml:space'} = 'preserve';
+ push @$para, join "\n", splice(@$para, 2) if @$para > 3;
+ return;
+}
+
+
+
+
+###########################################################################
+
+sub _traverse_treelet_bit { # for use only by the routine above
+ my($self, $name) = splice @_,0,2;
+
+ my $scratch;
+ $self->_handle_element_start(($scratch=$name), shift @_);
+
+ foreach my $x (@_) {
+ if(ref($x)) {
+ &_traverse_treelet_bit($self, @$x);
+ } else {
+ $self->_handle_text($x);
+ }
+ }
+
+ $self->_handle_element_end($scratch=$name);
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _closers_for_all_curr_open {
+ my $self = $_[0];
+ my @closers;
+ foreach my $still_open (@{ $self->{'curr_open'} || return }) {
+ my @copy = @$still_open;
+ $copy[1] = {%{ $copy[1] }};
+ #$copy[1]{'start_line'} = -1;
+ if($copy[0] eq '=for') {
+ $copy[0] = '=end';
+ } elsif($copy[0] eq '=over') {
+ $copy[0] = '=back';
+ } else {
+ die "I don't know how to auto-close an open $copy[0] region";
+ }
+
+ unless( @copy > 2 ) {
+ push @copy, $copy[1]{'target'};
+ $copy[-1] = '' unless defined $copy[-1];
+ # since =over's don't have targets
+ }
+
+ DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n";
+ unshift @closers, \@copy;
+ }
+ return @closers;
+}
+
+#--------------------------------------------------------------------------
+
+sub _verbatim_format {
+ my($it, $p) = @_;
+
+ my $formatting;
+
+ for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines
+ DEBUG and print "_verbatim_format appends a newline to $i: $p->[$i]\n";
+ $p->[$i] .= "\n";
+ # Unlike with simple Verbatim blocks, we don't end up just doing
+ # a join("\n", ...) on the contents, so we have to append a
+ # newline to ever line, and then nix the last one later.
+ }
+
+ if( DEBUG > 4 ) {
+ print "<<\n";
+ for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines
+ print "_verbatim_format $i: $p->[$i]";
+ }
+ print ">>\n";
+ }
+
+ for(my $i = $#$p; $i > 2; $i--) {
+ # work backwards over the lines, except the first (#2)
+
+ #next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s
+ # and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s;
+ # look at a formatty line preceding a nonformatty one
+ DEBUG > 5 and print "Scrutinizing line $i: $$p[$i]\n";
+ if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) {
+ DEBUG > 5 and print " It's a formatty line. ",
+ "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n";
+
+ if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) {
+ DEBUG > 5 and print " Previous line is formatty! Skipping this one.\n";
+ next;
+ } else {
+ DEBUG > 5 and print " Previous line is non-formatty! Yay!\n";
+ }
+ } else {
+ DEBUG > 5 and print " It's not a formatty line. Ignoring\n";
+ next;
+ }
+
+ # A formatty line has to have #: in the first two columns, and uses
+ # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic.
+ # Example:
+ # What do you want? i like pie. [or whatever]
+ # #:^^^^^^^^^^^^^^^^^ /////////////
+
+
+ DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n";
+
+ $formatting = ' ' . $1;
+ $formatting =~ s/\s+$//s; # nix trailing whitespace
+ unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op
+ splice @$p,$i,1; # remove this line
+ $i--; # don't consider next line
+ next;
+ }
+
+ if( length($formatting) >= length($p->[$i-1]) ) {
+ $formatting = substr($formatting, 0, length($p->[$i-1]) - 1) . ' ';
+ } else {
+ $formatting .= ' ' x (length($p->[$i-1]) - length($formatting));
+ }
+ # Make $formatting and the previous line be exactly the same length,
+ # with $formatting having a " " as the last character.
+
+ DEBUG > 4 and print "Formatting <$formatting> on <", $p->[$i-1], ">\n";
+
+
+ my @new_line;
+ while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) {
+ #print "Format matches $1\n";
+
+ if($2) {
+ #print "SKIPPING <$2>\n";
+ push @new_line,
+ substr($p->[$i-1], pos($formatting)-length($1), length($1));
+ } else {
+ #print "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 "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 "Nixed count: ", scalar(@nixed), "\n";
+
+ DEBUG > 6 and print "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 "_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 "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n";
+ } else {
+ DEBUG > 5 and print
+ "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);
+
+ DEBUG > 4 and print "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 "\nParagraphic tokenstack = (@stack)\n";
+ if(defined $1) {
+ if(defined $2) {
+ DEBUG > 3 and print "Found complex start-text code \"$1\"\n";
+ # signal that we're looking for simple unless we're in complex.
+ if ($stack[-1]) {
+ # We're in complex already. It's just stuff.
+ DEBUG > 4 and print " It's just stuff.\n";
+ push @{ $lineage[-1] }, $1;
+ } else {
+ # length of the necessary complex end-code string
+ push @stack, length($2) + 1;
+ push @lineage, [ substr($1,0,1), {}, ]; # new node object
+ push @{ $lineage[-2] }, $lineage[-1];
+ }
+ } else {
+ DEBUG > 3 and print "Found simple start-text code \"$1\"\n";
+ if ($stack[-1]) {
+ # We're in complex already. It's just stuff.
+ DEBUG > 4 and print " It's just stuff.\n";
+ push @{ $lineage[-1] }, $1;
+ } else {
+ # signal that we're looking for simple.
+ push @stack, 0;
+ push @lineage, [ substr($1,0,1), {}, ]; # new node object
+ push @{ $lineage[-2] }, $lineage[-1];
+ }
+ }
+ } elsif(defined $4) {
+ DEBUG > 3 and print "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 " 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 " 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 " 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 " 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 " But it's really just stuff, because we needed more.\n";
+ push @{ $lineage[-1] }, $3, $4;
+ next;
+ }
+ #print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n";
+
+ push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] };
+ # Keep the element from being childless
+
+ pop @stack;
+ pop @lineage;
+
+ } elsif(defined $5) {
+ DEBUG > 3 and print "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 " 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 " It's just stuff.\n";
+ push @{ $lineage[-1] }, $5;
+ }
+
+ } elsif(defined $6) {
+ DEBUG > 3 and print "Found stuff \"$6\"\n";
+ push @{ $lineage[-1] }, $6;
+
+ } else {
+ # should never ever ever ever happen
+ DEBUG and print "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 "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) = @_;
+ use UNIVERSAL ();
+ 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 that RE lets thru
+ )
+ ) { $_;
+ } else {
+ if( chr(65) eq 'A' ) {
+ s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
+ #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
+ <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg;
+ } else {
+ # We're in some crazy non-ASCII world!
+ s<([^abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])>
+ #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg;
+ <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($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 compatibilty 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 errata errors_seen
+Title)) {
+
+ delete $self->{$_};
+ }
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm
new file mode 100755
index 00000000000..136e851bafe
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm
@@ -0,0 +1,196 @@
+
+# A quite dimwitted pod2plaintext that need only know how to format whatever
+# text comes out of Pod::BlackBox's _gen_errata
+
+require 5;
+package Pod::Simple::Checker;
+use strict;
+use Carp ();
+use Pod::Simple::Methody ();
+use Pod::Simple ();
+use vars qw( @ISA $VERSION );
+$VERSION = '3.13';
+@ISA = ('Pod::Simple::Methody');
+BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
+ ? \&Pod::Simple::DEBUG
+ : sub() {0}
+ }
+
+use Text::Wrap 98.112902 (); # was 2001.0131, but I don't think we need that
+$Text::Wrap::wrap = 'overflow';
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub any_errata_seen { # read-only accessor
+ return $_[1]->{'Errata_seen'};
+}
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->nix_X_codes(1);
+ $new->nbsp_for_S(1);
+ $new->{'Thispara'} = '';
+ $new->{'Indent'} = 0;
+ $new->{'Indentstring'} = ' ';
+ $new->{'Errata_seen'} = 0;
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub handle_text { $_[0]{'Errata_seen'} and $_[0]{'Thispara'} .= $_[1] }
+
+sub start_Para { $_[0]{'Thispara'} = '' }
+
+sub start_head1 {
+ if($_[0]{'Errata_seen'}) {
+ $_[0]{'Thispara'} = '';
+ } else {
+ if($_[1]{'errata'}) { # start of errata!
+ $_[0]{'Errata_seen'} = 1;
+ $_[0]{'Thispara'} = $_[0]{'source_filename'} ?
+ "$_[0]{'source_filename'} -- " : ''
+ }
+ }
+}
+sub start_head2 { $_[0]{'Thispara'} = '' }
+sub start_head3 { $_[0]{'Thispara'} = '' }
+sub start_head4 { $_[0]{'Thispara'} = '' }
+
+sub start_Verbatim { $_[0]{'Thispara'} = '' }
+sub start_item_bullet { $_[0]{'Thispara'} = '* ' }
+sub start_item_number { $_[0]{'Thispara'} = "$_[1]{'number'}. " }
+sub start_item_text { $_[0]{'Thispara'} = '' }
+
+sub start_over_bullet { ++$_[0]{'Indent'} }
+sub start_over_number { ++$_[0]{'Indent'} }
+sub start_over_text { ++$_[0]{'Indent'} }
+sub start_over_block { ++$_[0]{'Indent'} }
+
+sub end_over_bullet { --$_[0]{'Indent'} }
+sub end_over_number { --$_[0]{'Indent'} }
+sub end_over_text { --$_[0]{'Indent'} }
+sub end_over_block { --$_[0]{'Indent'} }
+
+
+# . . . . . Now the actual formatters:
+
+sub end_head1 { $_[0]->emit_par(-4) }
+sub end_head2 { $_[0]->emit_par(-3) }
+sub end_head3 { $_[0]->emit_par(-2) }
+sub end_head4 { $_[0]->emit_par(-1) }
+sub end_Para { $_[0]->emit_par( 0) }
+sub end_item_bullet { $_[0]->emit_par( 0) }
+sub end_item_number { $_[0]->emit_par( 0) }
+sub end_item_text { $_[0]->emit_par(-2) }
+
+sub emit_par {
+ return unless $_[0]{'Errata_seen'};
+ my($self, $tweak_indent) = splice(@_,0,2);
+ my $indent = ' ' x ( 2 * $self->{'Indent'} + ($tweak_indent||0) );
+ # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
+
+ $self->{'Thispara'} =~ tr{\xAD}{}d if Pod::Simple::ASCII;
+ my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
+ $out =~ tr{\xA0}{ } if Pod::Simple::ASCII;
+ print {$self->{'output_fh'}} $out,
+ #"\n"
+ ;
+ $self->{'Thispara'} = '';
+
+ return;
+}
+
+# . . . . . . . . . . And then off by its lonesome:
+
+sub end_Verbatim {
+ return unless $_[0]{'Errata_seen'};
+ my $self = shift;
+ if(Pod::Simple::ASCII) {
+ $self->{'Thispara'} =~ tr{\xA0}{ };
+ $self->{'Thispara'} =~ tr{\xAD}{}d;
+ }
+
+ my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
+
+ $self->{'Thispara'} =~ s/^/$i/mg;
+
+ print { $self->{'output_fh'} } '',
+ $self->{'Thispara'},
+ "\n\n"
+ ;
+ $self->{'Thispara'} = '';
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::Checker -- check the Pod syntax of a document
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::Checker -e \
+ "exit Pod::Simple::Checker->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+This class is for checking the syntactic validity of Pod.
+It works by basically acting like a simple-minded version of
+L<Pod::Simple::Text> that formats only the "Pod Errors" section
+(if Pod::Simple even generates one for the given document).
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Checker>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm
new file mode 100755
index 00000000000..c2332fa73be
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm
@@ -0,0 +1,178 @@
+
+require 5;
+package Pod::Simple::Debug;
+use strict;
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+sub import {
+ my($value,$variable);
+
+ if(@_ == 2) {
+ $value = $_[1];
+ } elsif(@_ == 3) {
+ ($variable, $value) = @_[1,2];
+
+ ($variable, $value) = ($value, $variable)
+ if defined $value and ref($value) eq 'SCALAR'
+ and not(defined $variable and ref($variable) eq 'SCALAR')
+ ; # tolerate getting it backwards
+
+ unless( defined $variable and ref($variable) eq 'SCALAR') {
+ require Carp;
+ Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
+ . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
+ }
+ } else {
+ require Carp;
+ Carp::croak("Usage:\n use Pod::Simple::Debug (NUMVAL)\nor"
+ . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
+ }
+
+ if( defined &Pod::Simple::DEBUG ) {
+ require Carp;
+ Carp::croak("It's too late to call Pod::Simple::Debug -- "
+ . "Pod::Simple has already loaded\nAborting");
+ }
+
+ $value = 0 unless defined $value;
+
+ unless($value =~ m/^-?\d+$/) {
+ require Carp;
+ Carp::croak( "$value isn't a numeric value."
+ . "\nUsage:\n use Pod::Simple::Debug (NUMVAL)\nor"
+ . "\n use Pod::Simple::Debug (\\\$var, STARTNUMVAL)\nAborting");
+ }
+
+ if( defined $variable ) {
+ # make a not-really-constant
+ *Pod::Simple::DEBUG = sub () { $$variable } ;
+ $$variable = $value;
+ print "# Starting Pod::Simple::DEBUG = non-constant $variable with val $value\n";
+ } else {
+ *Pod::Simple::DEBUG = eval " sub () { $value } ";
+ print "# Starting Pod::Simple::DEBUG = $value\n";
+ }
+
+ require Pod::Simple;
+ return;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::Debug -- put Pod::Simple into trace/debug mode
+
+=head1 SYNOPSIS
+
+ use Pod::Simple::Debug (5); # or some integer
+
+Or:
+
+ my $debuglevel;
+ use Pod::Simple::Debug (\$debuglevel, 0);
+ ...some stuff that uses Pod::Simple to do stuff, but which
+ you don't want debug output from...
+
+ $debug_level = 4;
+ ...some stuff that uses Pod::Simple to do stuff, but which
+ you DO want debug output from...
+
+ $debug_level = 0;
+
+=head1 DESCRIPTION
+
+This is an internal module for controlling the debug level (a.k.a. trace
+level) of Pod::Simple. This is of interest only to Pod::Simple
+developers.
+
+
+=head1 CAVEATS
+
+Note that you should load this module I<before> loading Pod::Simple (or
+any Pod::Simple-based class). If you try loading Pod::Simple::Debug
+after &Pod::Simple::DEBUG is already defined, Pod::Simple::Debug will
+throw a fatal error to the effect that
+"it's s too late to call Pod::Simple::Debug".
+
+Note that the C<use Pod::Simple::Debug (\$x, I<somenum>)> mode will make
+Pod::Simple (et al) run rather slower, since &Pod::Simple::DEBUG won't
+be a constant sub anymore, and so Pod::Simple (et al) won't compile with
+constant-folding.
+
+
+=head1 GUTS
+
+Doing this:
+
+ use Pod::Simple::Debug (5); # or some integer
+
+is basically equivalent to:
+
+ BEGIN { sub Pod::Simple::DEBUG () {5} } # or some integer
+ use Pod::Simple ();
+
+And this:
+
+ use Pod::Simple::Debug (\$debug_level,0); # or some integer
+
+is basically equivalent to this:
+
+ my $debug_level;
+ BEGIN { $debug_level = 0 }
+ BEGIN { sub Pod::Simple::DEBUG () { $debug_level }
+ use Pod::Simple ();
+
+=head1 SEE ALSO
+
+L<Pod::Simple>
+
+The article "Constants in Perl", in I<The Perl Journal> issue
+21. See L<http://interglacial.com/tpj/21/>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm
new file mode 100755
index 00000000000..0f756463666
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm
@@ -0,0 +1,155 @@
+
+require 5;
+package Pod::Simple::DumpAsText;
+$VERSION = '3.13';
+use Pod::Simple ();
+BEGIN {@ISA = ('Pod::Simple')}
+
+use strict;
+
+use Carp ();
+
+BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->accept_codes('VerbatimFormatted');
+ return $new;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _handle_element_start {
+ # ($self, $element_name, $attr_hash_r)
+ my $fh = $_[0]{'output_fh'};
+ my($key, $value);
+ DEBUG and print "++ $_[1]\n";
+
+ print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n";
+ $_[0]{'indent'}++;
+ while(($key,$value) = each %{$_[2]}) {
+ unless($key =~ m/^~/s) {
+ next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
+ _perly_escape($key);
+ _perly_escape($value);
+ printf $fh qq{%s \\ "%s" => "%s"\n},
+ ' ' x ($_[0]{'indent'} || 0), $key, $value;
+ }
+ }
+ return;
+}
+
+sub _handle_text {
+ DEBUG and print "== \"$_[1]\"\n";
+
+ if(length $_[1]) {
+ my $indent = ' ' x $_[0]{'indent'};
+ my $text = $_[1];
+ _perly_escape($text);
+ $text =~ # A not-totally-brilliant wrapping algorithm:
+ s/(
+ [^\n]{55} # Snare some characters from a line
+ [^\n\ ]{0,50} # and finish any current word
+ )
+ \x20{1,10}(?!\n) # capture some spaces not at line-end
+ /$1"\n$indent . "/gx # => line-break here
+ ;
+
+ print {$_[0]{'output_fh'}} $indent, '* "', $text, "\"\n";
+ }
+ return;
+}
+
+sub _handle_element_end {
+ DEBUG and print "-- $_[1]\n";
+ print {$_[0]{'output_fh'}}
+ ' ' x --$_[0]{'indent'}, "--", $_[1], "\n";
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _perly_escape {
+ foreach my $x (@_) {
+ $x =~ s/([^\x00-\xFF])/sprintf'\x{%X}',ord($1)/eg;
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t \&\<\>\'!\#\%\(\)\*\+,\.\/\:\;=\?\~\[\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf'\x%02X',ord($1)/eg;
+ }
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::DumpAsText -- dump Pod-parsing events as text
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::DumpAsText -e \
+ "exit Pod::Simple::DumpAsText->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+This class is for dumping, as text, the events gotten from parsing a Pod
+document. This class is of interest to people writing Pod formatters
+based on Pod::Simple. It is useful for seeing exactly what events you
+get out of some Pod that you feed in.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 SEE ALSO
+
+L<Pod::Simple::DumpAsXML>
+
+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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm
new file mode 100755
index 00000000000..9e4b77ffbd8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm
@@ -0,0 +1,170 @@
+
+require 5;
+package Pod::Simple::DumpAsXML;
+$VERSION = '3.13';
+use Pod::Simple ();
+BEGIN {@ISA = ('Pod::Simple')}
+
+use strict;
+
+use Carp ();
+
+BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->accept_codes('VerbatimFormatted');
+ return $new;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _handle_element_start {
+ # ($self, $element_name, $attr_hash_r)
+ my $fh = $_[0]{'output_fh'};
+ my($key, $value);
+ DEBUG and print "++ $_[1]\n";
+
+ print $fh ' ' x ($_[0]{'indent'} || 0), "<", $_[1];
+
+ foreach my $key (sort keys %{$_[2]}) {
+ unless($key =~ m/^~/s) {
+ next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
+ _xml_escape($value = $_[2]{$key});
+ print $fh ' ', $key, '="', $value, '"';
+ }
+ }
+
+
+ print $fh ">\n";
+ $_[0]{'indent'}++;
+ return;
+}
+
+sub _handle_text {
+ DEBUG and print "== \"$_[1]\"\n";
+ if(length $_[1]) {
+ my $indent = ' ' x $_[0]{'indent'};
+ my $text = $_[1];
+ _xml_escape($text);
+ $text =~ # A not-totally-brilliant wrapping algorithm:
+ s/(
+ [^\n]{55} # Snare some characters from a line
+ [^\n\ ]{0,50} # and finish any current word
+ )
+ \x20{1,10}(?!\n) # capture some spaces not at line-end
+ /$1\n$indent/gx # => line-break here
+ ;
+
+ print {$_[0]{'output_fh'}} $indent, $text, "\n";
+ }
+ return;
+}
+
+sub _handle_element_end {
+ DEBUG and print "-- $_[1]\n";
+ print {$_[0]{'output_fh'}}
+ ' ' x --$_[0]{'indent'}, "</", $_[1], ">\n";
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub _xml_escape {
+ foreach my $x (@_) {
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done about that.
+ }
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::DumpAsXML -- turn Pod into XML
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::DumpAsXML -e \
+ "exit Pod::Simple::DumpAsXML->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+Pod::Simple::DumpAsXML is a subclass of L<Pod::Simple> that parses Pod
+and turns it into indented and wrapped XML. This class is of
+interest to people writing Pod formatters based on Pod::Simple.
+
+Pod::Simple::DumpAsXML inherits methods from
+L<Pod::Simple>.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple::XMLOutStream> is rather like this class.
+Pod::Simple::XMLOutStream's output is space-padded in a way
+that's better for sending to an XML processor (that is, it has
+no ignoreable whitespace). But
+Pod::Simple::DumpAsXML's output is much more human-readable, being
+(more-or-less) one token per line, with line-wrapping.
+
+L<Pod::Simple::DumpAsText> is rather like this class,
+except that it doesn't dump with XML syntax. Try them and see
+which one you like best!
+
+L<Pod::Simple>, L<Pod::Simple::DumpAsXML>
+
+The older libraries L<Pod::PXML>, L<Pod::XML>, L<Pod::SAX>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
new file mode 100755
index 00000000000..663a5e438c6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
@@ -0,0 +1,979 @@
+
+require 5;
+package Pod::Simple::HTML;
+use strict;
+use Pod::Simple::PullParser ();
+use vars qw(
+ @ISA %Tagmap $Computerese $LamePad $Linearization_Limit $VERSION
+ $Perldoc_URL_Prefix $Perldoc_URL_Postfix $Man_URL_Prefix $Man_URL_Postfix
+ $Title_Prefix $Title_Postfix $HTML_EXTENSION %ToIndex
+ $Doctype_decl $Content_decl
+);
+@ISA = ('Pod::Simple::PullParser');
+$VERSION = '3.13';
+
+use UNIVERSAL ();
+BEGIN {
+ if(defined &DEBUG) { } # no-op
+ elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
+ else { *DEBUG = sub () {0}; }
+}
+
+$Doctype_decl ||= ''; # No. Just No. Don't even ask me for it.
+ # qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
+ # "http://www.w3.org/TR/html4/loose.dtd">\n};
+
+$Content_decl ||=
+ q{<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" >};
+
+$HTML_EXTENSION = '.html' unless defined $HTML_EXTENSION;
+$Computerese = "" unless defined $Computerese;
+$LamePad = '' unless defined $LamePad;
+
+$Linearization_Limit = 120 unless defined $Linearization_Limit;
+ # headings/items longer than that won't get an <a name="...">
+$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?'
+ unless defined $Perldoc_URL_Prefix;
+$Perldoc_URL_Postfix = ''
+ unless defined $Perldoc_URL_Postfix;
+
+
+$Man_URL_Prefix = 'http://man.he.net/man';
+$Man_URL_Postfix = '';
+
+$Title_Prefix = '' unless defined $Title_Prefix;
+$Title_Postfix = '' unless defined $Title_Postfix;
+%ToIndex = map {; $_ => 1 } qw(head1 head2 head3 head4 ); # item-text
+ # 'item-text' stuff in the index doesn't quite work, and may
+ # not be a good idea anyhow.
+
+
+__PACKAGE__->_accessorize(
+ 'perldoc_url_prefix',
+ # In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
+ # to put before the "Foo%3a%3aBar".
+ # (for singleton mode only?)
+ 'perldoc_url_postfix',
+ # what to put after "Foo%3a%3aBar" in the URL. Normally "".
+
+ 'man_url_prefix',
+ # In turning L<crontab(5)> into http://whatever/man/1/crontab, what
+ # to put before the "1/crontab".
+ 'man_url_postfix',
+ # what to put after the "1/crontab" in the URL. Normally "".
+
+ 'batch_mode', # whether we're in batch mode
+ 'batch_mode_current_level',
+ # When in batch mode, how deep the current module is: 1 for "LWP",
+ # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
+
+ 'title_prefix', 'title_postfix',
+ # What to put before and after the title in the head.
+ # Should already be &-escaped
+
+ 'html_h_level',
+
+ 'html_header_before_title',
+ 'html_header_after_title',
+ 'html_footer',
+
+ 'index', # whether to add an index at the top of each page
+ # (actually it's a table-of-contents, but we'll call it an index,
+ # out of apparently longstanding habit)
+
+ 'html_css', # URL of CSS file to point to
+ 'html_javascript', # URL of CSS file to point to
+
+ 'force_title', # should already be &-escaped
+ 'default_title', # should already be &-escaped
+);
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+my @_to_accept;
+
+%Tagmap = (
+ 'Verbatim' => "\n<pre$Computerese>",
+ '/Verbatim' => "</pre>\n",
+ 'VerbatimFormatted' => "\n<pre$Computerese>",
+ '/VerbatimFormatted' => "</pre>\n",
+ 'VerbatimB' => "<b>",
+ '/VerbatimB' => "</b>",
+ 'VerbatimI' => "<i>",
+ '/VerbatimI' => "</i>",
+ 'VerbatimBI' => "<b><i>",
+ '/VerbatimBI' => "</i></b>",
+
+
+ 'Data' => "\n",
+ '/Data' => "\n",
+
+ 'head1' => "\n<h1>", # And also stick in an <a name="...">
+ 'head2' => "\n<h2>", # ''
+ 'head3' => "\n<h3>", # ''
+ 'head4' => "\n<h4>", # ''
+ '/head1' => "</a></h1>\n",
+ '/head2' => "</a></h2>\n",
+ '/head3' => "</a></h3>\n",
+ '/head4' => "</a></h4>\n",
+
+ 'X' => "<!--\n\tINDEX: ",
+ '/X' => "\n-->",
+
+ changes(qw(
+ Para=p
+ B=b I=i
+ over-bullet=ul
+ over-number=ol
+ over-text=dl
+ over-block=blockquote
+ item-bullet=li
+ item-number=li
+ item-text=dt
+ )),
+ changes2(
+ map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
+ qw[
+ sample=samp
+ definition=dfn
+ kbd=keyboard
+ variable=var
+ citation=cite
+ abbreviation=abbr
+ acronym=acronym
+ subscript=sub
+ superscript=sup
+ big=big
+ small=small
+ underline=u
+ strikethrough=s
+ ] # no point in providing a way to get <q>...</q>, I think
+ ),
+
+ '/item-bullet' => "</li>$LamePad\n",
+ '/item-number' => "</li>$LamePad\n",
+ '/item-text' => "</a></dt>$LamePad\n",
+ 'item-body' => "\n<dd>",
+ '/item-body' => "</dd>\n",
+
+
+ 'B' => "<b>", '/B' => "</b>",
+ 'I' => "<i>", '/I' => "</i>",
+ 'F' => "<em$Computerese>", '/F' => "</em>",
+ 'C' => "<code$Computerese>", '/C' => "</code>",
+ 'L' => "<a href='YOU_SHOULD_NEVER_SEE_THIS'>", # ideally never used!
+ '/L' => "</a>",
+);
+
+sub changes {
+ return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
+ ? ( $1, => "\n<$2>", "/$1", => "</$2>\n" ) : die "Funky $_"
+ } @_;
+}
+sub changes2 {
+ return map {; m/^([-_:0-9a-zA-Z]+)=([-_:0-9a-zA-Z]+)$/s
+ ? ( $1, => "<$2>", "/$1", => "</$2>" ) : die "Funky $_"
+ } @_;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub go { Pod::Simple::HTML->parse_from_file(@ARGV); exit 0 }
+ # Just so we can run from the command line. No options.
+ # For that, use perldoc!
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub new {
+ my $new = shift->SUPER::new(@_);
+ #$new->nix_X_codes(1);
+ $new->nbsp_for_S(1);
+ $new->accept_targets( 'html', 'HTML' );
+ $new->accept_codes('VerbatimFormatted');
+ $new->accept_codes(@_to_accept);
+ DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
+
+ $new->perldoc_url_prefix( $Perldoc_URL_Prefix );
+ $new->perldoc_url_postfix( $Perldoc_URL_Postfix );
+ $new->man_url_prefix( $Man_URL_Prefix );
+ $new->man_url_postfix( $Man_URL_Postfix );
+ $new->title_prefix( $Title_Prefix );
+ $new->title_postfix( $Title_Postfix );
+
+ $new->html_header_before_title(
+ qq[$Doctype_decl<html><head><title>]
+ );
+ $new->html_header_after_title( join "\n" =>
+ "</title>",
+ $Content_decl,
+ "</head>\n<body class='pod'>",
+ $new->version_tag_comment,
+ "<!-- start doc -->\n",
+ );
+ $new->html_footer( qq[\n<!-- end doc -->\n\n</body></html>\n] );
+
+ $new->{'Tagmap'} = {%Tagmap};
+
+ return $new;
+}
+
+sub __adjust_html_h_levels {
+ my ($self) = @_;
+ my $Tagmap = $self->{'Tagmap'};
+
+ my $add = $self->html_h_level;
+ return unless defined $add;
+ return if ($self->{'Adjusted_html_h_levels'}||0) == $add;
+
+ $add -= 1;
+ for (1 .. 4) {
+ $Tagmap->{"head$_"} =~ s/$_/$_ + $add/e;
+ $Tagmap->{"/head$_"} =~ s/$_/$_ + $add/e;
+ }
+}
+
+sub batch_mode_page_object_init {
+ my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
+ DEBUG and print "Initting $self\n for $module\n",
+ " in $infile\n out $outfile\n depth $depth\n";
+ $self->batch_mode(1);
+ $self->batch_mode_current_level($depth);
+ return $self;
+}
+
+sub run {
+ my $self = $_[0];
+ return $self->do_middle if $self->bare_output;
+ return
+ $self->do_beginning && $self->do_middle && $self->do_end;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub do_beginning {
+ my $self = $_[0];
+
+ my $title;
+
+ if(defined $self->force_title) {
+ $title = $self->force_title;
+ DEBUG and print "Forcing title to be $title\n";
+ } else {
+ # Actually try looking for the title in the document:
+ $title = $self->get_short_title();
+ unless($self->content_seen) {
+ DEBUG and print "No content seen in search for title.\n";
+ return;
+ }
+ $self->{'Title'} = $title;
+
+ if(defined $title and $title =~ m/\S/) {
+ $title = $self->title_prefix . esc($title) . $self->title_postfix;
+ } else {
+ $title = $self->default_title;
+ $title = '' unless defined $title;
+ DEBUG and print "Title defaults to $title\n";
+ }
+ }
+
+
+ my $after = $self->html_header_after_title || '';
+ if($self->html_css) {
+ my $link =
+ $self->html_css =~ m/</
+ ? $self->html_css # It's a big blob of markup, let's drop it in
+ : sprintf( # It's just a URL, so let's wrap it up
+ qq[<link rel="stylesheet" type="text/css" title="pod_stylesheet" href="%s">\n],
+ $self->html_css,
+ );
+ $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
+ }
+ $self->_add_top_anchor(\$after);
+
+ if($self->html_javascript) {
+ my $link =
+ $self->html_javascript =~ m/</
+ ? $self->html_javascript # It's a big blob of markup, let's drop it in
+ : sprintf( # It's just a URL, so let's wrap it up
+ qq[<script type="text/javascript" src="%s"></script>\n],
+ $self->html_javascript,
+ );
+ $after =~ s{(</head>)}{$link\n$1}i; # otherwise nevermind
+ }
+
+ print {$self->{'output_fh'}}
+ $self->html_header_before_title || '',
+ $title, # already escaped
+ $after,
+ ;
+
+ DEBUG and print "Returning from do_beginning...\n";
+ return 1;
+}
+
+sub _add_top_anchor {
+ my($self, $text_r) = @_;
+ unless($$text_r and $$text_r =~ m/name=['"]___top['"]/) { # a hack
+ $$text_r .= "<a name='___top' class='dummyTopAnchor' ></a>\n";
+ }
+ return;
+}
+
+sub version_tag_comment {
+ my $self = shift;
+ return sprintf
+ "<!--\n generated by %s v%s,\n using %s v%s,\n under Perl v%s at %s GMT.\n\n %s\n\n-->\n",
+ esc(
+ ref($self), $self->VERSION(), $ISA[0], $ISA[0]->VERSION(),
+ $], scalar(gmtime),
+ ), $self->_modnote(),
+ ;
+}
+
+sub _modnote {
+ my $class = ref($_[0]) || $_[0];
+ return join "\n " => grep m/\S/, split "\n",
+
+qq{
+If you want to change this HTML document, you probably shouldn't do that
+by changing it directly. Instead, see about changing the calling options
+to $class, and/or subclassing $class,
+then reconverting this document from the Pod source.
+When in doubt, email the author of $class for advice.
+See 'perldoc $class' for more info.
+};
+
+}
+
+sub do_end {
+ my $self = $_[0];
+ print {$self->{'output_fh'}} $self->html_footer || '';
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Normally this would just be a call to _do_middle_main_loop -- but we
+# have to do some elaborate things to emit all the content and then
+# summarize it and output it /before/ the content that it's a summary of.
+
+sub do_middle {
+ my $self = $_[0];
+ return $self->_do_middle_main_loop unless $self->index;
+
+ if( $self->output_string ) {
+ # An efficiency hack
+ my $out = $self->output_string; #it's a reference to it
+ my $sneakytag = "\f\f\e\e\b\bIndex Here\e\e\b\b\f\f\n";
+ $$out .= $sneakytag;
+ $self->_do_middle_main_loop;
+ $sneakytag = quotemeta($sneakytag);
+ my $index = $self->index_as_html();
+ if( $$out =~ s/$sneakytag/$index/s ) {
+ # Expected case
+ DEBUG and print "Inserted ", length($index), " bytes of index HTML into $out.\n";
+ } else {
+ DEBUG and print "Odd, couldn't find where to insert the index in the output!\n";
+ # I don't think this should ever happen.
+ }
+ return 1;
+ }
+
+ unless( $self->output_fh ) {
+ require Carp;
+ Carp::confess("Parser object \$p doesn't seem to have any output object! I don't know how to deal with that.");
+ }
+
+ # If we get here, we're outputting to a FH. So we need to do some magic.
+ # Namely, divert all content to a string, which we output after the index.
+ my $fh = $self->output_fh;
+ my $content = '';
+ {
+ # Our horrible bait and switch:
+ $self->output_string( \$content );
+ $self->_do_middle_main_loop;
+ $self->abandon_output_string();
+ $self->output_fh($fh);
+ }
+ print $fh $self->index_as_html();
+ print $fh $content;
+
+ return 1;
+}
+
+###########################################################################
+
+sub index_as_html {
+ my $self = $_[0];
+ # This is meant to be called AFTER the input document has been parsed!
+
+ my $points = $self->{'PSHTML_index_points'} || [];
+
+ @$points > 1 or return qq[<div class='indexgroupEmpty'></div>\n];
+ # There's no point in having a 0-item or 1-item index, I dare say.
+
+ my(@out) = qq{\n<div class='indexgroup'>};
+ my $level = 0;
+
+ my( $target_level, $previous_tagname, $tagname, $text, $anchorname, $indent);
+ foreach my $p (@$points, ['head0', '(end)']) {
+ ($tagname, $text) = @$p;
+ $anchorname = $self->section_escape($text);
+ if( $tagname =~ m{^head(\d+)$} ) {
+ $target_level = 0 + $1;
+ } else { # must be some kinda list item
+ if($previous_tagname =~ m{^head\d+$} ) {
+ $target_level = $level + 1;
+ } else {
+ $target_level = $level; # no change needed
+ }
+ }
+
+ # Get to target_level by opening or closing ULs
+ while($level > $target_level)
+ { --$level; push @out, (" " x $level) . "</ul>"; }
+ while($level < $target_level)
+ { ++$level; push @out, (" " x ($level-1))
+ . "<ul class='indexList indexList$level'>"; }
+
+ $previous_tagname = $tagname;
+ next unless $level;
+
+ $indent = ' ' x $level;
+ push @out, sprintf
+ "%s<li class='indexItem indexItem%s'><a href='#%s'>%s</a>",
+ $indent, $level, esc($anchorname), esc($text)
+ ;
+ }
+ push @out, "</div>\n";
+ return join "\n", @out;
+}
+
+###########################################################################
+
+sub _do_middle_main_loop {
+ my $self = $_[0];
+ my $fh = $self->{'output_fh'};
+ my $tagmap = $self->{'Tagmap'};
+
+ $self->__adjust_html_h_levels;
+
+ my($token, $type, $tagname, $linkto, $linktype);
+ my @stack;
+ my $dont_wrap = 0;
+
+ while($token = $self->get_token) {
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ if( ($type = $token->type) eq 'start' ) {
+ if(($tagname = $token->tagname) eq 'L') {
+ $linktype = $token->attr('type') || 'insane';
+
+ $linkto = $self->do_link($token);
+
+ if(defined $linkto and length $linkto) {
+ esc($linkto);
+ # (Yes, SGML-escaping applies on top of %-escaping!
+ # But it's rarely noticeable in practice.)
+ print $fh qq{<a href="$linkto" class="podlink$linktype"\n>};
+ } else {
+ print $fh "<a>"; # Yes, an 'a' element with no attributes!
+ }
+
+ } elsif ($tagname eq 'item-text' or $tagname =~ m/^head\d$/s) {
+ print $fh $tagmap->{$tagname} || next;
+
+ my @to_unget;
+ while(1) {
+ push @to_unget, $self->get_token;
+ last if $to_unget[-1]->is_end
+ and $to_unget[-1]->tagname eq $tagname;
+
+ # TODO: support for X<...>'s found in here? (maybe hack into linearize_tokens)
+ }
+
+ my $name = $self->linearize_tokens(@to_unget);
+ $name = $self->do_section($name, $token) if defined $name;
+
+ print $fh "<a ";
+ print $fh "class='u' href='#___top' title='click to go to top of document'\n"
+ if $tagname =~ m/^head\d$/s;
+
+ if(defined $name) {
+ my $esc = esc( $self->section_name_tidy( $name ) );
+ print $fh qq[name="$esc"];
+ DEBUG and print "Linearized ", scalar(@to_unget),
+ " tokens as \"$name\".\n";
+ push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name]
+ if $ToIndex{ $tagname };
+ # Obviously, this discards all formatting codes (saving
+ # just their content), but ahwell.
+
+ } else { # ludicrously long, so nevermind
+ DEBUG and print "Linearized ", scalar(@to_unget),
+ " tokens, but it was too long, so nevermind.\n";
+ }
+ print $fh "\n>";
+ $self->unget_token(@to_unget);
+
+ } elsif ($tagname eq 'Data') {
+ my $next = $self->get_token;
+ next unless defined $next;
+ unless( $next->type eq 'text' ) {
+ $self->unget_token($next);
+ next;
+ }
+ DEBUG and print " raw text ", $next->text, "\n";
+ print $fh "\n" . $next->text . "\n";
+ next;
+
+ } else {
+ if( $tagname =~ m/^over-/s ) {
+ push @stack, '';
+ } elsif( $tagname =~ m/^item-/s and @stack and $stack[-1] ) {
+ print $fh $stack[-1];
+ $stack[-1] = '';
+ }
+ print $fh $tagmap->{$tagname} || next;
+ ++$dont_wrap if $tagname eq 'Verbatim' or $tagname eq "VerbatimFormatted"
+ or $tagname eq 'X';
+ }
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ } elsif( $type eq 'end' ) {
+ if( ($tagname = $token->tagname) =~ m/^over-/s ) {
+ if( my $end = pop @stack ) {
+ print $fh $end;
+ }
+ } elsif( $tagname =~ m/^item-/s and @stack) {
+ $stack[-1] = $tagmap->{"/$tagname"};
+ if( $tagname eq 'item-text' and defined(my $next = $self->get_token) ) {
+ $self->unget_token($next);
+ if( $next->type eq 'start' ) {
+ print $fh $tagmap->{"/item-text"},$tagmap->{"item-body"};
+ $stack[-1] = $tagmap->{"/item-body"};
+ }
+ }
+ next;
+ }
+ print $fh $tagmap->{"/$tagname"} || next;
+ --$dont_wrap if $tagname eq 'Verbatim' or $tagname eq 'X';
+
+ # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+ } elsif( $type eq 'text' ) {
+ esc($type = $token->text); # reuse $type, why not
+ $type =~ s/([\?\!\"\'\.\,]) /$1\n/g unless $dont_wrap;
+ print $fh $type;
+ }
+
+ }
+ return 1;
+}
+
+###########################################################################
+#
+
+sub do_section {
+ my($self, $name, $token) = @_;
+ return $name;
+}
+
+sub do_link {
+ my($self, $token) = @_;
+ my $type = $token->attr('type');
+ if(!defined $type) {
+ $self->whine("Typeless L!?", $token->attr('start_line'));
+ } elsif( $type eq 'pod') { return $self->do_pod_link($token);
+ } elsif( $type eq 'url') { return $self->do_url_link($token);
+ } elsif( $type eq 'man') { return $self->do_man_link($token);
+ } else {
+ $self->whine("L of unknown type $type!?", $token->attr('start_line'));
+ }
+ return 'FNORG'; # should never get called
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub do_url_link { return $_[1]->attr('to') }
+
+sub do_man_link {
+ my ($self, $link) = @_;
+ my $to = $link->attr('to');
+ my $frag = $link->attr('section');
+
+ return undef unless defined $to and length $to; # should never happen
+
+ $frag = $self->section_escape($frag)
+ if defined $frag and length($frag .= ''); # (stringify)
+
+ DEBUG and print "Resolving \"$to/$frag\"\n\n";
+
+ return $self->resolve_man_page_link($to, $frag);
+}
+
+
+sub do_pod_link {
+ # And now things get really messy...
+ my($self, $link) = @_;
+ my $to = $link->attr('to');
+ my $section = $link->attr('section');
+ return undef unless( # should never happen
+ (defined $to and length $to) or
+ (defined $section and length $section)
+ );
+
+ $section = $self->section_escape($section)
+ if defined $section and length($section .= ''); # (stringify)
+
+ DEBUG and printf "Resolving \"%s\" \"%s\"...\n",
+ $to || "(nil)", $section || "(nil)";
+
+ {
+ # An early hack:
+ my $complete_url = $self->resolve_pod_link_by_table($to, $section);
+ if( $complete_url ) {
+ DEBUG > 1 and print "resolve_pod_link_by_table(T,S) gives ",
+ $complete_url, "\n (Returning that.)\n";
+ return $complete_url;
+ } else {
+ DEBUG > 4 and print " resolve_pod_link_by_table(T,S)",
+ " didn't return anything interesting.\n";
+ }
+ }
+
+ if(defined $to and length $to) {
+ # Give this routine first hack again
+ my $there = $self->resolve_pod_link_by_table($to);
+ if(defined $there and length $there) {
+ DEBUG > 1
+ and print "resolve_pod_link_by_table(T) gives $there\n";
+ } else {
+ $there =
+ $self->resolve_pod_page_link($to, $section);
+ # (I pass it the section value, but I don't see a
+ # particular reason it'd use it.)
+ DEBUG > 1 and print "resolve_pod_page_link gives ", $to || "(nil)", "\n";
+ unless( defined $there and length $there ) {
+ DEBUG and print "Can't resolve $to\n";
+ return undef;
+ }
+ # resolve_pod_page_link returning undef is how it
+ # can signal that it gives up on making a link
+ }
+ $to = $there;
+ }
+
+ #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n";
+
+ my $out = (defined $to and length $to) ? $to : '';
+ $out .= "#" . $section if defined $section and length $section;
+
+ unless(length $out) { # sanity check
+ DEBUG and printf "Oddly, couldn't resolve \"%s\" \"%s\"...\n",
+ $to || "(nil)", $section || "(nil)";
+ return undef;
+ }
+
+ DEBUG and print "Resolved to $out\n";
+ return $out;
+}
+
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+
+sub section_escape {
+ my($self, $section) = @_;
+ return $self->section_url_escape(
+ $self->section_name_tidy($section)
+ );
+}
+
+sub section_name_tidy {
+ my($self, $section) = @_;
+ $section =~ tr/ /_/;
+ $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters
+ $section = $self->unicode_escape_url($section);
+ $section = '_' unless length $section;
+ return $section;
+}
+
+sub section_url_escape { shift->general_url_escape(@_) }
+sub pagepath_url_escape { shift->general_url_escape(@_) }
+sub manpage_url_escape { shift->general_url_escape(@_) }
+
+sub general_url_escape {
+ my($self, $string) = @_;
+
+ $string =~ s/([^\x00-\xFF])/join '', map sprintf('%%%02X',$_), unpack 'C*', $1/eg;
+ # express Unicode things as urlencode(utf(orig)).
+
+ # A pretty conservative escaping, behoovey even for query components
+ # of a URL (see RFC 2396)
+
+ $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg;
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done
+ # about that, I guess?
+
+ return $string;
+}
+
+#--------------------------------------------------------------------------
+#
+# Oh look, a yawning portal to Hell! Let's play touch football right by it!
+#
+
+sub resolve_pod_page_link {
+ # resolve_pod_page_link must return a properly escaped URL
+ my $self = shift;
+ return $self->batch_mode()
+ ? $self->resolve_pod_page_link_batch_mode(@_)
+ : $self->resolve_pod_page_link_singleton_mode(@_)
+ ;
+}
+
+sub resolve_pod_page_link_singleton_mode {
+ my($self, $it) = @_;
+ return undef unless defined $it and length $it;
+ my $url = $self->pagepath_url_escape($it);
+
+ $url =~ s{::$}{}s; # probably never comes up anyway
+ $url =~ s{::}{/}g unless $self->perldoc_url_prefix =~ m/\?/s; # sane DWIM?
+
+ return undef unless length $url;
+ return $self->perldoc_url_prefix . $url . $self->perldoc_url_postfix;
+}
+
+sub resolve_pod_page_link_batch_mode {
+ my($self, $to) = @_;
+ DEBUG > 1 and print " During batch mode, resolving $to ...\n";
+ my @path = grep length($_), split m/::/s, $to, -1;
+ unless( @path ) { # sanity
+ DEBUG and print "Very odd! Splitting $to gives (nil)!\n";
+ return undef;
+ }
+ $self->batch_mode_rectify_path(\@path);
+ my $out = join('/', map $self->pagepath_url_escape($_), @path)
+ . $HTML_EXTENSION;
+ DEBUG > 1 and print " => $out\n";
+ return $out;
+}
+
+sub batch_mode_rectify_path {
+ my($self, $pathbits) = @_;
+ my $level = $self->batch_mode_current_level;
+ $level--; # how many levels up to go to get to the root
+ if($level < 1) {
+ unshift @$pathbits, '.'; # just to be pretty
+ } else {
+ unshift @$pathbits, ('..') x $level;
+ }
+ return;
+}
+
+sub resolve_man_page_link {
+ my ($self, $to, $frag) = @_;
+ my ($page, $section) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
+
+ return undef unless defined $page and length $page;
+ $section ||= 1;
+
+ return $self->man_url_prefix . "$section/"
+ . $self->manpage_url_escape($page)
+ . $self->man_url_postfix;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub resolve_pod_link_by_table {
+ # A crazy hack to allow specifying custom L<foo> => URL mappings
+
+ return unless $_[0]->{'podhtml_LOT'}; # An optimizy shortcut
+
+ my($self, $to, $section) = @_;
+
+ # TODO: add a method that actually populates podhtml_LOT from a file?
+
+ if(defined $section) {
+ $to = '' unless defined $to and length $to;
+ return $self->{'podhtml_LOT'}{"$to#$section"}; # quite possibly undef!
+ } else {
+ return $self->{'podhtml_LOT'}{$to}; # quite possibly undef!
+ }
+ return;
+}
+
+###########################################################################
+
+sub linearize_tokens { # self, tokens
+ my $self = shift;
+ my $out = '';
+
+ my $t;
+ while($t = shift @_) {
+ if(!ref $t or !UNIVERSAL::can($t, 'is_text')) {
+ $out .= $t; # a string, or some insane thing
+ } elsif($t->is_text) {
+ $out .= $t->text;
+ } elsif($t->is_start and $t->tag eq 'X') {
+ # Ignore until the end of this X<...> sequence:
+ my $x_open = 1;
+ while($x_open) {
+ next if( ($t = shift @_)->is_text );
+ if( $t->is_start and $t->tag eq 'X') { ++$x_open }
+ elsif($t->is_end and $t->tag eq 'X') { --$x_open }
+ }
+ }
+ }
+ return undef if length $out > $Linearization_Limit;
+ return $out;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub unicode_escape_url {
+ my($self, $string) = @_;
+ $string =~ s/([^\x00-\xFF])/'('.ord($1).')'/eg;
+ # Turn char 1234 into "(1234)"
+ return $string;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub esc { # a function.
+ if(defined wantarray) {
+ if(wantarray) {
+ @_ = splice @_; # break aliasing
+ } else {
+ my $x = shift;
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
+ return $x;
+ }
+ }
+ foreach my $x (@_) {
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg
+ if defined $x;
+ # Leave out "- so that "--" won't make it thru in X-generated comments
+ # with text in them.
+
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done about that.
+ }
+ return @_;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+1;
+__END__
+
+=head1 NAME
+
+Pod::Simple::HTML - convert Pod to HTML
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::HTML -e Pod::Simple::HTML::go thingy.pod
+
+
+=head1 DESCRIPTION
+
+This class is for making an HTML rendering of a Pod document.
+
+This is a subclass of L<Pod::Simple::PullParser> and inherits all its
+methods (and options).
+
+Note that if you want to do a batch conversion of a lot of Pod
+documents to HTML, you should see the module L<Pod::Simple::HTMLBatch>.
+
+
+
+=head1 CALLING FROM THE COMMAND LINE
+
+TODO
+
+ perl -MPod::Simple::HTML -e Pod::Simple::HTML::go Thing.pod Thing.html
+
+
+
+=head1 CALLING FROM PERL
+
+TODO make a new object, set any options, and use parse_from_file
+
+
+=head1 METHODS
+
+TODO
+all (most?) accessorized methods
+
+
+=head1 SUBCLASSING
+
+TODO
+
+ can just set any of: html_css html_javascript title_prefix
+ 'html_header_before_title',
+ 'html_header_after_title',
+ 'html_footer',
+
+maybe override do_pod_link
+
+maybe override do_beginning do_end
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::HTMLBatch>
+
+TODO: a corpus of sample Pod input and HTML output? Or common
+idioms?
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002-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 ACKNOWLEDGEMENTS
+
+Thanks to L<Hurricane Electrict|http://he.net/> for permission to use its
+L<Linux man pages online|http://man.he.net/> site for man page links.
+
+Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
+site for Perl module links.
+
+=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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm
new file mode 100755
index 00000000000..736ff53bcc1
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm
@@ -0,0 +1,1372 @@
+
+require 5;
+package Pod::Simple::HTMLBatch;
+use strict;
+use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION
+ $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA
+);
+$VERSION = '3.13';
+@ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML!
+
+# TODO: nocontents stylesheets. Strike some of the color variations?
+
+use Pod::Simple::HTML ();
+BEGIN {*esc = \&Pod::Simple::HTML::esc }
+use File::Spec ();
+use UNIVERSAL ();
+ # "Isn't the Universe an amazing place? I wouldn't live anywhere else!"
+
+use Pod::Simple::Search;
+$SEARCH_CLASS ||= 'Pod::Simple::Search';
+
+BEGIN {
+ if(defined &DEBUG) { } # no-op
+ elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG }
+ else { *DEBUG = sub () {0}; }
+}
+
+$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
+# flag to occasionally sleep for $SLEEPY - 1 seconds.
+
+$HTML_RENDER_CLASS ||= "Pod::Simple::HTML";
+
+#
+# Methods beginning with "_" are particularly internal and possibly ugly.
+#
+
+Pod::Simple::_accessorize( __PACKAGE__,
+ 'verbose', # how verbose to be during batch conversion
+ 'html_render_class', # what class to use to render
+ 'search_class', # what to use to search for POD documents
+ 'contents_file', # If set, should be the name of a file (in current directory)
+ # to write the list of all modules to
+ 'index', # will set $htmlpage->index(...) to this (true or false)
+ 'progress', # progress object
+ 'contents_page_start', 'contents_page_end',
+
+ 'css_flurry', '_css_wad', 'javascript_flurry', '_javascript_wad',
+ 'no_contents_links', # set to true to suppress automatic adding of << links.
+ '_contents',
+);
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# Just so we can run from the command line more easily
+sub go {
+ @ARGV == 2 or die sprintf(
+ "Usage: perl -M%s -e %s:go indirs outdir\n (or use \"\@INC\" for indirs)\n",
+ __PACKAGE__, __PACKAGE__,
+ );
+
+ if(defined($ARGV[1]) and length($ARGV[1])) {
+ my $d = $ARGV[1];
+ -e $d or die "I see no output directory named \"$d\"\nAborting";
+ -d $d or die "But \"$d\" isn't a directory!\nAborting";
+ -w $d or die "Directory \"$d\" isn't writeable!\nAborting";
+ }
+
+ __PACKAGE__->batch_convert(@ARGV);
+}
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+
+sub new {
+ my $new = bless {}, ref($_[0]) || $_[0];
+ $new->html_render_class($HTML_RENDER_CLASS);
+ $new->search_class($SEARCH_CLASS);
+ $new->verbose(1 + DEBUG);
+ $new->_contents([]);
+
+ $new->index(1);
+
+ $new-> _css_wad([]); $new->css_flurry(1);
+ $new->_javascript_wad([]); $new->javascript_flurry(1);
+
+ $new->contents_file(
+ 'index' . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION)
+ );
+
+ $new->contents_page_start( join "\n", grep $_,
+ $Pod::Simple::HTML::Doctype_decl,
+ "<html><head>",
+ "<title>Perl Documentation</title>",
+ $Pod::Simple::HTML::Content_decl,
+ "</head>",
+ "\n<body class='contentspage'>\n<h1>Perl Documentation</h1>\n"
+ ); # override if you need a different title
+
+
+ $new->contents_page_end( sprintf(
+ "\n\n<p class='contentsfooty'>Generated by %s v%s under Perl v%s\n<br >At %s GMT, which is %s local time.</p>\n\n</body></html>\n",
+ esc(
+ ref($new),
+ eval {$new->VERSION} || $VERSION,
+ $], scalar(gmtime), scalar(localtime),
+ )));
+
+ return $new;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub muse {
+ my $self = shift;
+ if($self->verbose) {
+ print 'T+', int(time() - $self->{'_batch_start_time'}), "s: ", @_, "\n";
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub batch_convert {
+ my($self, $dirs, $outdir) = @_;
+ $self ||= __PACKAGE__; # tolerate being called as an optionless function
+ $self = $self->new unless ref $self; # tolerate being used as a class method
+
+ if(!defined($dirs) or $dirs eq '' or $dirs eq '@INC' ) {
+ $dirs = '';
+ } elsif(ref $dirs) {
+ # OK, it's an explicit set of dirs to scan, specified as an arrayref.
+ } else {
+ # OK, it's an explicit set of dirs to scan, specified as a
+ # string like "/thing:/also:/whatever/perl" (":"-delim, as usual)
+ # or, under MSWin, like "c:/thing;d:/also;c:/whatever/perl" (";"-delim!)
+ require Config;
+ my $ps = quotemeta( $Config::Config{'path_sep'} || ":" );
+ $dirs = [ grep length($_), split qr/$ps/, $dirs ];
+ }
+
+ $outdir = $self->filespecsys->curdir
+ unless defined $outdir and length $outdir;
+
+ $self->_batch_convert_main($dirs, $outdir);
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _batch_convert_main {
+ my($self, $dirs, $outdir) = @_;
+ # $dirs is either false, or an arrayref.
+ # $outdir is a pathspec.
+
+ $self->{'_batch_start_time'} ||= time();
+
+ $self->muse( "= ", scalar(localtime) );
+ $self->muse( "Starting batch conversion to \"$outdir\"" );
+
+ my $progress = $self->progress;
+ if(!$progress and $self->verbose > 0 and $self->verbose() <= 5) {
+ require Pod::Simple::Progress;
+ $progress = Pod::Simple::Progress->new(
+ ($self->verbose < 2) ? () # Default omission-delay
+ : ($self->verbose == 2) ? 1 # Reduce the omission-delay
+ : 0 # Eliminate the omission-delay
+ );
+ $self->progress($progress);
+ }
+
+ if($dirs) {
+ $self->muse(scalar(@$dirs), " dirs to scan: @$dirs");
+ } else {
+ $self->muse("Scanning \@INC. This could take a minute or two.");
+ }
+ my $mod2path = $self->find_all_pods($dirs ? $dirs : ());
+ $self->muse("Done scanning.");
+
+ my $total = keys %$mod2path;
+ unless($total) {
+ $self->muse("No pod found. Aborting batch conversion.\n");
+ return $self;
+ }
+
+ $progress and $progress->goal($total);
+ $self->muse("Now converting pod files to HTML.",
+ ($total > 25) ? " This will take a while more." : ()
+ );
+
+ $self->_spray_css( $outdir );
+ $self->_spray_javascript( $outdir );
+
+ $self->_do_all_batch_conversions($mod2path, $outdir);
+
+ $progress and $progress->done(sprintf (
+ "Done converting %d files.", $self->{"__batch_conv_page_count"}
+ ));
+ return $self->_batch_convert_finish($outdir);
+ return $self;
+}
+
+
+sub _do_all_batch_conversions {
+ my($self, $mod2path, $outdir) = @_;
+ $self->{"__batch_conv_page_count"} = 0;
+
+ foreach my $module (sort {lc($a) cmp lc($b)} keys %$mod2path) {
+ $self->_do_one_batch_conversion($module, $mod2path, $outdir);
+ sleep($SLEEPY - 1) if $SLEEPY;
+ }
+
+ return;
+}
+
+sub _batch_convert_finish {
+ my($self, $outdir) = @_;
+ $self->write_contents_file($outdir);
+ $self->muse("Done with batch conversion. $$self{'__batch_conv_page_count'} files done.");
+ $self->muse( "= ", scalar(localtime) );
+ $self->progress and $self->progress->done("All done!");
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _do_one_batch_conversion {
+ my($self, $module, $mod2path, $outdir, $outfile) = @_;
+
+ my $retval;
+ my $total = scalar keys %$mod2path;
+ my $infile = $mod2path->{$module};
+ my @namelets = grep m/\S/, split "::", $module;
+ # this can stick around in the contents LoL
+ my $depth = scalar @namelets;
+ die "Contentless thingie?! $module $infile" unless @namelets; #sanity
+
+ $outfile ||= do {
+ my @n = @namelets;
+ $n[-1] .= $HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION;
+ $self->filespecsys->catfile( $outdir, @n );
+ };
+
+ my $progress = $self->progress;
+
+ my $page = $self->html_render_class->new;
+ if(DEBUG > 5) {
+ $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: ",
+ ref($page), " render ($depth) $module => $outfile");
+ } elsif(DEBUG > 2) {
+ $self->muse($self->{"__batch_conv_page_count"} + 1, "/$total: $module => $outfile")
+ }
+
+ # Give each class a chance to init the converter:
+ $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
+ if $page->can('batch_mode_page_object_init');
+ # Init for the index (TOC), too.
+ $self->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
+ if $self->can('batch_mode_page_object_init');
+
+ # Now get busy...
+ $self->makepath($outdir => \@namelets);
+
+ $progress and $progress->reach($self->{"__batch_conv_page_count"}, "Rendering $module");
+
+ if( $retval = $page->parse_from_file($infile, $outfile) ) {
+ ++ $self->{"__batch_conv_page_count"} ;
+ $self->note_for_contents_file( \@namelets, $infile, $outfile );
+ } else {
+ $self->muse("Odd, parse_from_file(\"$infile\", \"$outfile\") returned false.");
+ }
+
+ $page->batch_mode_page_object_kill($self, $module, $infile, $outfile, $depth)
+ if $page->can('batch_mode_page_object_kill');
+ # The following isn't a typo. Note that it switches $self and $page.
+ $self->batch_mode_page_object_kill($page, $module, $infile, $outfile, $depth)
+ if $self->can('batch_mode_page_object_kill');
+
+ DEBUG > 4 and printf "%s %sb < $infile %s %sb\n",
+ $outfile, -s $outfile, $infile, -s $infile
+ ;
+
+ undef($page);
+ return $retval;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub filespecsys { $_[0]{'_filespecsys'} || 'File::Spec' }
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub note_for_contents_file {
+ my($self, $namelets, $infile, $outfile) = @_;
+
+ # I think the infile and outfile parts are never used. -- SMB
+ # But it's handy to have them around for debugging.
+
+ if( $self->contents_file ) {
+ my $c = $self->_contents();
+ push @$c,
+ [ join("::", @$namelets), $infile, $outfile, $namelets ]
+ # 0 1 2 3
+ ;
+ DEBUG > 3 and print "Noting @$c[-1]\n";
+ }
+ return;
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub write_contents_file {
+ my($self, $outdir) = @_;
+ my $outfile = $self->_contents_filespec($outdir) || return;
+
+ $self->muse("Preparing list of modules for ToC");
+
+ my($toplevel, # maps toplevelbit => [all submodules]
+ $toplevel_form_freq, # ends up being 'foo' => 'Foo'
+ ) = $self->_prep_contents_breakdown;
+
+ my $Contents = eval { $self->_wopen($outfile) };
+ if( $Contents ) {
+ $self->muse( "Writing contents file $outfile" );
+ } else {
+ warn "Couldn't write-open contents file $outfile: $!\nAbort writing to $outfile at all";
+ return;
+ }
+
+ $self->_write_contents_start( $Contents, $outfile, );
+ $self->_write_contents_middle( $Contents, $outfile, $toplevel, $toplevel_form_freq );
+ $self->_write_contents_end( $Contents, $outfile, );
+ return $outfile;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_start {
+ my($self, $Contents, $outfile) = @_;
+ my $starter = $self->contents_page_start || '';
+
+ {
+ my $css_wad = $self->_css_wad_to_markup(1);
+ if( $css_wad ) {
+ $starter =~ s{(</head>)}{\n$css_wad\n$1}i; # otherwise nevermind
+ }
+
+ my $javascript_wad = $self->_javascript_wad_to_markup(1);
+ if( $javascript_wad ) {
+ $starter =~ s{(</head>)}{\n$javascript_wad\n$1}i; # otherwise nevermind
+ }
+ }
+
+ unless(print $Contents $starter, "<dl class='superindex'>\n" ) {
+ warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Contents);
+ return 0;
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_middle {
+ my($self, $Contents, $outfile, $toplevel2submodules, $toplevel_form_freq) = @_;
+
+ foreach my $t (sort keys %$toplevel2submodules) {
+ my @downlines = sort {$a->[-1] cmp $b->[-1]}
+ @{ $toplevel2submodules->{$t} };
+
+ printf $Contents qq[<dt><a name="%s">%s</a></dt>\n<dd>\n],
+ esc( $t, $toplevel_form_freq->{$t} )
+ ;
+
+ my($path, $name);
+ foreach my $e (@downlines) {
+ $name = $e->[0];
+ $path = join( "/", '.', esc( @{$e->[3]} ) )
+ . ($HTML_EXTENSION || $Pod::Simple::HTML::HTML_EXTENSION);
+ print $Contents qq{ <a href="$path">}, esc($name), "</a>&nbsp;&nbsp;\n";
+ }
+ print $Contents "</dd>\n\n";
+ }
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _write_contents_end {
+ my($self, $Contents, $outfile) = @_;
+ unless(
+ print $Contents "</dl>\n",
+ $self->contents_page_end || '',
+ ) {
+ warn "Couldn't write to $outfile: $!";
+ }
+ close($Contents) or warn "Couldn't close $outfile: $!";
+ return 1;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _prep_contents_breakdown {
+ my($self) = @_;
+ my $contents = $self->_contents;
+ my %toplevel; # maps lctoplevelbit => [all submodules]
+ my %toplevel_form_freq; # ends up being 'foo' => 'Foo'
+ # (mapping anycase forms to most freq form)
+
+ foreach my $entry (@$contents) {
+ my $toplevel =
+ $entry->[0] =~ m/^perl\w*$/ ? 'perl_core_docs'
+ # group all the perlwhatever docs together
+ : $entry->[3][0] # normal case
+ ;
+ ++$toplevel_form_freq{ lc $toplevel }{ $toplevel };
+ push @{ $toplevel{ lc $toplevel } }, $entry;
+ push @$entry, lc($entry->[0]); # add a sort-order key to the end
+ }
+
+ foreach my $toplevel (sort keys %toplevel) {
+ my $fgroup = $toplevel_form_freq{$toplevel};
+ $toplevel_form_freq{$toplevel} =
+ (
+ sort { $fgroup->{$b} <=> $fgroup->{$a} or $a cmp $b }
+ keys %$fgroup
+ # This hash is extremely unlikely to have more than 4 members, so this
+ # sort isn't so very wasteful
+ )[0];
+ }
+
+ return(\%toplevel, \%toplevel_form_freq) if wantarray;
+ return \%toplevel;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _contents_filespec {
+ my($self, $outdir) = @_;
+ my $outfile = $self->contents_file;
+ return unless $outfile;
+ return $self->filespecsys->catfile( $outdir, $outfile );
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub makepath {
+ my($self, $outdir, $namelets) = @_;
+ return unless @$namelets > 1;
+ for my $i (0 .. ($#$namelets - 1)) {
+ my $dir = $self->filespecsys->catdir( $outdir, @$namelets[0 .. $i] );
+ if(-e $dir) {
+ die "$dir exists but not as a directory!?" unless -d $dir;
+ next;
+ }
+ DEBUG > 3 and print " Making $dir\n";
+ mkdir $dir, 0777
+ or die "Can't mkdir $dir: $!\nAborting"
+ ;
+ }
+ return;
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub batch_mode_page_object_init {
+ my $self = shift;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+
+ # TODO: any further options to percolate onto this new object here?
+
+ $page->default_title($module);
+ $page->index( $self->index );
+
+ $page->html_css( $self-> _css_wad_to_markup($depth) );
+ $page->html_javascript( $self->_javascript_wad_to_markup($depth) );
+
+ $self->add_header_backlink($page, $module, $infile, $outfile, $depth);
+ $self->add_footer_backlink($page, $module, $infile, $outfile, $depth);
+
+
+ return $self;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub add_header_backlink {
+ my $self = shift;
+ return if $self->no_contents_links;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+ $page->html_header_after_title( join '',
+ $page->html_header_after_title || '',
+
+ qq[<p class="backlinktop"><b><a name="___top" href="],
+ $self->url_up_to_contents($depth),
+ qq[" accesskey="1" title="All Documents">&lt;&lt;</a></b></p>\n],
+ )
+ if $self->contents_file
+ ;
+ return;
+}
+
+sub add_footer_backlink {
+ my $self = shift;
+ return if $self->no_contents_links;
+ my($page, $module, $infile, $outfile, $depth) = @_;
+ $page->html_footer( join '',
+ qq[<p class="backlinkbottom"><b><a name="___bottom" href="],
+ $self->url_up_to_contents($depth),
+ qq[" title="All Documents">&lt;&lt;</a></b></p>\n],
+
+ $page->html_footer || '',
+ )
+ if $self->contents_file
+ ;
+ return;
+}
+
+sub url_up_to_contents {
+ my($self, $depth) = @_;
+ --$depth;
+ return join '/', ('..') x $depth, esc($self->contents_file);
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub find_all_pods {
+ my($self, $dirs) = @_;
+ # You can override find_all_pods in a subclass if you want to
+ # do extra filtering or whatnot. But for the moment, we just
+ # pass to modnames2paths:
+ return $self->modnames2paths($dirs);
+}
+
+#_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-
+
+sub modnames2paths { # return a hashref mapping modulenames => paths
+ my($self, $dirs) = @_;
+
+ my $m2p;
+ {
+ my $search = $self->search_class->new;
+ DEBUG and print "Searching via $search\n";
+ $search->verbose(1) if DEBUG > 10;
+ $search->progress( $self->progress->copy->goal(0) ) if $self->progress;
+ $search->shadows(0); # don't bother noting shadowed files
+ $search->inc( $dirs ? 0 : 1 );
+ $search->survey( $dirs ? @$dirs : () );
+ $m2p = $search->name2path;
+ die "What, no name2path?!" unless $m2p;
+ }
+
+ $self->muse("That's odd... no modules found!") unless keys %$m2p;
+ if( DEBUG > 4 ) {
+ print "Modules found (name => path):\n";
+ foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) {
+ print " $m $$m2p{$m}\n";
+ }
+ print "(total ", scalar(keys %$m2p), ")\n\n";
+ } elsif( DEBUG ) {
+ print "Found ", scalar(keys %$m2p), " modules.\n";
+ }
+ $self->muse( "Found ", scalar(keys %$m2p), " modules." );
+
+ # return the Foo::Bar => /whatever/Foo/Bar.pod|pm hashref
+ return $m2p;
+}
+
+#===========================================================================
+
+sub _wopen {
+ # this is abstracted out so that the daemon class can override it
+ my($self, $outpath) = @_;
+ require Symbol;
+ my $out_fh = Symbol::gensym();
+ DEBUG > 5 and print "Write-opening to $outpath\n";
+ return $out_fh if open($out_fh, "> $outpath");
+ require Carp;
+ Carp::croak("Can't write-open $outpath: $!");
+}
+
+#==========================================================================
+
+sub add_css {
+ my($self, $url, $is_default, $name, $content_type, $media, $_code) = @_;
+ return unless $url;
+ unless($name) {
+ # cook up a reasonable name based on the URL
+ $name = $url;
+ if( $name !~ m/\?/ and $name =~ m{([^/]+)$}s ) {
+ $name = $1;
+ $name =~ s/\.css//i;
+ }
+ }
+ $media ||= 'all';
+ $content_type ||= 'text/css';
+
+ my $bunch = [$url, $name, $content_type, $media, $_code];
+ if($is_default) { unshift @{ $self->_css_wad }, $bunch }
+ else { push @{ $self->_css_wad }, $bunch }
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _spray_css {
+ my($self, $outdir) = @_;
+
+ return unless $self->css_flurry();
+ $self->_gen_css_wad();
+
+ my $lol = $self->_css_wad;
+ foreach my $chunk (@$lol) {
+ my $url = $chunk->[0];
+ my $outfile;
+ if( ref($chunk->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.css$)} ) {
+ $outfile = $self->filespecsys->catfile( $outdir, "$1" );
+ DEBUG > 5 and print "Noting $$chunk[0] as a file I'll create.\n";
+ } else {
+ DEBUG > 5 and print "OK, noting $$chunk[0] as an external CSS.\n";
+ # Requires no further attention.
+ next;
+ }
+
+ #$self->muse( "Writing autogenerated CSS file $outfile" );
+ my $Cssout = $self->_wopen($outfile);
+ print $Cssout ${$chunk->[-1]}
+ or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Cssout);
+ DEBUG > 5 and print "Wrote $outfile\n";
+ }
+
+ return;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub _css_wad_to_markup {
+ my($self, $depth) = @_;
+
+ my @css = @{ $self->_css_wad || return '' };
+ return '' unless @css;
+
+ my $rel = 'stylesheet';
+ my $out = '';
+
+ --$depth;
+ my $uplink = $depth ? ('../' x $depth) : '';
+
+ foreach my $chunk (@css) {
+ next unless $chunk and @$chunk;
+
+ my( $url1, $url2, $title, $type, $media) = (
+ $self->_maybe_uplink( $chunk->[0], $uplink ),
+ esc(grep !ref($_), @$chunk)
+ );
+
+ $out .= qq{<link rel="$rel" title="$title" type="$type" href="$url1$url2" media="$media" >\n};
+
+ $rel = 'alternate stylesheet'; # alternates = all non-first iterations
+ }
+ return $out;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub _maybe_uplink {
+ # if the given URL looks relative, return the given uplink string --
+ # otherwise return emptystring
+ my($self, $url, $uplink) = @_;
+ ($url =~ m{^\./} or $url !~ m{[/\:]} )
+ ? $uplink
+ : ''
+ # qualify it, if/as needed
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+sub _gen_css_wad {
+ my $self = $_[0];
+ my $css_template = $self->_css_template;
+ foreach my $variation (
+
+ # Commented out for sake of concision:
+ #
+ # 011n=black_with_red_on_white
+ # 001n=black_with_yellow_on_white
+ # 101n=black_with_green_on_white
+ # 110=white_with_yellow_on_black
+ # 010=white_with_green_on_black
+ # 011=white_with_blue_on_black
+ # 100=white_with_red_on_black
+ '110n=blkbluw', # black_with_blue_on_white
+ '010n=blkmagw', # black_with_magenta_on_white
+ '100n=blkcynw', # black_with_cyan_on_white
+ '101=whtprpk', # white_with_purple_on_black
+ '001=whtnavk', # white_with_navy_blue_on_black
+ '010a=grygrnk', # grey_with_green_on_black
+ '010b=whtgrng', # white_with_green_on_grey
+ '101an=blkgrng', # black_with_green_on_grey
+ '101bn=grygrnw', # grey_with_green_on_white
+ ) {
+
+ my $outname = $variation;
+ my($flipmode, @swap) = ( ($4 || ''), $1,$2,$3)
+ if $outname =~ s/^([012])([012])([[012])([a-z]*)=?//s;
+ @swap = () if '010' eq join '', @swap; # 010 is a swop-no-op!
+
+ my $this_css =
+ "/* This file is autogenerated. Do not edit. $variation */\n\n"
+ . $css_template;
+
+ # Only look at three-digitty colors, for now at least.
+ if( $flipmode =~ m/n/ ) {
+ $this_css =~ s/(#[0-9a-fA-F]{3})\b/_color_negate($1)/eg;
+ $this_css =~ s/\bthin\b/medium/g;
+ }
+ $this_css =~ s<#([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])\b>
+ < join '', '#', ($1,$2,$3)[@swap] >eg if @swap;
+
+ if( $flipmode =~ m/a/)
+ { $this_css =~ s/#fff\b/#999/gi } # black -> dark grey
+ elsif($flipmode =~ m/b/)
+ { $this_css =~ s/#000\b/#666/gi } # white -> light grey
+
+ my $name = $outname;
+ $name =~ tr/-_/ /;
+ $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css);
+ }
+
+ # Now a few indexless variations:
+ foreach my $variation (
+ 'blkbluw', # black_with_blue_on_white
+ 'whtpurk', # white_with_purple_on_black
+ 'whtgrng', # white_with_green_on_grey
+ 'grygrnw', # grey_with_green_on_white
+ ) {
+ my $outname = "$variation\_";
+ my $this_css = join "\n",
+ "/* This file is autogenerated. Do not edit. $outname */\n",
+ "\@import url(\"./_$variation.css\");",
+ ".indexgroup { display: none; }",
+ "\n",
+ ;
+ my $name = $outname;
+ $name =~ tr/-_/ /;
+ $self->add_css( "$outname.css", 0, $name, 0, 0, \$this_css);
+ }
+
+ return;
+}
+
+sub _color_negate {
+ my $x = lc $_[0];
+ $x =~ tr[0123456789abcdef]
+ [fedcba9876543210];
+ return $x;
+}
+
+#===========================================================================
+
+sub add_javascript {
+ my($self, $url, $content_type, $_code) = @_;
+ return unless $url;
+ push @{ $self->_javascript_wad }, [
+ $url, $content_type || 'text/javascript', $_code
+ ];
+ return;
+}
+
+sub _spray_javascript {
+ my($self, $outdir) = @_;
+ return unless $self->javascript_flurry();
+ $self->_gen_javascript_wad();
+
+ my $lol = $self->_javascript_wad;
+ foreach my $script (@$lol) {
+ my $url = $script->[0];
+ my $outfile;
+
+ if( ref($script->[-1]) and $url =~ m{^(_[-a-z0-9_]+\.js$)} ) {
+ $outfile = $self->filespecsys->catfile( $outdir, "$1" );
+ DEBUG > 5 and print "Noting $$script[0] as a file I'll create.\n";
+ } else {
+ DEBUG > 5 and print "OK, noting $$script[0] as an external JavaScript.\n";
+ next;
+ }
+
+ #$self->muse( "Writing JavaScript file $outfile" );
+ my $Jsout = $self->_wopen($outfile);
+
+ print $Jsout ${$script->[-1]}
+ or warn "Couldn't print to $outfile: $!\nAbort writing to $outfile at all";
+ close($Jsout);
+ DEBUG > 5 and print "Wrote $outfile\n";
+ }
+
+ return;
+}
+
+sub _gen_javascript_wad {
+ my $self = $_[0];
+ my $js_code = $self->_javascript || return;
+ $self->add_javascript( "_podly.js", 0, \$js_code);
+ return;
+}
+
+sub _javascript_wad_to_markup {
+ my($self, $depth) = @_;
+
+ my @scripts = @{ $self->_javascript_wad || return '' };
+ return '' unless @scripts;
+
+ my $out = '';
+
+ --$depth;
+ my $uplink = $depth ? ('../' x $depth) : '';
+
+ foreach my $s (@scripts) {
+ next unless $s and @$s;
+
+ my( $url1, $url2, $type, $media) = (
+ $self->_maybe_uplink( $s->[0], $uplink ),
+ esc(grep !ref($_), @$s)
+ );
+
+ $out .= qq{<script type="$type" src="$url1$url2"></script>\n};
+ }
+ return $out;
+}
+
+#===========================================================================
+
+sub _css_template { return $CSS }
+sub _javascript { return $JAVASCRIPT }
+
+$CSS = <<'EOCSS';
+/* For accessibility reasons, never specify text sizes in px/pt/pc/in/cm/mm */
+
+@media all { .hide { display: none; } }
+
+@media print {
+ .noprint, div.indexgroup, .backlinktop, .backlinkbottom { display: none }
+
+ * {
+ border-color: black !important;
+ color: black !important;
+ background-color: transparent !important;
+ background-image: none !important;
+ }
+
+ dl.superindex > dd {
+ word-spacing: .6em;
+ }
+}
+
+@media aural, braille, embossed {
+ div.indexgroup { display: none; } /* Too noisy, don't you think? */
+ dl.superindex > dt:before { content: "Group "; }
+ dl.superindex > dt:after { content: " contains:"; }
+ .backlinktop a:before { content: "Back to contents"; }
+ .backlinkbottom a:before { content: "Back to contents"; }
+}
+
+@media aural {
+ dl.superindex > dt { pause-before: 600ms; }
+}
+
+@media screen, tty, tv, projection {
+ .noscreen { display: none; }
+
+ a:link { color: #7070ff; text-decoration: underline; }
+ a:visited { color: #e030ff; text-decoration: underline; }
+ a:active { color: #800000; text-decoration: underline; }
+ body.contentspage a { text-decoration: none; }
+ a.u { color: #fff !important; text-decoration: none; }
+
+ body.pod {
+ margin: 0 5px;
+ color: #fff;
+ background-color: #000;
+ }
+
+ body.pod h1, body.pod h2, body.pod h3, body.pod h4 {
+ font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
+ font-weight: normal;
+ margin-top: 1.2em;
+ margin-bottom: .1em;
+ border-top: thin solid transparent;
+ /* margin-left: -5px; border-left: 2px #7070ff solid; padding-left: 3px; */
+ }
+
+ body.pod h1 { border-top-color: #0a0; }
+ body.pod h2 { border-top-color: #080; }
+ body.pod h3 { border-top-color: #040; }
+ body.pod h4 { border-top-color: #010; }
+
+ p.backlinktop + h1 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h2 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h3 { border-top: none; margin-top: 0em; }
+ p.backlinktop + h4 { border-top: none; margin-top: 0em; }
+
+ body.pod dt {
+ font-size: 105%; /* just a wee bit more than normal */
+ }
+
+ .indexgroup { font-size: 80%; }
+
+ .backlinktop, .backlinkbottom {
+ margin-left: -5px;
+ margin-right: -5px;
+ background-color: #040;
+ border-top: thin solid #050;
+ border-bottom: thin solid #050;
+ }
+
+ .backlinktop a, .backlinkbottom a {
+ text-decoration: none;
+ color: #080;
+ background-color: #000;
+ border: thin solid #0d0;
+ }
+ .backlinkbottom { margin-bottom: 0; padding-bottom: 0; }
+ .backlinktop { margin-top: 0; padding-top: 0; }
+
+ body.contentspage {
+ color: #fff;
+ background-color: #000;
+ }
+
+ body.contentspage h1 {
+ color: #0d0;
+ margin-left: 1em;
+ margin-right: 1em;
+ text-indent: -.9em;
+ font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
+ font-weight: normal;
+ border-top: thin solid #fff;
+ border-bottom: thin solid #fff;
+ text-align: center;
+ }
+
+ dl.superindex > dt {
+ font-family: Tahoma, Verdana, Helvetica, Arial, sans-serif;
+ font-weight: normal;
+ font-size: 90%;
+ margin-top: .45em;
+ /* margin-bottom: -.15em; */
+ }
+ dl.superindex > dd {
+ word-spacing: .6em; /* most important rule here! */
+ }
+ dl.superindex > a:link {
+ text-decoration: none;
+ color: #fff;
+ }
+
+ .contentsfooty {
+ border-top: thin solid #999;
+ font-size: 90%;
+ }
+
+}
+
+/* The End */
+
+EOCSS
+
+#==========================================================================
+
+$JAVASCRIPT = <<'EOJAVASCRIPT';
+
+// From http://www.alistapart.com/articles/alternate/
+
+function setActiveStyleSheet(title) {
+ var i, a, main;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if(a.getAttribute("rel").indexOf("style") != -1 && a.getAttribute("title")) {
+ a.disabled = true;
+ if(a.getAttribute("title") == title) a.disabled = false;
+ }
+ }
+}
+
+function getActiveStyleSheet() {
+ var i, a;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if( a.getAttribute("rel").indexOf("style") != -1
+ && a.getAttribute("title")
+ && !a.disabled
+ ) return a.getAttribute("title");
+ }
+ return null;
+}
+
+function getPreferredStyleSheet() {
+ var i, a;
+ for(i=0 ; (a = document.getElementsByTagName("link")[i]) ; i++) {
+ if( a.getAttribute("rel").indexOf("style") != -1
+ && a.getAttribute("rel").indexOf("alt") == -1
+ && a.getAttribute("title")
+ ) return a.getAttribute("title");
+ }
+ return null;
+}
+
+function createCookie(name,value,days) {
+ if (days) {
+ var date = new Date();
+ date.setTime(date.getTime()+(days*24*60*60*1000));
+ var expires = "; expires="+date.toGMTString();
+ }
+ else expires = "";
+ document.cookie = name+"="+value+expires+"; path=/";
+}
+
+function readCookie(name) {
+ var nameEQ = name + "=";
+ var ca = document.cookie.split(';');
+ for(var i=0 ; i < ca.length ; i++) {
+ var c = ca[i];
+ while (c.charAt(0)==' ') c = c.substring(1,c.length);
+ if (c.indexOf(nameEQ) == 0) return c.substring(nameEQ.length,c.length);
+ }
+ return null;
+}
+
+window.onload = function(e) {
+ var cookie = readCookie("style");
+ var title = cookie ? cookie : getPreferredStyleSheet();
+ setActiveStyleSheet(title);
+}
+
+window.onunload = function(e) {
+ var title = getActiveStyleSheet();
+ createCookie("style", title, 365);
+}
+
+var cookie = readCookie("style");
+var title = cookie ? cookie : getPreferredStyleSheet();
+setActiveStyleSheet(title);
+
+// The End
+
+EOJAVASCRIPT
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+1;
+__END__
+
+
+=head1 NAME
+
+Pod::Simple::HTMLBatch - convert several Pod files to several HTML files
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::HTMLBatch -e 'Pod::Simple::HTMLBatch::go' in out
+
+
+=head1 DESCRIPTION
+
+This module is used for running batch-conversions of a lot of HTML
+documents
+
+This class is NOT a subclass of Pod::Simple::HTML
+(nor of bad old Pod::Html) -- although it uses
+Pod::Simple::HTML for doing the conversion of each document.
+
+The normal use of this class is like so:
+
+ use Pod::Simple::HTMLBatch;
+ my $batchconv = Pod::Simple::HTMLBatch->new;
+ $batchconv->some_option( some_value );
+ $batchconv->some_other_option( some_other_value );
+ $batchconv->batch_convert( \@search_dirs, $output_dir );
+
+=head2 FROM THE COMMAND LINE
+
+Note that this class also provides
+(but does not export) the function Pod::Simple::HTMLBatch::go.
+This is basically just a shortcut for C<<
+Pod::Simple::HTMLBatch->batch_convert(@ARGV) >>.
+It's meant to be handy for calling from the command line.
+
+However, the shortcut requires that you specify exactly two command-line
+arguments, C<indirs> and C<outdir>.
+
+Example:
+
+ % mkdir out_html
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html
+ (to convert the pod from Perl's @INC
+ files under the directory ../htmlversion)
+
+(Note that the command line there contains a literal atsign-I-N-C. This
+is handled as a special case by batch_convert, in order to save you having
+to enter the odd-looking "" as the first command-line parameter when you
+mean "just use whatever's in @INC".)
+
+Example:
+
+ % mkdir ../seekrut
+ % chmod og-rx ../seekrut
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../htmlversion
+ (to convert the pod under the current dir into HTML
+ files under the directory ../htmlversion)
+
+Example:
+
+ % perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go happydocs .
+ (to convert all pod from happydocs into the current directory)
+
+
+
+=head1 MAIN METHODS
+
+=over
+
+=item $batchconv = Pod::Simple::HTMLBatch->new;
+
+This TODO
+
+
+=item $batchconv->batch_convert( I<indirs>, I<outdir> );
+
+this TODO
+
+=item $batchconv->batch_convert( undef , ...);
+
+=item $batchconv->batch_convert( q{@INC}, ...);
+
+These two values for I<indirs> specify that the normal Perl @INC
+
+=item $batchconv->batch_convert( \@dirs , ...);
+
+This specifies that the input directories are the items in
+the arrayref C<\@dirs>.
+
+=item $batchconv->batch_convert( "somedir" , ...);
+
+This specifies that the director "somedir" is the input.
+(This can be an absolute or relative path, it doesn't matter.)
+
+A common value you might want would be just "." for the current
+directory:
+
+ $batchconv->batch_convert( "." , ...);
+
+
+=item $batchconv->batch_convert( 'somedir:someother:also' , ...);
+
+This specifies that you want the dirs "somedir", "somother", and "also"
+scanned, just as if you'd passed the arrayref
+C<[qw( somedir someother also)]>. Note that a ":"-separator is normal
+under Unix, but Under MSWin, you'll need C<'somedir;someother;also'>
+instead, since the pathsep on MSWin is ";" instead of ":". (And
+I<that> is because ":" often comes up in paths, like
+C<"c:/perl/lib">.)
+
+(Exactly what separator character should be used, is gotten from
+C<$Config::Config{'path_sep'}>, via the L<Config> module.)
+
+=item $batchconv->batch_convert( ... , undef );
+
+This specifies that you want the HTML output to go into the current
+directory.
+
+(Note that a missing or undefined value means a different thing in
+the first slot than in the second. That's so that C<batch_convert()>
+with no arguments (or undef arguments) means "go from @INC, into
+the current directory.)
+
+=item $batchconv->batch_convert( ... , 'somedir' );
+
+This specifies that you want the HTML output to go into the
+directory 'somedir'.
+(This can be an absolute or relative path, it doesn't matter.)
+
+=back
+
+
+Note that you can also call C<batch_convert> as a class method,
+like so:
+
+ Pod::Simple::HTMLBatch->batch_convert( ... );
+
+That is just short for this:
+
+ Pod::Simple::HTMLBatch-> new-> batch_convert(...);
+
+That is, it runs a conversion with default options, for
+whatever inputdirs and output dir you specify.
+
+
+=head2 ACCESSOR METHODS
+
+The following are all accessor methods -- that is, they don't do anything
+on their own, but just alter the contents of the conversion object,
+which comprises the options for this particular batch conversion.
+
+We show the "put" form of the accessors below (i.e., the syntax you use
+for setting the accessor to a specific value). But you can also
+call each method with no parameters to get its current value. For
+example, C<< $self->contents_file() >> returns the current value of
+the contents_file attribute.
+
+=over
+
+
+=item $batchconv->verbose( I<nonnegative_integer> );
+
+This controls how verbose to be during batch conversion, as far as
+notes to STDOUT (or whatever is C<select>'d) about how the conversion
+is going. If 0, no progress information is printed.
+If 1 (the default value), some progress information is printed.
+Higher values print more information.
+
+
+=item $batchconv->index( I<true-or-false> );
+
+This controls whether or not each HTML page is liable to have a little
+table of contents at the top (which we call an "index" for historical
+reasons). This is true by default.
+
+
+=item $batchconv->contents_file( I<filename> );
+
+If set, should be the name of a file (in the output directory)
+to write the HTML index to. The default value is "index.html".
+If you set this to a false value, no contents file will be written.
+
+=item $batchconv->contents_page_start( I<HTML_string> );
+
+This specifies what string should be put at the beginning of
+the contents page.
+The default is a string more or less like this:
+
+ <html>
+ <head><title>Perl Documentation</title></head>
+ <body class='contentspage'>
+ <h1>Perl Documentation</h1>
+
+=item $batchconv->contents_page_end( I<HTML_string> );
+
+This specifies what string should be put at the end of the contents page.
+The default is a string more or less like this:
+
+ <p class='contentsfooty'>Generated by
+ Pod::Simple::HTMLBatch v3.01 under Perl v5.008
+ <br >At Fri May 14 22:26:42 2004 GMT,
+ which is Fri May 14 14:26:42 2004 local time.</p>
+
+
+
+=item $batchconv->add_css( $url );
+
+TODO
+
+=item $batchconv->add_javascript( $url );
+
+TODO
+
+=item $batchconv->css_flurry( I<true-or-false> );
+
+If true (the default value), we autogenerate some CSS files in the
+output directory, and set our HTML files to use those.
+TODO: continue
+
+=item $batchconv->javascript_flurry( I<true-or-false> );
+
+If true (the default value), we autogenerate a JavaScript in the
+output directory, and set our HTML files to use it. Currently,
+the JavaScript is used only to get the browser to remember what
+stylesheet it prefers.
+TODO: continue
+
+=item $batchconv->no_contents_links( I<true-or-false> );
+
+TODO
+
+=item $batchconv->html_render_class( I<classname> );
+
+This sets what class is used for rendering the files.
+The default is "Pod::Simple::HTML". If you set it to something else,
+it should probably be a subclass of Pod::Simple::HTML, and you should
+C<require> or C<use> that class so that's it's loaded before
+Pod::Simple::HTMLBatch tries loading it.
+
+=item $batchconv->search_class( I<classname> );
+
+This sets what class is used for searching for the files.
+The default is "Pod::Simple::Search". If you set it to something else,
+it should probably be a subclass of Pod::Simple::Search, and you should
+C<require> or C<use> that class so that's it's loaded before
+Pod::Simple::HTMLBatch tries loading it.
+
+=back
+
+
+
+
+=head1 NOTES ON CUSTOMIZATION
+
+TODO
+
+ call add_css($someurl) to add stylesheet as alternate
+ call add_css($someurl,1) to add as primary stylesheet
+
+ call add_javascript
+
+ subclass Pod::Simple::HTML and set $batchconv->html_render_class to
+ that classname
+ and maybe override
+ $page->batch_mode_page_object_init($self, $module, $infile, $outfile, $depth)
+ or maybe override
+ $batchconv->batch_mode_page_object_init($page, $module, $infile, $outfile, $depth)
+ subclass Pod::Simple::Search and set $batchconv->search_class to
+ that classname
+
+
+
+=head1 ASK ME!
+
+If you want to do some kind of big pod-to-HTML version with some
+particular kind of option that you don't see how to achieve using this
+module, email me (C<sburke@cpan.org>) and I'll probably have a good idea
+how to do it. For reasons of concision and energetic laziness, some
+methods and options in this module (and the dozen modules it depends on)
+are undocumented; but one of those undocumented bits might be just what
+you're looking for.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::HTMLBatch>, L<perlpod>, L<perlpodspec>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLLegacy.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLLegacy.pm
new file mode 100755
index 00000000000..f78de90144f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLLegacy.pm
@@ -0,0 +1,104 @@
+
+require 5;
+package Pod::Simple::HTMLLegacy;
+use strict;
+
+use vars qw($VERSION);
+use Getopt::Long;
+
+$VERSION = "5.01";
+
+#--------------------------------------------------------------------------
+#
+# This class is meant to thinly emulate bad old Pod::Html
+#
+# TODO: some basic docs
+
+sub pod2html {
+ my @args = (@_);
+
+ my( $verbose, $infile, $outfile, $title );
+ my $index = 1;
+
+ {
+ my($help);
+
+ my($netscape); # dummy
+ local @ARGV = @args;
+ GetOptions(
+ "help" => \$help,
+ "verbose!" => \$verbose,
+ "infile=s" => \$infile,
+ "outfile=s" => \$outfile,
+ "title=s" => \$title,
+ "index!" => \$index,
+
+ "netscape!" => \$netscape,
+ ) or return bad_opts(@args);
+ bad_opts(@args) if @ARGV; # it should be all switches!
+ return help_message() if $help;
+ }
+
+ for($infile, $outfile) { $_ = undef unless defined and length }
+
+ if($verbose) {
+ warn sprintf "%s version %s\n", __PACKAGE__, $VERSION;
+ warn "OK, processed args [@args] ...\n";
+ warn sprintf
+ " Verbose: %s\n Index: %s\n Infile: %s\n Outfile: %s\n Title: %s\n",
+ map defined($_) ? $_ : "(nil)",
+ $verbose, $index, $infile, $outfile, $title,
+ ;
+ *Pod::Simple::HTML::DEBUG = sub(){1};
+ }
+ require Pod::Simple::HTML;
+ Pod::Simple::HTML->VERSION(3);
+
+ die "No such input file as $infile\n"
+ if defined $infile and ! -e $infile;
+
+
+ my $pod = Pod::Simple::HTML->new;
+ $pod->force_title($title) if defined $title;
+ $pod->index($index);
+ return $pod->parse_from_file($infile, $outfile);
+}
+
+#--------------------------------------------------------------------------
+
+sub bad_opts { die _help_message(); }
+sub help_message { print STDOUT _help_message() }
+
+#--------------------------------------------------------------------------
+
+sub _help_message {
+
+ join '',
+
+"[", __PACKAGE__, " version ", $VERSION, qq~]
+Usage: pod2html --help --infile=<name> --outfile=<name>
+ --verbose --index --noindex
+
+Options:
+ --help - prints this message.
+ --[no]index - generate an index at the top of the resulting html
+ (default behavior).
+ --infile - filename for the pod to convert (input taken from stdin
+ by default).
+ --outfile - filename for the resulting html file (output sent to
+ stdout by default).
+ --title - title that will appear in resulting html file.
+ --[no]verbose - self-explanatory (off by default).
+
+Note that pod2html is DEPRECATED, and this version implements only
+ some of the options known to older versions.
+For more information, see 'perldoc pod2html'.
+~;
+
+}
+
+1;
+__END__
+
+OVER the underpass! UNDER the overpass! Around the FUTURE and BEYOND REPAIR!!
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm
new file mode 100755
index 00000000000..c219ebd2611
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm
@@ -0,0 +1,174 @@
+
+require 5;
+package Pod::Simple::LinkSection;
+ # Based somewhat dimly on Array::Autojoin
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+use strict;
+use Pod::Simple::BlackBox;
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm
new file mode 100755
index 00000000000..15c63efb780
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm
@@ -0,0 +1,152 @@
+
+require 5;
+package Pod::Simple::Methody;
+use strict;
+use Pod::Simple ();
+use vars qw(@ISA $VERSION);
+$VERSION = '3.13';
+@ISA = ('Pod::Simple');
+
+# Yes, we could use named variables, but I want this to be impose
+# as little an additional performance hit as possible.
+
+sub _handle_element_start {
+ $_[1] =~ tr/-:./__/;
+ ( $_[0]->can( 'start_' . $_[1] )
+ || return
+ )->(
+ $_[0], $_[2]
+ );
+}
+
+sub _handle_text {
+ ( $_[0]->can( 'handle_text' )
+ || return
+ )->(
+ @_
+ );
+}
+
+sub _handle_element_end {
+ $_[1] =~ tr/-:./__/;
+ ( $_[0]->can( 'end_' . $_[1] )
+ || return
+ )->(
+ $_[0]
+ );
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::Methody -- turn Pod::Simple events into method calls
+
+=head1 SYNOPSIS
+
+ require 5;
+ use strict;
+ package SomePodFormatter;
+ use base qw(Pod::Simple::Methody);
+
+ sub handle_text {
+ my($self, $text) = @_;
+ ...
+ }
+
+ sub start_head1 {
+ my($self, $attrs) = @_;
+ ...
+ }
+ sub end_head1 {
+ my($self) = @_;
+ ...
+ }
+
+...and start_/end_ methods for whatever other events you want to catch.
+
+=head1 DESCRIPTION
+
+This class is of
+interest to people writing Pod formatters based on Pod::Simple.
+
+This class (which is very small -- read the source) overrides
+Pod::Simple's _handle_element_start, _handle_text, and
+_handle_element_end methods so that parser events are turned into method
+calls. (Otherwise, this is a subclass of L<Pod::Simple> and inherits all
+its methods.)
+
+You can use this class as the base class for a Pod formatter/processor.
+
+=head1 METHOD CALLING
+
+When Pod::Simple sees a "=head1 Hi there", for example, it basically does
+this:
+
+ $parser->_handle_element_start( "head1", \%attributes );
+ $parser->_handle_text( "Hi there" );
+ $parser->_handle_element_end( "head1" );
+
+But if you subclass Pod::Simple::Methody, it will instead do this
+when it sees a "=head1 Hi there":
+
+ $parser->start_head1( \%attributes ) if $parser->can('start_head1');
+ $parser->handle_text( "Hi there" ) if $parser->can('handle_text');
+ $parser->end_head1() if $parser->can('end_head1');
+
+If Pod::Simple sends an event where the element name has a dash,
+period, or colon, the corresponding method name will have a underscore
+in its place. For example, "foo.bar:baz" becomes start_foo_bar_baz
+and end_foo_bar_baz.
+
+See the source for Pod::Simple::Text for an example of using this class.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm
new file mode 100755
index 00000000000..06b643f3cb9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm
@@ -0,0 +1,93 @@
+
+require 5;
+package Pod::Simple::Progress;
+$VERSION = '3.13';
+use strict;
+
+# Objects of this class are used for noting progress of an
+# operation every so often. Messages delivered more often than that
+# are suppressed.
+#
+# There's actually nothing in here that's specific to Pod processing;
+# but it's ad-hoc enough that I'm not willing to give it a name that
+# implies that it's generally useful, like "IO::Progress" or something.
+#
+# -- sburke
+#
+#--------------------------------------------------------------------------
+
+sub new {
+ my($class,$delay) = @_;
+ my $self = bless {'quiet_until' => 1}, ref($class) || $class;
+ $self->to(*STDOUT{IO});
+ $self->delay(defined($delay) ? $delay : 5);
+ return $self;
+}
+
+sub copy {
+ my $orig = shift;
+ bless {%$orig, 'quiet_until' => 1}, ref($orig);
+}
+#--------------------------------------------------------------------------
+
+sub reach {
+ my($self, $point, $note) = @_;
+ if( (my $now = time) >= $self->{'quiet_until'}) {
+ my $goal;
+ my $to = $self->{'to'};
+ print $to join('',
+ ($self->{'quiet_until'} == 1) ? () : '... ',
+ (defined $point) ? (
+ '#',
+ ($goal = $self->{'goal'}) ? (
+ ' ' x (length($goal) - length($point)),
+ $point, '/', $goal,
+ ) : $point,
+ $note ? ': ' : (),
+ ) : (),
+ $note || '',
+ "\n"
+ );
+ $self->{'quiet_until'} = $now + $self->{'delay'};
+ }
+ return $self;
+}
+
+#--------------------------------------------------------------------------
+
+sub done {
+ my($self, $note) = @_;
+ $self->{'quiet_until'} = 1;
+ return $self->reach( undef, $note );
+}
+
+#--------------------------------------------------------------------------
+# Simple accessors:
+
+sub delay {
+ return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] }
+sub goal {
+ return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] }
+sub to {
+ return $_[0]{'to' } if @_ == 1; $_[0]{'to' } = $_[1]; return $_[0] }
+
+#--------------------------------------------------------------------------
+
+unless(caller) { # Simple self-test:
+ my $p = __PACKAGE__->new->goal(5);
+ $p->reach(1, "Primus!");
+ sleep 1;
+ $p->reach(2, "Secundus!");
+ sleep 3;
+ $p->reach(3, "Tertius!");
+ sleep 5;
+ $p->reach(4);
+ $p->reach(5, "Quintus!");
+ sleep 1;
+ $p->done("All done");
+}
+
+#--------------------------------------------------------------------------
+1;
+__END__
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm
new file mode 100755
index 00000000000..eaef116e646
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm
@@ -0,0 +1,844 @@
+
+require 5;
+package Pod::Simple::PullParser;
+$VERSION = '3.13';
+use Pod::Simple ();
+BEGIN {@ISA = ('Pod::Simple')}
+
+use strict;
+use Carp ();
+
+use Pod::Simple::PullParserStartToken;
+use Pod::Simple::PullParserEndToken;
+use Pod::Simple::PullParserTextToken;
+
+BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
+
+__PACKAGE__->_accessorize(
+ 'source_fh', # the filehandle we're reading from
+ 'source_scalar_ref', # the scalarref we're reading from
+ 'source_arrayref', # the arrayref we're reading from
+);
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# And here is how we implement a pull-parser on top of a push-parser...
+
+sub filter {
+ my($self, $source) = @_;
+ $self = $self->new unless ref $self;
+
+ $source = *STDIN{IO} unless defined $source;
+ $self->set_source($source);
+ $self->output_fh(*STDOUT{IO});
+
+ $self->run; # define run() in a subclass if you want to use filter()!
+ return $self;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+sub parse_string_document {
+ my $this = shift;
+ $this->set_source(\ $_[0]);
+ $this->run;
+}
+
+sub parse_file {
+ my($this, $filename) = @_;
+ $this->set_source($filename);
+ $this->run;
+}
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+# In case anyone tries to use them:
+
+sub run {
+ use Carp ();
+ if( __PACKAGE__ eq ref($_[0]) || $_[0]) { # I'm not being subclassed!
+ Carp::croak "You can call run() only on subclasses of "
+ . __PACKAGE__;
+ } else {
+ Carp::croak join '',
+ "You can't call run() because ",
+ ref($_[0]) || $_[0], " didn't define a run() method";
+ }
+}
+
+sub parse_lines {
+ use Carp ();
+ Carp::croak "Use set_source with ", __PACKAGE__,
+ " and subclasses, not parse_lines";
+}
+
+sub parse_line {
+ use Carp ();
+ Carp::croak "Use set_source with ", __PACKAGE__,
+ " and subclasses, not parse_line";
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ die "Couldn't construct for $class" unless $self;
+
+ $self->{'token_buffer'} ||= [];
+ $self->{'start_token_class'} ||= 'Pod::Simple::PullParserStartToken';
+ $self->{'text_token_class'} ||= 'Pod::Simple::PullParserTextToken';
+ $self->{'end_token_class'} ||= 'Pod::Simple::PullParserEndToken';
+
+ DEBUG > 1 and print "New pullparser object: $self\n";
+
+ return $self;
+}
+
+# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
+
+sub get_token {
+ my $self = shift;
+ DEBUG > 1 and print "\nget_token starting up on $self.\n";
+ DEBUG > 2 and print " Items in token-buffer (",
+ scalar( @{ $self->{'token_buffer'} } ) ,
+ ") :\n", map(
+ " " . $_->dump . "\n", @{ $self->{'token_buffer'} }
+ ),
+ @{ $self->{'token_buffer'} } ? '' : ' (no tokens)',
+ "\n"
+ ;
+
+ until( @{ $self->{'token_buffer'} } ) {
+ DEBUG > 3 and print "I need to get something into my empty token buffer...\n";
+ if($self->{'source_dead'}) {
+ DEBUG and print "$self 's source is dead.\n";
+ push @{ $self->{'token_buffer'} }, undef;
+ } elsif(exists $self->{'source_fh'}) {
+ my @lines;
+ my $fh = $self->{'source_fh'}
+ || Carp::croak('You have to call set_source before you can call get_token');
+
+ DEBUG and print "$self 's source is filehandle $fh.\n";
+ # Read those many lines at a time
+ for(my $i = Pod::Simple::MANY_LINES; $i--;) {
+ DEBUG > 3 and print " Fetching a line from source filehandle $fh...\n";
+ local $/ = $Pod::Simple::NL;
+ push @lines, scalar(<$fh>); # readline
+ DEBUG > 3 and print " Line is: ",
+ defined($lines[-1]) ? $lines[-1] : "<undef>\n";
+ unless( defined $lines[-1] ) {
+ DEBUG and print "That's it for that source fh! Killing.\n";
+ delete $self->{'source_fh'}; # so it can be GC'd
+ last;
+ }
+ # but pass thru the undef, which will set source_dead to true
+
+ # TODO: look to see if $lines[-1] is =encoding, and if so,
+ # do horribly magic things
+
+ }
+
+ if(DEBUG > 8) {
+ print "* I've gotten ", scalar(@lines), " lines:\n";
+ foreach my $l (@lines) {
+ if(defined $l) {
+ print " line {$l}\n";
+ } else {
+ print " line undef\n";
+ }
+ }
+ print "* end of ", scalar(@lines), " lines\n";
+ }
+
+ $self->SUPER::parse_lines(@lines);
+
+ } elsif(exists $self->{'source_arrayref'}) {
+ DEBUG and print "$self 's source is arrayref $self->{'source_arrayref'}, with ",
+ scalar(@{$self->{'source_arrayref'}}), " items left in it.\n";
+
+ DEBUG > 3 and print " Fetching ", Pod::Simple::MANY_LINES, " lines.\n";
+ $self->SUPER::parse_lines(
+ splice @{ $self->{'source_arrayref'} },
+ 0,
+ Pod::Simple::MANY_LINES
+ );
+ unless( @{ $self->{'source_arrayref'} } ) {
+ DEBUG and print "That's it for that source arrayref! Killing.\n";
+ $self->SUPER::parse_lines(undef);
+ delete $self->{'source_arrayref'}; # so it can be GC'd
+ }
+ # to make sure that an undef is always sent to signal end-of-stream
+
+ } elsif(exists $self->{'source_scalar_ref'}) {
+
+ DEBUG and print "$self 's source is scalarref $self->{'source_scalar_ref'}, with ",
+ length(${ $self->{'source_scalar_ref'} }) -
+ (pos(${ $self->{'source_scalar_ref'} }) || 0),
+ " characters left to parse.\n";
+
+ DEBUG > 3 and print " Fetching a line from source-string...\n";
+ if( ${ $self->{'source_scalar_ref'} } =~
+ m/([^\n\r]*)((?:\r?\n)?)/g
+ ) {
+ #print(">> $1\n"),
+ $self->SUPER::parse_lines($1)
+ if length($1) or length($2)
+ or pos( ${ $self->{'source_scalar_ref'} })
+ != length( ${ $self->{'source_scalar_ref'} });
+ # 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).
+ } else { # that's the end. Byebye
+ $self->SUPER::parse_lines(undef);
+ delete $self->{'source_scalar_ref'};
+ DEBUG and print "That's it for that source scalarref! Killing.\n";
+ }
+
+
+ } else {
+ die "What source??";
+ }
+ }
+ DEBUG and print "get_token about to return ",
+ Pod::Simple::pretty( @{$self->{'token_buffer'}}
+ ? $self->{'token_buffer'}[-1] : undef
+ ), "\n";
+ return shift @{$self->{'token_buffer'}}; # that's an undef if empty
+}
+
+use UNIVERSAL ();
+sub unget_token {
+ my $self = shift;
+ DEBUG and print "Ungetting ", scalar(@_), " tokens: ",
+ @_ ? "@_\n" : "().\n";
+ foreach my $t (@_) {
+ Carp::croak "Can't unget that, because it's not a token -- it's undef!"
+ unless defined $t;
+ Carp::croak "Can't unget $t, because it's not a token -- it's a string!"
+ unless ref $t;
+ Carp::croak "Can't unget $t, because it's not a token object!"
+ unless UNIVERSAL::can($t, 'type');
+ }
+
+ unshift @{$self->{'token_buffer'}}, @_;
+ DEBUG > 1 and print "Token buffer now has ",
+ scalar(@{$self->{'token_buffer'}}), " items in it.\n";
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+# $self->{'source_filename'} = $source;
+
+sub set_source {
+ my $self = shift @_;
+ return $self->{'source_fh'} unless @_;
+ my $handle;
+ if(!defined $_[0]) {
+ Carp::croak("Can't use empty-string as a source for set_source");
+ } elsif(ref(\( $_[0] )) eq 'GLOB') {
+ $self->{'source_filename'} = '' . ($handle = $_[0]);
+ DEBUG and print "$self 's source is glob $_[0]\n";
+ # and fall thru
+ } elsif(ref( $_[0] ) eq 'SCALAR') {
+ $self->{'source_scalar_ref'} = $_[0];
+ DEBUG and print "$self 's source is scalar ref $_[0]\n";
+ return;
+ } elsif(ref( $_[0] ) eq 'ARRAY') {
+ $self->{'source_arrayref'} = $_[0];
+ DEBUG and print "$self 's source is array ref $_[0]\n";
+ return;
+ } elsif(ref $_[0]) {
+ $self->{'source_filename'} = '' . ($handle = $_[0]);
+ DEBUG and print "$self 's source is fh-obj $_[0]\n";
+ } elsif(!length $_[0]) {
+ Carp::croak("Can't use empty-string as a source for set_source");
+ } else { # It's a filename!
+ DEBUG and print "$self 's source is filename $_[0]\n";
+ {
+ local *PODSOURCE;
+ open(PODSOURCE, "<$_[0]") || Carp::croak "Can't open $_[0]: $!";
+ $handle = *PODSOURCE{IO};
+ }
+ $self->{'source_filename'} = $_[0];
+ DEBUG and print " Its name is $_[0].\n";
+
+ # TODO: file-discipline things here!
+ }
+
+ $self->{'source_fh'} = $handle;
+ DEBUG and print " Its handle is $handle\n";
+ return 1;
+}
+
+# ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
+
+sub get_title_short { shift->get_short_title(@_) } # alias
+
+sub get_short_title {
+ my $title = shift->get_title(@_);
+ $title = $1 if $title =~ m/^(\S{1,60})\s+--?\s+./s;
+ # turn "Foo::Bar -- bars for your foo" into "Foo::Bar"
+ return $title;
+}
+
+sub get_title { shift->_get_titled_section(
+ 'NAME', max_token => 50, desperate => 1, @_)
+}
+sub get_version { shift->_get_titled_section(
+ 'VERSION',
+ max_token => 400,
+ accept_verbatim => 1,
+ max_content_length => 3_000,
+ @_,
+ );
+}
+sub get_description { shift->_get_titled_section(
+ 'DESCRIPTION',
+ max_token => 400,
+ max_content_length => 3_000,
+ @_,
+) }
+
+sub get_authors { shift->get_author(@_) } # a harmless alias
+
+sub get_author {
+ my $this = shift;
+ # Max_token is so high because these are
+ # typically at the end of the document:
+ $this->_get_titled_section('AUTHOR' , max_token => 10_000, @_) ||
+ $this->_get_titled_section('AUTHORS', max_token => 10_000, @_);
+}
+
+#--------------------------------------------------------------------------
+
+sub _get_titled_section {
+ # Based on a get_title originally contributed by Graham Barr
+ my($self, $titlename, %options) = (@_);
+
+ my $max_token = delete $options{'max_token'};
+ my $desperate_for_title = delete $options{'desperate'};
+ my $accept_verbatim = delete $options{'accept_verbatim'};
+ my $max_content_length = delete $options{'max_content_length'};
+ my $nocase = delete $options{'nocase'};
+ $max_content_length = 120 unless defined $max_content_length;
+
+ Carp::croak( "Unknown " . ((1 == keys %options) ? "option: " : "options: ")
+ . join " ", map "[$_]", sort keys %options
+ )
+ if keys %options;
+
+ my %content_containers;
+ $content_containers{'Para'} = 1;
+ if($accept_verbatim) {
+ $content_containers{'Verbatim'} = 1;
+ $content_containers{'VerbatimFormatted'} = 1;
+ }
+
+ my $token_count = 0;
+ my $title;
+ my @to_unget;
+ my $state = 0;
+ my $depth = 0;
+
+ Carp::croak "What kind of titlename is \"$titlename\"?!" unless
+ defined $titlename and $titlename =~ m/^[A-Z ]{1,60}$/s; #sanity
+ my $titlename_re = quotemeta($titlename);
+
+ my $head1_text_content;
+ my $para_text_content;
+
+ while(
+ ++$token_count <= ($max_token || 1_000_000)
+ and defined(my $token = $self->get_token)
+ ) {
+ push @to_unget, $token;
+
+ if ($state == 0) { # seeking =head1
+ if( $token->is_start and $token->tagname eq 'head1' ) {
+ DEBUG and print " Found head1. Seeking content...\n";
+ ++$state;
+ $head1_text_content = '';
+ }
+ }
+
+ elsif($state == 1) { # accumulating text until end of head1
+ if( $token->is_text ) {
+ DEBUG and print " Adding \"", $token->text, "\" to head1-content.\n";
+ $head1_text_content .= $token->text;
+ } elsif( $token->is_end and $token->tagname eq 'head1' ) {
+ DEBUG and print " Found end of head1. Considering content...\n";
+ $head1_text_content = uc $head1_text_content if $nocase;
+ if($head1_text_content eq $titlename
+ or $head1_text_content =~ m/\($titlename_re\)/s
+ # We accept "=head1 Nomen Modularis (NAME)" for sake of i18n
+ ) {
+ DEBUG and print " Yup, it was $titlename. Seeking next para-content...\n";
+ ++$state;
+ } elsif(
+ $desperate_for_title
+ # if we're so desperate we'll take the first
+ # =head1's content as a title
+ and $head1_text_content =~ m/\S/
+ and $head1_text_content !~ m/^[ A-Z]+$/s
+ and $head1_text_content !~
+ m/\((?:
+ NAME | TITLE | VERSION | AUTHORS? | DESCRIPTION | SYNOPSIS
+ | COPYRIGHT | LICENSE | NOTES? | FUNCTIONS? | METHODS?
+ | CAVEATS? | BUGS? | SEE\ ALSO | SWITCHES | ENVIRONMENT
+ )\)/sx
+ # avoid accepting things like =head1 Thingy Thongy (DESCRIPTION)
+ and ($max_content_length
+ ? (length($head1_text_content) <= $max_content_length) # sanity
+ : 1)
+ ) {
+ DEBUG and print " It looks titular: \"$head1_text_content\".\n",
+ "\n Using that.\n";
+ $title = $head1_text_content;
+ last;
+ } else {
+ --$state;
+ DEBUG and print " Didn't look titular ($head1_text_content).\n",
+ "\n Dropping back to seeking-head1-content mode...\n";
+ }
+ }
+ }
+
+ elsif($state == 2) {
+ # seeking start of para (which must immediately follow)
+ if($token->is_start and $content_containers{ $token->tagname }) {
+ DEBUG and print " Found start of Para. Accumulating content...\n";
+ $para_text_content = '';
+ ++$state;
+ } else {
+ DEBUG and print
+ " Didn't see an immediately subsequent start-Para. Reseeking H1\n";
+ $state = 0;
+ }
+ }
+
+ elsif($state == 3) {
+ # accumulating text until end of Para
+ if( $token->is_text ) {
+ DEBUG and print " Adding \"", $token->text, "\" to para-content.\n";
+ $para_text_content .= $token->text;
+ # and keep looking
+
+ } elsif( $token->is_end and $content_containers{ $token->tagname } ) {
+ DEBUG and print " Found end of Para. Considering content: ",
+ $para_text_content, "\n";
+
+ if( $para_text_content =~ m/\S/
+ and ($max_content_length
+ ? (length($para_text_content) <= $max_content_length)
+ : 1)
+ ) {
+ # Some minimal sanity constraints, I think.
+ DEBUG and print " It looks contentworthy, I guess. Using it.\n";
+ $title = $para_text_content;
+ last;
+ } else {
+ DEBUG and print " Doesn't look at all contentworthy!\n Giving up.\n";
+ undef $title;
+ last;
+ }
+ }
+ }
+
+ else {
+ die "IMPOSSIBLE STATE $state!\n"; # should never happen
+ }
+
+ }
+
+ # Put it all back!
+ $self->unget_token(@to_unget);
+
+ if(DEBUG) {
+ if(defined $title) { print " Returing title <$title>\n" }
+ else { print "Returning title <>\n" }
+ }
+
+ return '' unless defined $title;
+ $title =~ s/^\s+//;
+ return $title;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+#
+# Methods that actually do work at parse-time:
+
+sub _handle_element_start {
+ my $self = shift; # leaving ($element_name, $attr_hash_r)
+ DEBUG > 2 and print "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n";
+
+ push @{ $self->{'token_buffer'} },
+ $self->{'start_token_class'}->new(@_);
+ return;
+}
+
+sub _handle_text {
+ my $self = shift; # leaving ($text)
+ DEBUG > 2 and print "== $_[0]\n";
+ push @{ $self->{'token_buffer'} },
+ $self->{'text_token_class'}->new(@_);
+ return;
+}
+
+sub _handle_element_end {
+ my $self = shift; # leaving ($element_name);
+ DEBUG > 2 and print "-- $_[0]\n";
+ push @{ $self->{'token_buffer'} },
+ $self->{'end_token_class'}->new(@_);
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParser -- a pull-parser interface to parsing Pod
+
+=head1 SYNOPSIS
+
+ my $parser = SomePodProcessor->new;
+ $parser->set_source( "whatever.pod" );
+ $parser->run;
+
+Or:
+
+ my $parser = SomePodProcessor->new;
+ $parser->set_source( $some_filehandle_object );
+ $parser->run;
+
+Or:
+
+ my $parser = SomePodProcessor->new;
+ $parser->set_source( \$document_source );
+ $parser->run;
+
+Or:
+
+ my $parser = SomePodProcessor->new;
+ $parser->set_source( \@document_lines );
+ $parser->run;
+
+And elsewhere:
+
+ require 5;
+ package SomePodProcessor;
+ use strict;
+ use base qw(Pod::Simple::PullParser);
+
+ sub run {
+ my $self = shift;
+ Token:
+ while(my $token = $self->get_token) {
+ ...process each token...
+ }
+ }
+
+=head1 DESCRIPTION
+
+This class is for using Pod::Simple to build a Pod processor -- but
+one that uses an interface based on a stream of token objects,
+instead of based on events.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+A subclass of Pod::Simple::PullParser should define a C<run> method
+that calls C<< $token = $parser->get_token >> to pull tokens.
+
+See the source for Pod::Simple::RTF for an example of a formatter
+that uses Pod::Simple::PullParser.
+
+=head1 METHODS
+
+=over
+
+=item my $token = $parser->get_token
+
+This returns the next token object (which will be of a subclass of
+L<Pod::Simple::PullParserToken>), or undef if the parser-stream has hit
+the end of the document.
+
+=item $parser->unget_token( $token )
+
+=item $parser->unget_token( $token1, $token2, ... )
+
+This restores the token object(s) to the front of the parser stream.
+
+=back
+
+The source has to be set before you can parse anything. The lowest-level
+way is to call C<set_source>:
+
+=over
+
+=item $parser->set_source( $filename )
+
+=item $parser->set_source( $filehandle_object )
+
+=item $parser->set_source( \$document_source )
+
+=item $parser->set_source( \@document_lines )
+
+=back
+
+Or you can call these methods, which Pod::Simple::PullParser has defined
+to work just like Pod::Simple's same-named methods:
+
+=over
+
+=item $parser->parse_file(...)
+
+=item $parser->parse_string_document(...)
+
+=item $parser->filter(...)
+
+=item $parser->parse_from_file(...)
+
+=back
+
+For those to work, the Pod-processing subclass of
+Pod::Simple::PullParser has to have defined a $parser->run method --
+so it is advised that all Pod::Simple::PullParser subclasses do so.
+See the Synopsis above, or the source for Pod::Simple::RTF.
+
+Authors of formatter subclasses might find these methods useful to
+call on a parser object that you haven't started pulling tokens
+from yet:
+
+=over
+
+=item my $title_string = $parser->get_title
+
+This tries to get the title string out of $parser, by getting some tokens,
+and scanning them for the title, and then ungetting them so that you can
+process the token-stream from the beginning.
+
+For example, suppose you have a document that starts out:
+
+ =head1 NAME
+
+ Hoo::Boy::Wowza -- Stuff B<wow> yeah!
+
+$parser->get_title on that document will return "Hoo::Boy::Wowza --
+Stuff wow yeah!". If the document starts with:
+
+ =head1 Name
+
+ Hoo::Boy::W00t -- Stuff B<w00t> yeah!
+
+Then you'll need to pass the C<nocase> option in order to recognize "Name":
+
+ $parser->get_title(nocase => 1);
+
+In cases where get_title can't find the title, it will return empty-string
+("").
+
+=item my $title_string = $parser->get_short_title
+
+This is just like get_title, except that it returns just the modulename, if
+the title seems to be of the form "SomeModuleName -- description".
+
+For example, suppose you have a document that starts out:
+
+ =head1 NAME
+
+ Hoo::Boy::Wowza -- Stuff B<wow> yeah!
+
+then $parser->get_short_title on that document will return
+"Hoo::Boy::Wowza".
+
+But if the document starts out:
+
+ =head1 NAME
+
+ Hooboy, stuff B<wow> yeah!
+
+then $parser->get_short_title on that document will return "Hooboy,
+stuff wow yeah!". If the document starts with:
+
+ =head1 Name
+
+ Hoo::Boy::W00t -- Stuff B<w00t> yeah!
+
+Then you'll need to pass the C<nocase> option in order to recognize "Name":
+
+ $parser->get_short_title(nocase => 1);
+
+If the title can't be found, then get_short_title returns empty-string
+("").
+
+=item $author_name = $parser->get_author
+
+This works like get_title except that it returns the contents of the
+"=head1 AUTHOR\n\nParagraph...\n" section, assuming that that section
+isn't terribly long. To recognize a "=head1 Author\n\nParagraph\n"
+section, pass the C<nocase> otpion:
+
+ $parser->get_author(nocase => 1);
+
+(This method tolerates "AUTHORS" instead of "AUTHOR" too.)
+
+=item $description_name = $parser->get_description
+
+This works like get_title except that it returns the contents of the
+"=head1 DESCRIPTION\n\nParagraph...\n" section, assuming that that section
+isn't terribly long. To recognize a "=head1 Description\n\nParagraph\n"
+section, pass the C<nocase> otpion:
+
+ $parser->get_description(nocase => 1);
+
+=item $version_block = $parser->get_version
+
+This works like get_title except that it returns the contents of
+the "=head1 VERSION\n\n[BIG BLOCK]\n" block. Note that this does NOT
+return the module's C<$VERSION>!! To recognize a
+"=head1 Version\n\n[BIG BLOCK]\n" section, pass the C<nocase> otpion:
+
+ $parser->get_version(nocase => 1);
+
+=back
+
+=head1 NOTE
+
+You don't actually I<have> to define a C<run> method. If you're
+writing a Pod-formatter class, you should define a C<run> just so
+that users can call C<parse_file> etc, but you don't I<have> to.
+
+And if you're not writing a formatter class, but are instead just
+writing a program that does something simple with a Pod::PullParser
+object (and not an object of a subclass), then there's no reason to
+bother subclassing to add a C<run> method.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>
+
+L<Pod::Simple::PullParserToken> -- and its subclasses
+L<Pod::Simple::PullParserStartToken>,
+L<Pod::Simple::PullParserTextToken>, and
+L<Pod::Simple::PullParserEndToken>.
+
+L<HTML::TokeParser>, which inspired this.
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
+JUNK:
+
+sub _old_get_title { # some witchery in here
+ my $self = $_[0];
+ my $title;
+ my @to_unget;
+
+ while(1) {
+ push @to_unget, $self->get_token;
+ unless(defined $to_unget[-1]) { # whoops, short doc!
+ pop @to_unget;
+ last;
+ }
+
+ DEBUG and print "-Got token ", $to_unget[-1]->dump, "\n";
+
+ (DEBUG and print "Too much in the buffer.\n"),
+ last if @to_unget > 25; # sanity
+
+ my $pattern = '';
+ if( #$to_unget[-1]->type eq 'end'
+ #and $to_unget[-1]->tagname eq 'Para'
+ #and
+ ($pattern = join('',
+ map {;
+ ($_->type eq 'start') ? ("<" . $_->tagname .">")
+ : ($_->type eq 'end' ) ? ("</". $_->tagname .">")
+ : ($_->type eq 'text' ) ? ($_->text =~ m<^([A-Z]+)$>s ? $1 : 'X')
+ : "BLORP"
+ } @to_unget
+ )) =~ m{<head1>NAME</head1><Para>(X|</?[BCIFLS]>)+</Para>$}s
+ ) {
+ # Whee, it fits the pattern
+ DEBUG and print "Seems to match =head1 NAME pattern.\n";
+ $title = '';
+ foreach my $t (reverse @to_unget) {
+ last if $t->type eq 'start' and $t->tagname eq 'Para';
+ $title = $t->text . $title if $t->type eq 'text';
+ }
+ undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
+ last;
+
+ } elsif ($pattern =~ m{<head(\d)>(.+)</head\d>$}
+ and !( $1 eq '1' and $2 eq 'NAME' )
+ ) {
+ # Well, it fits a fallback pattern
+ DEBUG and print "Seems to match NAMEless pattern.\n";
+ $title = '';
+ foreach my $t (reverse @to_unget) {
+ last if $t->type eq 'start' and $t->tagname =~ m/^head\d$/s;
+ $title = $t->text . $title if $t->type eq 'text';
+ }
+ undef $title if $title =~ m<^\s*$>; # make sure it's contentful!
+ last;
+
+ } else {
+ DEBUG and $pattern and print "Leading pattern: $pattern\n";
+ }
+ }
+
+ # Put it all back:
+ $self->unget_token(@to_unget);
+
+ if(DEBUG) {
+ if(defined $title) { print " Returing title <$title>\n" }
+ else { print "Returning title <>\n" }
+ }
+
+ return '' unless defined $title;
+ return $title;
+}
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm
new file mode 100755
index 00000000000..2c32bd805b8
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm
@@ -0,0 +1,120 @@
+
+require 5;
+package Pod::Simple::PullParserEndToken;
+use Pod::Simple::PullParserToken ();
+use strict;
+use vars qw(@ISA $VERSION);
+@ISA = ('Pod::Simple::PullParserToken');
+$VERSION = '3.13';
+
+sub new { # Class->new(tagname);
+ my $class = shift;
+ return bless ['end', @_], ref($class) || $class;
+}
+
+# Purely accessors:
+
+sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
+sub tag { shift->tagname(@_) }
+
+# shortcut:
+sub is_tagname { $_[0][1] eq $_[1] }
+sub is_tag { shift->is_tagname(@_) }
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParserEndToken -- end-tokens from Pod::Simple::PullParser
+
+=head1 SYNOPSIS
+
+(See L<Pod::Simple::PullParser>)
+
+=head1 DESCRIPTION
+
+When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
+get an object of this class.
+
+This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
+and adds these methods:
+
+=over
+
+=item $token->tagname
+
+This returns the tagname for this end-token object.
+For example, parsing a "=head1 ..." line will give you
+a start-token with the tagname of "head1", token(s) for its
+content, and then an end-token with the tagname of "head1".
+
+=item $token->tagname(I<somestring>)
+
+This changes the tagname for this end-token object.
+You probably won't need to do this.
+
+=item $token->tag(...)
+
+A shortcut for $token->tagname(...)
+
+=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
+
+These are shortcuts for C<< $token->tag() eq I<somestring> >>
+
+=back
+
+You're unlikely to ever need to construct an object of this class for
+yourself, but if you want to, call
+C<<
+Pod::Simple::PullParserEndToken->new( I<tagname> )
+>>
+
+=head1 SEE ALSO
+
+L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm
new file mode 100755
index 00000000000..39802641896
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm
@@ -0,0 +1,161 @@
+
+require 5;
+package Pod::Simple::PullParserStartToken;
+use Pod::Simple::PullParserToken ();
+use strict;
+use vars qw(@ISA $VERSION);
+@ISA = ('Pod::Simple::PullParserToken');
+$VERSION = '3.13';
+
+sub new { # Class->new(tagname, optional_attrhash);
+ my $class = shift;
+ return bless ['start', @_], ref($class) || $class;
+}
+
+# Purely accessors:
+
+sub tagname { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
+sub tag { shift->tagname(@_) }
+
+sub is_tagname { $_[0][1] eq $_[1] }
+sub is_tag { shift->is_tagname(@_) }
+
+
+sub attr_hash { $_[0][2] ||= {} }
+
+sub attr {
+ if(@_ == 2) { # Reading: $token->attr('attrname')
+ ${$_[0][2] || return undef}{ $_[1] };
+ } elsif(@_ > 2) { # Writing: $token->attr('attrname', 'newval')
+ ${$_[0][2] ||= {}}{ $_[1] } = $_[2];
+ } else {
+ require Carp;
+ Carp::croak(
+ 'usage: $object->attr("val") or $object->attr("key", "newval")');
+ return undef;
+ }
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParserStartToken -- start-tokens from Pod::Simple::PullParser
+
+=head1 SYNOPSIS
+
+(See L<Pod::Simple::PullParser>)
+
+=head1 DESCRIPTION
+
+When you do $parser->get_token on a L<Pod::Simple::PullParser> object, you might
+get an object of this class.
+
+This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
+and adds these methods:
+
+=over
+
+=item $token->tagname
+
+This returns the tagname for this start-token object.
+For example, parsing a "=head1 ..." line will give you
+a start-token with the tagname of "head1", token(s) for its
+content, and then an end-token with the tagname of "head1".
+
+=item $token->tagname(I<somestring>)
+
+This changes the tagname for this start-token object.
+You probably won't need
+to do this.
+
+=item $token->tag(...)
+
+A shortcut for $token->tagname(...)
+
+=item $token->is_tag(I<somestring>) or $token->is_tagname(I<somestring>)
+
+These are shortcuts for C<< $token->tag() eq I<somestring> >>
+
+=item $token->attr(I<attrname>)
+
+This returns the value of the I<attrname> attribute for this start-token
+object, or undef.
+
+For example, parsing a LZ<><Foo/"Bar"> link will produce a start-token
+with a "to" attribute with the value "Foo", a "type" attribute with the
+value "pod", and a "section" attribute with the value "Bar".
+
+=item $token->attr(I<attrname>, I<newvalue>)
+
+This sets the I<attrname> attribute for this start-token object to
+I<newvalue>. You probably won't need to do this.
+
+=item $token->attr_hash
+
+This returns the hashref that is the attribute set for this start-token.
+This is useful if (for example) you want to ask what all the attributes
+are -- you can just do C<< keys %{$token->attr_hash} >>
+
+=back
+
+
+You're unlikely to ever need to construct an object of this class for
+yourself, but if you want to, call
+C<<
+Pod::Simple::PullParserStartToken->new( I<tagname>, I<attrhash> )
+>>
+
+=head1 SEE ALSO
+
+L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=head1 SEE ALSO
+
+L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm
new file mode 100755
index 00000000000..f33fc6e9438
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm
@@ -0,0 +1,128 @@
+
+require 5;
+package Pod::Simple::PullParserTextToken;
+use Pod::Simple::PullParserToken ();
+use strict;
+use vars qw(@ISA $VERSION);
+@ISA = ('Pod::Simple::PullParserToken');
+$VERSION = '3.13';
+
+sub new { # Class->new(text);
+ my $class = shift;
+ return bless ['text', @_], ref($class) || $class;
+}
+
+# Purely accessors:
+
+sub text { (@_ == 2) ? ($_[0][1] = $_[1]) : $_[0][1] }
+
+sub text_r { \ $_[0][1] }
+
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParserTextToken -- text-tokens from Pod::Simple::PullParser
+
+=head1 SYNOPSIS
+
+(See L<Pod::Simple::PullParser>)
+
+=head1 DESCRIPTION
+
+When you do $parser->get_token on a L<Pod::Simple::PullParser>, you might
+get an object of this class.
+
+This is a subclass of L<Pod::Simple::PullParserToken> and inherits all its methods,
+and adds these methods:
+
+=over
+
+=item $token->text
+
+This returns the text that this token holds. For example, parsing
+CZ<><foo> will return a C start-token, a text-token, and a C end-token. And
+if you want to get the "foo" out of the text-token, call C<< $token->text >>
+
+=item $token->text(I<somestring>)
+
+This changes the string that this token holds. You probably won't need
+to do this.
+
+=item $token->text_r()
+
+This returns a scalar reference to the string that this token holds.
+This can be useful if you don't want to memory-copy the potentially
+large text value (well, as large as a paragraph or a verbatim block)
+as calling $token->text would do.
+
+Or, if you want to alter the value, you can even do things like this:
+
+ for ( ${ $token->text_r } ) { # Aliases it with $_ !!
+
+ s/ The / the /g; # just for example
+
+ if( 'A' eq chr(65) ) { # (if in an ASCII world)
+ tr/\xA0/ /;
+ tr/\xAD//d;
+ }
+
+ ...or however you want to alter the value...
+ }
+
+=back
+
+You're unlikely to ever need to construct an object of this class for
+yourself, but if you want to, call
+C<<
+Pod::Simple::PullParserTextToken->new( I<text> )
+>>
+
+=head1 SEE ALSO
+
+L<Pod::Simple::PullParserToken>, L<Pod::Simple>, L<Pod::Simple::Subclassing>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm
new file mode 100755
index 00000000000..3a156b442bd
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm
@@ -0,0 +1,163 @@
+
+require 5;
+package Pod::Simple::PullParserToken;
+ # Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token
+@ISA = ();
+$VERSION = '3.13';
+use strict;
+
+sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway
+ my $class = shift;
+ return bless [@_], ref($class) || $class;
+}
+
+sub type { $_[0][0] } # Can't change the type of an object
+sub dump { Pod::Simple::pretty( [ @{ $_[0] } ] ) }
+
+sub is_start { $_[0][0] eq 'start' }
+sub is_end { $_[0][0] eq 'end' }
+sub is_text { $_[0][0] eq 'text' }
+
+1;
+__END__
+
+sub dump { '[' . _esc( @{ $_[0] } ) . ']' }
+
+# JUNK:
+
+sub _esc {
+ return '' unless @_;
+ my @out;
+ foreach my $in (@_) {
+ push @out, '"' . $in . '"';
+ $out[-1] =~ s/([^- \:\:\.\,\'\>\<\"\/\=\?\+\|\[\]\{\}\_a-zA-Z0-9_\`\~\!\#\%\^\&\*\(\)])/
+ sprintf( (ord($1) < 256) ? "\\x%02X" : "\\x{%X}", ord($1))
+ /eg;
+ }
+ return join ', ', @out;
+}
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::PullParserToken -- tokens from Pod::Simple::PullParser
+
+=head1 SYNOPSIS
+
+Given a $parser that's an object of class Pod::Simple::PullParser
+(or a subclass)...
+
+ while(my $token = $parser->get_token) {
+ $DEBUG and print "Token: ", $token->dump, "\n";
+ if($token->is_start) {
+ ...access $token->tagname, $token->attr, etc...
+
+ } elsif($token->is_text) {
+ ...access $token->text, $token->text_r, etc...
+
+ } elsif($token->is_end) {
+ ...access $token->tagname...
+
+ }
+ }
+
+(Also see L<Pod::Simple::PullParser>)
+
+=head1 DESCRIPTION
+
+When you do $parser->get_token on a L<Pod::Simple::PullParser>, you should
+get an object of a subclass of Pod::Simple::PullParserToken.
+
+Subclasses will add methods, and will also inherit these methods:
+
+=over
+
+=item $token->type
+
+This returns the type of the token. This will be either the string
+"start", the string "text", or the string "end".
+
+Once you know what the type of an object is, you then know what
+subclass it belongs to, and therefore what methods it supports.
+
+Yes, you could probably do the same thing with code like
+$token->isa('Pod::Simple::PullParserEndToken'), but that's not so
+pretty as using just $token->type, or even the following shortcuts:
+
+=item $token->is_start
+
+This is a shortcut for C<< $token->type() eq "start" >>
+
+=item $token->is_text
+
+This is a shortcut for C<< $token->type() eq "text" >>
+
+=item $token->is_end
+
+This is a shortcut for C<< $token->type() eq "end" >>
+
+=item $token->dump
+
+This returns a handy stringified value of this object. This
+is useful for debugging, as in:
+
+ while(my $token = $parser->get_token) {
+ $DEBUG and print "Token: ", $token->dump, "\n";
+ ...
+ }
+
+=back
+
+=head1 SEE ALSO
+
+My subclasses:
+L<Pod::Simple::PullParserStartToken>,
+L<Pod::Simple::PullParserTextToken>, and
+L<Pod::Simple::PullParserEndToken>.
+
+L<Pod::Simple::PullParser> and 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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm
new file mode 100755
index 00000000000..b89eac047a4
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm
@@ -0,0 +1,699 @@
+
+require 5;
+package Pod::Simple::RTF;
+
+#sub DEBUG () {4};
+#sub Pod::Simple::DEBUG () {4};
+#sub Pod::Simple::PullParser::DEBUG () {4};
+
+use strict;
+use vars qw($VERSION @ISA %Escape $WRAP %Tagmap);
+$VERSION = '3.13';
+use Pod::Simple::PullParser ();
+BEGIN {@ISA = ('Pod::Simple::PullParser')}
+
+use Carp ();
+BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG }
+
+$WRAP = 1 unless defined $WRAP;
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub _openclose {
+ return map {;
+ m/^([-A-Za-z]+)=(\w[^\=]*)$/s or die "what's <$_>?";
+ ( $1, "{\\$2\n", "/$1", "}" );
+ } @_;
+}
+
+my @_to_accept;
+
+%Tagmap = (
+ # 'foo=bar' means ('foo' => '{\bar'."\n", '/foo' => '}')
+ _openclose(
+ 'B=cs18\b',
+ 'I=cs16\i',
+ 'C=cs19\f1\lang1024\noproof',
+ 'F=cs17\i\lang1024\noproof',
+
+ 'VerbatimI=cs26\i',
+ 'VerbatimB=cs27\b',
+ 'VerbatimBI=cs28\b\i',
+
+ map {; m/^([-a-z]+)/s && push @_to_accept, $1; $_ }
+ qw[
+ underline=ul smallcaps=scaps shadow=shad
+ superscript=super subscript=sub strikethrough=strike
+ outline=outl emboss=embo engrave=impr
+ dotted-underline=uld dash-underline=uldash
+ dot-dash-underline=uldashd dot-dot-dash-underline=uldashdd
+ double-underline=uldb thick-underline=ulth
+ word-underline=ulw wave-underline=ulwave
+ ]
+ # But no double-strikethrough, because MSWord can't agree with the
+ # RTF spec on whether it's supposed to be \strikedl or \striked1 (!!!)
+ ),
+
+ # Bit of a hack here:
+ 'L=pod' => '{\cs22\i'."\n",
+ 'L=url' => '{\cs23\i'."\n",
+ 'L=man' => '{\cs24\i'."\n",
+ '/L' => '}',
+
+ 'Data' => "\n",
+ '/Data' => "\n",
+
+ 'Verbatim' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
+ '/Verbatim' => "\n\\par}\n",
+ 'VerbatimFormatted' => "\n{\\pard\\li#rtfindent##rtfkeep#\\plain\\s20\\sa180\\f1\\fs18\\lang1024\\noproof\n",
+ '/VerbatimFormatted' => "\n\\par}\n",
+ 'Para' => "\n{\\pard\\li#rtfindent#\\sa180\n",
+ '/Para' => "\n\\par}\n",
+ 'head1' => "\n{\\pard\\li#rtfindent#\\s31\\keepn\\sb90\\sa180\\f2\\fs#head1_halfpoint_size#\\ul{\n",
+ '/head1' => "\n}\\par}\n",
+ 'head2' => "\n{\\pard\\li#rtfindent#\\s32\\keepn\\sb90\\sa180\\f2\\fs#head2_halfpoint_size#\\ul{\n",
+ '/head2' => "\n}\\par}\n",
+ 'head3' => "\n{\\pard\\li#rtfindent#\\s33\\keepn\\sb90\\sa180\\f2\\fs#head3_halfpoint_size#\\ul{\n",
+ '/head3' => "\n}\\par}\n",
+ 'head4' => "\n{\\pard\\li#rtfindent#\\s34\\keepn\\sb90\\sa180\\f2\\fs#head4_halfpoint_size#\\ul{\n",
+ '/head4' => "\n}\\par}\n",
+ # wordpad borks on \tc\tcl1, or I'd put that in =head1 and =head2
+
+ 'item-bullet' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
+ '/item-bullet' => "\n\\par}\n",
+ 'item-number' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
+ '/item-number' => "\n\\par}\n",
+ 'item-text' => "\n{\\pard\\li#rtfindent##rtfitemkeepn#\\sb60\\sa150\\fi-120\n",
+ '/item-text' => "\n\\par}\n",
+
+ # we don't need any styles for over-* and /over-*
+);
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub new {
+ my $new = shift->SUPER::new(@_);
+ $new->nix_X_codes(1);
+ $new->nbsp_for_S(1);
+ $new->accept_targets( 'rtf', 'RTF' );
+
+ $new->{'Tagmap'} = {%Tagmap};
+
+ $new->accept_codes(@_to_accept);
+ $new->accept_codes('VerbatimFormatted');
+ DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n";
+ $new->doc_lang(
+ ( $ENV{'RTFDEFLANG'} || '') =~ m/^(\d{1,10})$/s ? $1
+ : ($ENV{'RTFDEFLANG'} || '') =~ m/^0?x([a-fA-F0-9]{1,10})$/s ? hex($1)
+ # yes, tolerate hex!
+ : ($ENV{'RTFDEFLANG'} || '') =~ m/^([a-fA-F0-9]{4})$/s ? hex($1)
+ # yes, tolerate even more hex!
+ : '1033'
+ );
+
+ $new->head1_halfpoint_size(32);
+ $new->head2_halfpoint_size(28);
+ $new->head3_halfpoint_size(25);
+ $new->head4_halfpoint_size(22);
+ $new->codeblock_halfpoint_size(18);
+ $new->header_halfpoint_size(17);
+ $new->normal_halfpoint_size(25);
+
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+__PACKAGE__->_accessorize(
+ 'doc_lang',
+ 'head1_halfpoint_size',
+ 'head2_halfpoint_size',
+ 'head3_halfpoint_size',
+ 'head4_halfpoint_size',
+ 'codeblock_halfpoint_size',
+ 'header_halfpoint_size',
+ 'normal_halfpoint_size',
+ 'no_proofing_exemptions',
+);
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub run {
+ my $self = $_[0];
+ return $self->do_middle if $self->bare_output;
+ return
+ $self->do_beginning && $self->do_middle && $self->do_end;
+}
+
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub do_middle { # the main work
+ my $self = $_[0];
+ my $fh = $self->{'output_fh'};
+
+ my($token, $type, $tagname, $scratch);
+ my @stack;
+ my @indent_stack;
+ $self->{'rtfindent'} = 0 unless defined $self->{'rtfindent'};
+
+ while($token = $self->get_token) {
+
+ if( ($type = $token->type) eq 'text' ) {
+ if( $self->{'rtfverbatim'} ) {
+ DEBUG > 1 and print " $type " , $token->text, " in verbatim!\n";
+ rtf_esc_codely($scratch = $token->text);
+ print $fh $scratch;
+ next;
+ }
+
+ DEBUG > 1 and print " $type " , $token->text, "\n";
+
+ $scratch = $token->text;
+ $scratch =~ tr/\t\cb\cc/ /d;
+
+ $self->{'no_proofing_exemptions'} or $scratch =~
+ s/(?:
+ ^
+ |
+ (?<=[\cm\cj\t "\[\<\(])
+ ) # start on whitespace, sequence-start, or quote
+ ( # something looking like a Perl token:
+ (?:
+ [\$\@\:\<\*\\_]\S+ # either starting with a sigil, etc.
+ )
+ |
+ # or starting alpha, but containing anything strange:
+ (?:
+ [a-zA-Z'\x80-\xFF]+[\$\@\:_<>\(\\\*]\S+
+ )
+ )
+ /\cb$1\cc/xsg
+ ;
+
+ rtf_esc($scratch);
+ $scratch =~
+ s/(
+ [^\cm\cj\n]{65} # Snare 65 characters from a line
+ [^\cm\cj\n\x20]{0,50} # and finish any current word
+ )
+ (\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end
+ /$1$2\n/gx # and put a NL before those spaces
+ if $WRAP;
+ # This may wrap at well past the 65th column, but not past the 120th.
+
+ print $fh $scratch;
+
+ } elsif( $type eq 'start' ) {
+ DEBUG > 1 and print " +$type ",$token->tagname,
+ " (", map("<$_> ", %{$token->attr_hash}), ")\n";
+
+ if( ($tagname = $token->tagname) eq 'Verbatim'
+ or $tagname eq 'VerbatimFormatted'
+ ) {
+ ++$self->{'rtfverbatim'};
+ my $next = $self->get_token;
+ next unless defined $next;
+ my $line_count = 1;
+ if($next->type eq 'text') {
+ my $t = $next->text_r;
+ while( $$t =~ m/$/mg ) {
+ last if ++$line_count > 15; # no point in counting further
+ }
+ DEBUG > 3 and print " verbatim line count: $line_count\n";
+ }
+ $self->unget_token($next);
+ $self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ;
+
+ } elsif( $tagname =~ m/^item-/s ) {
+ my @to_unget;
+ my $text_count_here = 0;
+ $self->{'rtfitemkeepn'} = '';
+ # Some heuristics to stop item-*'s functioning as subheadings
+ # from getting split from the things they're subheadings for.
+ #
+ # It's not terribly pretty, but it really does make things pretty.
+ #
+ while(1) {
+ push @to_unget, $self->get_token;
+ pop(@to_unget), last unless defined $to_unget[-1];
+ # Erroneously used to be "unshift" instead of pop! Adds instead
+ # of removes, and operates on the beginning instead of the end!
+
+ if($to_unget[-1]->type eq 'text') {
+ if( ($text_count_here += length ${$to_unget[-1]->text_r}) > 150 ){
+ DEBUG > 1 and print " item-* is too long to be keepn'd.\n";
+ last;
+ }
+ } elsif (@to_unget > 1 and
+ $to_unget[-2]->type eq 'end' and
+ $to_unget[-2]->tagname =~ m/^item-/s
+ ) {
+ # Bail out here, after setting rtfitemkeepn yea or nay.
+ $self->{'rtfitemkeepn'} = '\keepn' if
+ $to_unget[-1]->type eq 'start' and
+ $to_unget[-1]->tagname eq 'Para';
+
+ DEBUG > 1 and printf " item-* before %s(%s) %s keepn'd.\n",
+ $to_unget[-1]->type,
+ $to_unget[-1]->can('tagname') ? $to_unget[-1]->tagname : '',
+ $self->{'rtfitemkeepn'} ? "gets" : "doesn't get";
+ last;
+ } elsif (@to_unget > 40) {
+ DEBUG > 1 and print " item-* now has too many tokens (",
+ scalar(@to_unget),
+ (DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (),
+ ") to be keepn'd.\n";
+ last; # give up
+ }
+ # else keep while'ing along
+ }
+ # Now put it aaaaall back...
+ $self->unget_token(@to_unget);
+
+ } elsif( $tagname =~ m/^over-/s ) {
+ push @stack, $1;
+ push @indent_stack,
+ int($token->attr('indent') * 4 * $self->normal_halfpoint_size);
+ DEBUG and print "Indenting over $indent_stack[-1] twips.\n";
+ $self->{'rtfindent'} += $indent_stack[-1];
+
+ } elsif ($tagname eq 'L') {
+ $tagname .= '=' . ($token->attr('type') || 'pod');
+
+ } elsif ($tagname eq 'Data') {
+ my $next = $self->get_token;
+ next unless defined $next;
+ unless( $next->type eq 'text' ) {
+ $self->unget_token($next);
+ next;
+ }
+ DEBUG and print " raw text ", $next->text, "\n";
+ printf $fh "\n" . $next->text . "\n";
+ next;
+ }
+
+ defined($scratch = $self->{'Tagmap'}{$tagname}) or next;
+ $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
+ print $fh $scratch;
+
+ if ($tagname eq 'item-number') {
+ print $fh $token->attr('number'), ". \n";
+ } elsif ($tagname eq 'item-bullet') {
+ print $fh "\\'95 \n";
+ #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}");
+ }
+
+ } elsif( $type eq 'end' ) {
+ DEBUG > 1 and print " -$type ",$token->tagname,"\n";
+ if( ($tagname = $token->tagname) =~ m/^over-/s ) {
+ DEBUG and print "Indenting back $indent_stack[-1] twips.\n";
+ $self->{'rtfindent'} -= pop @indent_stack;
+ pop @stack;
+ } elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') {
+ --$self->{'rtfverbatim'};
+ }
+ defined($scratch = $self->{'Tagmap'}{"/$tagname"}) or next;
+ $scratch =~ s/\#([^\#]+)\#/${$self}{$1}/g; # interpolate
+ print $fh $scratch;
+ }
+ }
+ return 1;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+sub do_beginning {
+ my $self = $_[0];
+ my $fh = $self->{'output_fh'};
+ return print $fh join '',
+ $self->doc_init,
+ $self->font_table,
+ $self->stylesheet,
+ $self->color_table,
+ $self->doc_info,
+ $self->doc_start,
+ "\n"
+ ;
+}
+
+sub do_end {
+ my $self = $_[0];
+ my $fh = $self->{'output_fh'};
+ return print $fh '}'; # that should do it
+}
+
+###########################################################################
+
+sub stylesheet {
+ return sprintf <<'END',
+{\stylesheet
+{\snext0 Normal;}
+{\*\cs10 \additive Default Paragraph Font;}
+{\*\cs16 \additive \i \sbasedon10 pod-I;}
+{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;}
+{\*\cs18 \additive \b \sbasedon10 pod-B;}
+{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;}
+{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs%s\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;}
+{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;}
+{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;}
+{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;}
+{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;}
+
+{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;}
+{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;}
+{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;}
+{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;}
+
+{\s31\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head1;}
+{\s32\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head2;}
+{\s33\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head3;}
+{\s34\ql \keepn\sb90\sa180\f2\fs%s\ul\sbasedon0 \snext0 pod-head4;}
+}
+
+END
+
+ $_[0]->codeblock_halfpoint_size(),
+ $_[0]->head1_halfpoint_size(),
+ $_[0]->head2_halfpoint_size(),
+ $_[0]->head3_halfpoint_size(),
+ $_[0]->head4_halfpoint_size(),
+ ;
+}
+
+###########################################################################
+# Override these as necessary for further customization
+
+sub font_table {
+ return <<'END'; # text font, code font, heading font
+{\fonttbl
+{\f0\froman Times New Roman;}
+{\f1\fmodern Courier New;}
+{\f2\fswiss Arial;}
+}
+
+END
+}
+
+sub doc_init {
+ return <<'END';
+{\rtf1\ansi\deff0
+
+END
+}
+
+sub color_table {
+ return <<'END';
+{\colortbl;\red255\green0\blue0;\red0\green0\blue255;}
+END
+}
+
+
+sub doc_info {
+ my $self = $_[0];
+
+ my $class = ref($self) || $self;
+
+ my $tag = __PACKAGE__ . ' ' . $VERSION;
+
+ unless($class eq __PACKAGE__) {
+ $tag = " ($tag)";
+ $tag = " v" . $self->VERSION . $tag if defined $self->VERSION;
+ $tag = $class . $tag;
+ }
+
+ return sprintf <<'END',
+{\info{\doccomm
+%s
+ using %s v%s
+ under Perl v%s at %s GMT}
+{\author [see doc]}{\company [see doc]}{\operator [see doc]}
+}
+
+END
+
+ # None of the following things should need escaping, I dare say!
+ $tag,
+ $ISA[0], $ISA[0]->VERSION(),
+ $], scalar(gmtime),
+ ;
+}
+
+sub doc_start {
+ my $self = $_[0];
+ my $title = $self->get_short_title();
+ DEBUG and print "Short Title: <$title>\n";
+ $title .= ' ' if length $title;
+
+ $title =~ s/ *$/ /s;
+ $title =~ s/^ //s;
+ $title =~ s/ $/, /s;
+ # make sure it ends in a comma and a space, unless it's 0-length
+
+ my $is_obviously_module_name;
+ $is_obviously_module_name = 1
+ if $title =~ m/^\S+$/s and $title =~ m/::/s;
+ # catches the most common case, at least
+
+ DEBUG and print "Title0: <$title>\n";
+ $title = rtf_esc($title);
+ DEBUG and print "Title1: <$title>\n";
+ $title = '\lang1024\noproof ' . $title
+ if $is_obviously_module_name;
+
+ return sprintf <<'END',
+\deflang%s\plain\lang%s\widowctrl
+{\header\pard\qr\plain\f2\fs%s
+%s
+p.\chpgn\par}
+\fs%s
+
+END
+ ($self->doc_lang) x 2,
+ $self->header_halfpoint_size,
+ $title,
+ $self->normal_halfpoint_size,
+ ;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+#-------------------------------------------------------------------------
+
+use integer;
+sub rtf_esc {
+ my $x; # scratch
+ if(!defined wantarray) { # void context: alter in-place!
+ for(@_) {
+ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ }
+ return;
+ } elsif(wantarray) { # return an array
+ return map {; ($x = $_) =~
+ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ $x;
+ } @_;
+ } else { # return a single scalar
+ ($x = ((@_ == 1) ? $_[0] : join '', @_)
+ ) =~ s/([F\x00-\x1F\-\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ # Escape \, {, }, -, control chars, and 7f-ff.
+ $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ return $x;
+ }
+}
+
+sub rtf_esc_codely {
+ # Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts.
+ # We don't want to change the "-" to hard-hyphen, because we want to
+ # be able to paste this into a file and run it without there being
+ # dire screaming about the mysterious hard-hyphen character (which
+ # looks just like a normal dash character).
+
+ my $x; # scratch
+ if(!defined wantarray) { # void context: alter in-place!
+ for(@_) {
+ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ }
+ return;
+ } elsif(wantarray) { # return an array
+ return map {; ($x = $_) =~
+ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ $x;
+ } @_;
+ } else { # return a single scalar
+ ($x = ((@_ == 1) ? $_[0] : join '', @_)
+ ) =~ s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER
+ # Escape \, {, }, -, control chars, and 7f-ff.
+ $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg;
+ return $x;
+ }
+}
+
+%Escape = (
+ map( (chr($_),chr($_)), # things not apparently needing escaping
+ 0x20 .. 0x7E ),
+ map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things
+ 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46),
+
+ # We get to escape out 'F' so that we can send RTF files thru the mail
+ # without the slightest worry that paragraphs beginning with "From"
+ # will get munged.
+
+ # And some refinements:
+ "\cm" => "\n",
+ "\cj" => "\n",
+ "\n" => "\n\\line ",
+
+ "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay)
+ "\f" => "\n\\page\n", # Formfeed
+ "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen
+ "\xA0" => "\\~", # Latin-1 non-breaking space
+ "\xAD" => "\\-", # Latin-1 soft (optional) hyphen
+
+ # CRAZY HACKS:
+ "\n" => "\\line\n",
+ "\r" => "\n",
+ "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1
+ "\cc" => "}",
+);
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::RTF -- format Pod as RTF
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::RTF -e \
+ "exit Pod::Simple::RTF->filter(shift)->any_errata_seen" \
+ thingy.pod > thingy.rtf
+
+=head1 DESCRIPTION
+
+This class is a formatter that takes Pod and renders it as RTF, good for
+viewing/printing in MSWord, WordPad/write.exe, TextEdit, etc.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 FORMAT CONTROL ATTRIBUTES
+
+You can set these attributes on the parser object before you
+call C<parse_file> (or a similar method) on it:
+
+=over
+
+=item $parser->head1_halfpoint_size( I<halfpoint_integer> );
+
+=item $parser->head2_halfpoint_size( I<halfpoint_integer> );
+
+=item $parser->head3_halfpoint_size( I<halfpoint_integer> );
+
+=item $parser->head4_halfpoint_size( I<halfpoint_integer> );
+
+These methods set the size (in half-points, like 52 for 26-point)
+that these heading levels will appear as.
+
+=item $parser->codeblock_halfpoint_size( I<halfpoint_integer> );
+
+This method sets the size (in half-points, like 21 for 10.5-point)
+that codeblocks ("verbatim sections") will appear as.
+
+=item $parser->header_halfpoint_size( I<halfpoint_integer> );
+
+This method sets the size (in half-points, like 15 for 7.5-point)
+that the header on each page will appear in. The header
+is usually just "I<modulename> p. I<pagenumber>".
+
+=item $parser->normal_halfpoint_size( I<halfpoint_integer> );
+
+This method sets the size (in half-points, like 26 for 13-point)
+that normal paragraphic text will appear in.
+
+=item $parser->no_proofing_exemptions( I<true_or_false> );
+
+Set this value to true if you don't want the formatter to try
+putting a hidden code on all Perl symbols (as best as it can
+notice them) that labels them as being not in English, and
+so not worth spellchecking.
+
+=item $parser->doc_lang( I<microsoft_decimal_language_code> )
+
+This sets the language code to tag this document as being in. By
+default, it is currently the value of the environment variable
+C<RTFDEFLANG>, or if that's not set, then the value
+1033 (for US English).
+
+Setting this appropriately is useful if you want to use the RTF
+to spellcheck, and/or if you want it to hyphenate right.
+
+Here are some notable values:
+
+ 1033 US English
+ 2057 UK English
+ 3081 Australia English
+ 4105 Canada English
+ 1034 Spain Spanish
+ 2058 Mexico Spanish
+ 1031 Germany German
+ 1036 France French
+ 3084 Canada French
+ 1035 Finnish
+ 1044 Norwegian (Bokmal)
+ 2068 Norwegian (Nynorsk)
+
+=back
+
+If you are particularly interested in customizing this module's output
+even more, see the source and/or write to me.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<RTF::Writer>, L<RTF::Cookbook>, L<RTF::Document>,
+L<RTF::Generator>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm
new file mode 100755
index 00000000000..37cd2e8319f
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm
@@ -0,0 +1,1043 @@
+
+require 5.005;
+package Pod::Simple::Search;
+use strict;
+
+use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY);
+$VERSION = '3.13'; ## Current version of this package
+
+BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level
+use Carp ();
+
+$SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i;
+ # flag to occasionally sleep for $SLEEPY - 1 seconds.
+
+$MAX_VERSION_WITHIN ||= 60;
+
+#############################################################################
+
+#use diagnostics;
+use File::Spec ();
+use File::Basename qw( basename );
+use Config ();
+use Cwd qw( cwd );
+
+#==========================================================================
+__PACKAGE__->_accessorize( # Make my dumb accessor methods
+ 'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob',
+ 'limit_re', 'shadows', 'verbose', 'name2path', 'path2name',
+);
+#==========================================================================
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, ref($class) || $class;
+ $self->init;
+ return $self;
+}
+
+sub init {
+ my $self = shift;
+ $self->inc(1);
+ $self->verbose(DEBUG);
+ return $self;
+}
+
+#--------------------------------------------------------------------------
+
+sub survey {
+ my($self, @search_dirs) = @_;
+ $self = $self->new unless ref $self; # tolerate being a class method
+
+ $self->_expand_inc( \@search_dirs );
+
+
+ $self->{'_scan_count'} = 0;
+ $self->{'_dirs_visited'} = {};
+ $self->path2name( {} );
+ $self->name2path( {} );
+ $self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'};
+ my $cwd = cwd();
+ my $verbose = $self->verbose;
+ local $_; # don't clobber the caller's $_ !
+
+ foreach my $try (@search_dirs) {
+ unless( File::Spec->file_name_is_absolute($try) ) {
+ # make path absolute
+ $try = File::Spec->catfile( $cwd ,$try);
+ }
+ # simplify path
+ $try = File::Spec->canonpath($try);
+
+ my $start_in;
+ my $modname_prefix;
+ if($self->{'dir_prefix'}) {
+ $start_in = File::Spec->catdir(
+ $try,
+ grep length($_), split '[\\/:]+', $self->{'dir_prefix'}
+ );
+ $modname_prefix = [grep length($_), split m{[:/\\]}, $self->{'dir_prefix'}];
+ $verbose and print "Appending \"$self->{'dir_prefix'}\" to $try, ",
+ "giving $start_in (= @$modname_prefix)\n";
+ } else {
+ $start_in = $try;
+ }
+
+ if( $self->{'_dirs_visited'}{$start_in} ) {
+ $verbose and print "Directory '$start_in' already seen, skipping.\n";
+ next;
+ } else {
+ $self->{'_dirs_visited'}{$start_in} = 1;
+ }
+
+ unless(-e $start_in) {
+ $verbose and print "Skipping non-existent $start_in\n";
+ next;
+ }
+
+ my $closure = $self->_make_search_callback;
+
+ if(-d $start_in) {
+ # Normal case:
+ $verbose and print "Beginning excursion under $start_in\n";
+ $self->_recurse_dir( $start_in, $closure, $modname_prefix );
+ $verbose and print "Back from excursion under $start_in\n\n";
+
+ } elsif(-f _) {
+ # A excursion consisting of just one file!
+ $_ = basename($start_in);
+ $verbose and print "Pondering $start_in ($_)\n";
+ $closure->($start_in, $_, 0, []);
+
+ } else {
+ $verbose and print "Skipping mysterious $start_in\n";
+ }
+ }
+ $self->progress and $self->progress->done(
+ "Noted $$self{'_scan_count'} Pod files total");
+
+ return unless defined wantarray; # void
+ return $self->name2path unless wantarray; # scalar
+ return $self->name2path, $self->path2name; # list
+}
+
+
+#==========================================================================
+sub _make_search_callback {
+ my $self = $_[0];
+
+ # Put the options in variables, for easy access
+ my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress,$path2name,$name2path) =
+ map scalar($self->$_()),
+ qw(laborious verbose shadows limit_re callback progress path2name name2path);
+
+ my($file, $shortname, $isdir, $modname_bits);
+ return sub {
+ ($file, $shortname, $isdir, $modname_bits) = @_;
+
+ if($isdir) { # this never gets called on the startdir itself, just subdirs
+
+ if( $self->{'_dirs_visited'}{$file} ) {
+ $verbose and print "Directory '$file' already seen, skipping.\n";
+ return 'PRUNE';
+ }
+
+ print "Looking in dir $file\n" if $verbose;
+
+ unless ($laborious) { # $laborious overrides pruning
+ if( m/^(\d+\.[\d_]{3,})\z/s
+ and do { my $x = $1; $x =~ tr/_//d; $x != $] }
+ ) {
+ $verbose and print "Perl $] version mismatch on $_, skipping.\n";
+ return 'PRUNE';
+ }
+
+ if( m/^([A-Za-z][a-zA-Z0-9_]*)\z/s ) {
+ $verbose and print "$_ is a well-named module subdir. Looking....\n";
+ } else {
+ $verbose and print "$_ is a fishy directory name. Skipping.\n";
+ return 'PRUNE';
+ }
+ } # end unless $laborious
+
+ $self->{'_dirs_visited'}{$file} = 1;
+ return; # (not pruning);
+ }
+
+
+ # Make sure it's a file even worth even considering
+ if($laborious) {
+ unless(
+ m/\.(pod|pm|plx?)\z/i || -x _ and -T _
+ # Note that the cheapest operation (the RE) is run first.
+ ) {
+ $verbose > 1 and print " Brushing off uninteresting $file\n";
+ return;
+ }
+ } else {
+ unless( m/^[-_a-zA-Z0-9]+\.(?:pod|pm|plx?)\z/is ) {
+ $verbose > 1 and print " Brushing off oddly-named $file\n";
+ return;
+ }
+ }
+
+ $verbose and print "Considering item $file\n";
+ my $name = $self->_path2modname( $file, $shortname, $modname_bits );
+ $verbose > 0.01 and print " Nominating $file as $name\n";
+
+ if($limit_re and $name !~ m/$limit_re/i) {
+ $verbose and print "Shunning $name as not matching $limit_re\n";
+ return;
+ }
+
+ if( !$shadows and $name2path->{$name} ) {
+ $verbose and print "Not worth considering $file ",
+ "-- already saw $name as ",
+ join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n";
+ return;
+ }
+
+ # Put off until as late as possible the expense of
+ # actually reading the file:
+ if( m/\.pod\z/is ) {
+ # just assume it has pod, okay?
+ } else {
+ $progress and $progress->reach($self->{'_scan_count'}, "Scanning $file");
+ return unless $self->contains_pod( $file );
+ }
+ ++ $self->{'_scan_count'};
+
+ # Or finally take note of it:
+ if( $name2path->{$name} ) {
+ $verbose and print
+ "Duplicate POD found (shadowing?): $name ($file)\n",
+ " Already seen in ",
+ join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n";
+ } else {
+ $name2path->{$name} = $file; # Noting just the first occurrence
+ }
+ $verbose and print " Noting $name = $file\n";
+ if( $callback ) {
+ local $_ = $_; # insulate from changes, just in case
+ $callback->($file, $name);
+ }
+ $path2name->{$file} = $name;
+ return;
+ }
+}
+
+#==========================================================================
+
+sub _path2modname {
+ my($self, $file, $shortname, $modname_bits) = @_;
+
+ # this code simplifies the POD name for Perl modules:
+ # * remove "site_perl"
+ # * remove e.g. "i586-linux" (from 'archname')
+ # * remove e.g. 5.00503
+ # * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod)
+ # * dig into the file for case-preserved name if not already mixed case
+
+ my @m = @$modname_bits;
+ my $x;
+ my $verbose = $self->verbose;
+
+ # Shaving off leading naughty-bits
+ while(@m
+ and defined($x = lc( $m[0] ))
+ and( $x eq 'site_perl'
+ or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s )
+ or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum
+ or $x eq lc( $Config::Config{'archname'} )
+ )) { shift @m }
+
+ my $name = join '::', @m, $shortname;
+ $self->_simplify_base($name);
+
+ # On VMS, case-preserved document names can't be constructed from
+ # filenames, so try to extract them from the "=head1 NAME" tag in the
+ # file instead.
+ if ($^O eq 'VMS' && ($name eq lc($name) || $name eq uc($name))) {
+ open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!";
+ my $in_pod = 0;
+ my $in_name = 0;
+ my $line;
+ while ($line = <PODFILE>) {
+ chomp $line;
+ $in_pod = 1 if ($line =~ m/^=\w/);
+ $in_pod = 0 if ($line =~ m/^=cut/);
+ next unless $in_pod; # skip non-pod text
+ next if ($line =~ m/^\s*\z/); # and blank lines
+ next if ($in_pod && ($line =~ m/^X</)); # and commands
+ if ($in_name) {
+ if ($line =~ m/(\w+::)?(\w+)/) {
+ # substitute case-preserved version of name
+ my $podname = $2;
+ my $prefix = $1 || '';
+ $verbose and print "Attempting case restore of '$name' from '$prefix$podname'\n";
+ unless ($name =~ s/$prefix$podname/$prefix$podname/i) {
+ $verbose and print "Attempting case restore of '$name' from '$podname'\n";
+ $name =~ s/$podname/$podname/i;
+ }
+ last;
+ }
+ }
+ $in_name = 1 if ($line =~ m/^=head1 NAME/);
+ }
+ close PODFILE;
+ }
+
+ return $name;
+}
+
+#==========================================================================
+
+sub _recurse_dir {
+ my($self, $startdir, $callback, $modname_bits) = @_;
+
+ my $maxdepth = $self->{'fs_recursion_maxdepth'} || 10;
+ my $verbose = $self->verbose;
+
+ my $here_string = File::Spec->curdir;
+ my $up_string = File::Spec->updir;
+ $modname_bits ||= [];
+
+ my $recursor;
+ $recursor = sub {
+ my($dir_long, $dir_bare) = @_;
+ if( @$modname_bits >= 10 ) {
+ $verbose and print "Too deep! [@$modname_bits]\n";
+ return;
+ }
+
+ unless(-d $dir_long) {
+ $verbose > 2 and print "But it's not a dir! $dir_long\n";
+ return;
+ }
+ unless( opendir(INDIR, $dir_long) ) {
+ $verbose > 2 and print "Can't opendir $dir_long : $!\n";
+ closedir(INDIR);
+ return
+ }
+ my @items = sort readdir(INDIR);
+ closedir(INDIR);
+
+ push @$modname_bits, $dir_bare unless $dir_bare eq '';
+
+ my $i_full;
+ foreach my $i (@items) {
+ next if $i eq $here_string or $i eq $up_string or $i eq '';
+ $i_full = File::Spec->catfile( $dir_long, $i );
+
+ if(!-r $i_full) {
+ $verbose and print "Skipping unreadable $i_full\n";
+
+ } elsif(-f $i_full) {
+ $_ = $i;
+ $callback->( $i_full, $i, 0, $modname_bits );
+
+ } elsif(-d _) {
+ $i =~ s/\.DIR\z//i if $^O eq 'VMS';
+ $_ = $i;
+ my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';
+
+ if($rv eq 'PRUNE') {
+ $verbose > 1 and print "OK, pruning";
+ } else {
+ # Otherwise, recurse into it
+ $recursor->( File::Spec->catdir($dir_long, $i) , $i);
+ }
+ } else {
+ $verbose > 1 and print "Skipping oddity $i_full\n";
+ }
+ }
+ pop @$modname_bits;
+ return;
+ };;
+
+ local $_;
+ $recursor->($startdir, '');
+
+ undef $recursor; # allow it to be GC'd
+
+ return;
+}
+
+
+#==========================================================================
+
+sub run {
+ # A function, useful in one-liners
+
+ my $self = __PACKAGE__->new;
+ $self->limit_glob($ARGV[0]) if @ARGV;
+ $self->callback( sub {
+ my($file, $name) = @_;
+ my $version = '';
+
+ # Yes, I know we won't catch the version in like a File/Thing.pm
+ # if we see File/Thing.pod first. That's just the way the
+ # cookie crumbles. -- SMB
+
+ if($file =~ m/\.pod$/i) {
+ # Don't bother looking for $VERSION in .pod files
+ DEBUG and print "Not looking for \$VERSION in .pod $file\n";
+ } elsif( !open(INPOD, $file) ) {
+ DEBUG and print "Couldn't open $file: $!\n";
+ close(INPOD);
+ } else {
+ # Sane case: file is readable
+ my $lines = 0;
+ while(<INPOD>) {
+ last if $lines++ > $MAX_VERSION_WITHIN; # some degree of sanity
+ if( s/^\s*\$VERSION\s*=\s*//s and m/\d/ ) {
+ DEBUG and print "Found version line (#$lines): $_";
+ s/\s*\#.*//s;
+ s/\;\s*$//s;
+ s/\s+$//s;
+ s/\t+/ /s; # nix tabs
+ # Optimize the most common cases:
+ $_ = "v$1"
+ if m{^v?["']?([0-9_]+(\.[0-9_]+)*)["']?$}s
+ # like in $VERSION = "3.14159";
+ or m{\$Revision:\s*([0-9_]+(?:\.[0-9_]+)*)\s*\$}s
+ # like in sprintf("%d.%02d", q$Revision: 4.13 $ =~ /(\d+)\.(\d+)/);
+ ;
+
+ # Like in sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/)
+ $_ = sprintf("v%d.%s",
+ map {s/_//g; $_}
+ $1 =~ m/-(\d+)_([\d_]+)/) # snare just the numeric part
+ if m{\$Name:\s*([^\$]+)\$}s
+ ;
+ $version = $_;
+ DEBUG and print "Noting $version as version\n";
+ last;
+ }
+ }
+ close(INPOD);
+ }
+ print "$name\t$version\t$file\n";
+ return;
+ # End of callback!
+ });
+
+ $self->survey;
+}
+
+#==========================================================================
+
+sub simplify_name {
+ my($self, $str) = @_;
+
+ # Remove all path components
+ # XXX Why not just use basename()? -- SMB
+
+ if ($^O eq 'MacOS') { $str =~ s{^.*:+}{}s }
+ else { $str =~ s{^.*/+}{}s }
+
+ $self->_simplify_base($str);
+ return $str;
+}
+
+#==========================================================================
+
+sub _simplify_base { # Internal method only
+
+ # strip Perl's own extensions
+ $_[1] =~ s/\.(pod|pm|plx?)\z//i;
+
+ # strip meaningless extensions on Win32 and OS/2
+ $_[1] =~ s/\.(bat|exe|cmd)\z//i if $^O =~ /mswin|os2/i;
+
+ # strip meaningless extensions on VMS
+ $_[1] =~ s/\.(com)\z//i if $^O eq 'VMS';
+
+ return;
+}
+
+#==========================================================================
+
+sub _expand_inc {
+ my($self, $search_dirs) = @_;
+
+ return unless $self->{'inc'};
+
+ if ($^O eq 'MacOS') {
+ push @$search_dirs,
+ grep $_ ne File::Spec->curdir, $self->_mac_whammy(@INC);
+ # Any other OSs need custom handling here?
+ } else {
+ push @$search_dirs, grep $_ ne File::Spec->curdir, @INC;
+ }
+
+ $self->{'laborious'} = 0; # Since inc said to use INC
+ return;
+}
+
+#==========================================================================
+
+sub _mac_whammy { # Tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS
+ my @them;
+ (undef,@them) = @_;
+ for $_ (@them) {
+ if ( $_ eq '.' ) {
+ $_ = ':';
+ } elsif ( $_ =~ s|^((?:\.\./)+)|':' x (length($1)/3)|e ) {
+ $_ = ':'. $_;
+ } else {
+ $_ =~ s|^\./|:|;
+ }
+ }
+ return @them;
+}
+
+#==========================================================================
+
+sub _limit_glob_to_limit_re {
+ my $self = $_[0];
+ my $limit_glob = $self->{'limit_glob'} || return;
+
+ my $limit_re = '^' . quotemeta($limit_glob) . '$';
+ $limit_re =~ s/\\\?/./g; # glob "?" => "."
+ $limit_re =~ s/\\\*/.*?/g; # glob "*" => ".*?"
+ $limit_re =~ s/\.\*\?\$$//s; # final glob "*" => ".*?$" => ""
+
+ $self->{'verbose'} and print "Turning limit_glob $limit_glob into re $limit_re\n";
+
+ # A common optimization:
+ if(!exists($self->{'dir_prefix'})
+ and $limit_glob =~ m/^(?:\w+\:\:)+/s # like "File::*" or "File::Thing*"
+ # Optimize for sane and common cases (but not things like "*::File")
+ ) {
+ $self->{'dir_prefix'} = join "::", $limit_glob =~ m/^(?:\w+::)+/sg;
+ $self->{'verbose'} and print " and setting dir_prefix to $self->{'dir_prefix'}\n";
+ }
+
+ return $limit_re;
+}
+
+#==========================================================================
+
+# contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu>
+
+sub find {
+ my($self, $pod, @search_dirs) = @_;
+ $self = $self->new unless ref $self; # tolerate being a class method
+
+ # Check usage
+ Carp::carp 'Usage: \$self->find($podname, ...)'
+ unless defined $pod and length $pod;
+
+ my $verbose = $self->verbose;
+
+ # Split on :: and then join the name together using File::Spec
+ my @parts = split /::/, $pod;
+ $verbose and print "Chomping {$pod} => {@parts}\n";
+
+ #@search_dirs = File::Spec->curdir unless @search_dirs;
+
+ if( $self->inc ) {
+ if( $^O eq 'MacOS' ) {
+ push @search_dirs, $self->_mac_whammy(@INC);
+ } else {
+ push @search_dirs, @INC;
+ }
+
+ # Add location of pod documentation for perl man pages (eg perlfunc)
+ # This is a pod directory in the private install tree
+ #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'},
+ # 'pod');
+ #push (@search_dirs, $perlpoddir)
+ # if -d $perlpoddir;
+
+ # Add location of binaries such as pod2text:
+ push @search_dirs, $Config::Config{'scriptdir'};
+ # and if that's undef or q{} or nonexistent, we just ignore it later
+ }
+
+ my %seen_dir;
+ Dir:
+ foreach my $dir ( @search_dirs ) {
+ next unless defined $dir and length $dir;
+ next if $seen_dir{$dir};
+ $seen_dir{$dir} = 1;
+ unless(-d $dir) {
+ print "Directory $dir does not exist\n" if $verbose;
+ next Dir;
+ }
+
+ print "Looking in directory $dir\n" if $verbose;
+ my $fullname = File::Spec->catfile( $dir, @parts );
+ print "Filename is now $fullname\n" if $verbose;
+
+ foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions
+ my $fullext = $fullname . $ext;
+ if( -f $fullext and $self->contains_pod( $fullext ) ){
+ print "FOUND: $fullext\n" if $verbose;
+ return $fullext;
+ }
+ }
+ my $subdir = File::Spec->catdir($dir,'pod');
+ if(-d $subdir) { # slip in the ./pod dir too
+ $verbose and print "Noticing $subdir and stopping there...\n";
+ $dir = $subdir;
+ redo Dir;
+ }
+ }
+
+ return undef;
+}
+
+#==========================================================================
+
+sub contains_pod {
+ my($self, $file) = @_;
+ my $verbose = $self->{'verbose'};
+
+ # check for one line of POD
+ $verbose > 1 and print " Scanning $file for pod...\n";
+ unless( open(MAYBEPOD,"<$file") ) {
+ print "Error: $file is unreadable: $!\n";
+ return undef;
+ }
+
+ sleep($SLEEPY - 1) if $SLEEPY;
+ # avoid totally hogging the processor on OSs with poor process control
+
+ local $_;
+ while( <MAYBEPOD> ) {
+ if(m/^=(head\d|pod|over|item)\b/s) {
+ close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
+ chomp;
+ $verbose > 1 and print " Found some pod ($_) in $file\n";
+ return 1;
+ }
+ }
+ close(MAYBEPOD) || die "Bizarre error closing $file: $!\nAborting";
+ $verbose > 1 and print " No POD in $file, skipping.\n";
+ return 0;
+}
+
+#==========================================================================
+
+sub _accessorize { # A simple-minded method-maker
+ shift;
+ no strict 'refs';
+ foreach my $attrname (@_) {
+ *{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];
+
+ # Read access:
+ return $_[0]->{$attrname} if @_ == 1;
+
+ # Write access:
+ $_[0]->{$attrname} = $_[1];
+ return $_[0]; # RETURNS MYSELF!
+ };
+ }
+ # Ya know, they say accessories make the ensemble!
+ return;
+}
+
+#==========================================================================
+sub _state_as_string {
+ my $self = $_[0];
+ return '' unless ref $self;
+ my @out = "{\n # State of $self ...\n";
+ foreach my $k (sort keys %$self) {
+ push @out, " ", _esc($k), " => ", _esc($self->{$k}), ",\n";
+ }
+ push @out, "}\n";
+ my $x = join '', @out;
+ $x =~ s/^/#/mg;
+ return $x;
+}
+
+sub _esc {
+ my $in = $_[0];
+ return 'undef' unless defined $in;
+ $in =~
+ s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])>
+ <'\\x'.(unpack("H2",$1))>eg;
+ return qq{"$in"};
+}
+
+#==========================================================================
+
+run() unless caller; # run if "perl whatever/Search.pm"
+
+1;
+
+#==========================================================================
+
+__END__
+
+
+=head1 NAME
+
+Pod::Simple::Search - find POD documents in directory trees
+
+=head1 SYNOPSIS
+
+ use Pod::Simple::Search;
+ my $name2path = Pod::Simple::Search->new->limit_glob('LWP::*')->survey;
+ print "Looky see what I found: ",
+ join(' ', sort keys %$name2path), "\n";
+
+ print "LWPUA docs = ",
+ Pod::Simple::Search->new->find('LWP::UserAgent') || "?",
+ "\n";
+
+=head1 DESCRIPTION
+
+B<Pod::Simple::Search> is a class that you use for running searches
+for Pod files. An object of this class has several attributes
+(mostly options for controlling search options), and some methods
+for searching based on those attributes.
+
+The way to use this class is to make a new object of this class,
+set any options, and then call one of the search options
+(probably C<survey> or C<find>). The sections below discuss the
+syntaxes for doing all that.
+
+
+=head1 CONSTRUCTOR
+
+This class provides the one constructor, called C<new>.
+It takes no parameters:
+
+ use Pod::Simple::Search;
+ my $search = Pod::Simple::Search->new;
+
+=head1 ACCESSORS
+
+This class defines several methods for setting (and, occasionally,
+reading) the contents of an object. With two exceptions (discussed at
+the end of this section), these attributes are just for controlling the
+way searches are carried out.
+
+Note that each of these return C<$self> when you call them as
+C<< $self->I<whatever(value)> >>. That's so that you can chain
+together set-attribute calls like this:
+
+ my $name2path =
+ Pod::Simple::Search->new
+ -> inc(0) -> verbose(1) -> callback(\&blab)
+ ->survey(@there);
+
+...which works exactly as if you'd done this:
+
+ my $search = Pod::Simple::Search->new;
+ $search->inc(0);
+ $search->verbose(1);
+ $search->callback(\&blab);
+ my $name2path = $search->survey(@there);
+
+=over
+
+=item $search->inc( I<true-or-false> );
+
+This attribute, if set to a true value, means that searches should
+implicitly add perl's I<@INC> paths. This
+automatically considers paths specified in the C<PERL5LIB> environment
+as this is prepended to I<@INC> by the Perl interpreter itself.
+This attribute's default value is B<TRUE>. If you want to search
+only specific directories, set $self->inc(0) before calling
+$inc->survey or $inc->find.
+
+
+=item $search->verbose( I<nonnegative-number> );
+
+This attribute, if set to a nonzero positive value, will make searches output
+(via C<warn>) notes about what they're doing as they do it.
+This option may be useful for debugging a pod-related module.
+This attribute's default value is zero, meaning that no C<warn> messages
+are produced. (Setting verbose to 1 turns on some messages, and setting
+it to 2 turns on even more messages, i.e., makes the following search(es)
+even more verbose than 1 would make them.)
+
+
+=item $search->limit_glob( I<some-glob-string> );
+
+This option means that you want to limit the results just to items whose
+podnames match the given glob/wildcard expression. For example, you
+might limit your search to just "LWP::*", to search only for modules
+starting with "LWP::*" (but not including the module "LWP" itself); or
+you might limit your search to "LW*" to see only modules whose (full)
+names begin with "LW"; or you might search for "*Find*" to search for
+all modules with "Find" somewhere in their full name. (You can also use
+"?" in a glob expression; so "DB?" will match "DBI" and "DBD".)
+
+
+=item $search->callback( I<\&some_routine> );
+
+This attribute means that every time this search sees a matching
+Pod file, it should call this callback routine. The routine is called
+with two parameters: the current file's filespec, and its pod name.
+(For example: C<("/etc/perljunk/File/Crunk.pm", "File::Crunk")> would
+be in C<@_>.)
+
+The callback routine's return value is not used for anything.
+
+This attribute's default value is false, meaning that no callback
+is called.
+
+=item $search->laborious( I<true-or-false> );
+
+Unless you set this attribute to a true value, Pod::Search will
+apply Perl-specific heuristics to find the correct module PODs quickly.
+This attribute's default value is false. You won't normally need
+to set this to true.
+
+Specifically: Turning on this option will disable the heuristics for
+seeing only files with Perl-like extensions, omitting subdirectories
+that are numeric but do I<not> match the current Perl interpreter's
+version ID, suppressing F<site_perl> as a module hierarchy name, etc.
+
+
+=item $search->shadows( I<true-or-false> );
+
+Unless you set this attribute to a true value, Pod::Simple::Search will
+consider only the first file of a given modulename as it looks thru the
+specified directories; that is, with this option off, if
+Pod::Simple::Search has seen a C<somepathdir/Foo/Bar.pm> already in this
+search, then it won't bother looking at a C<somelaterpathdir/Foo/Bar.pm>
+later on in that search, because that file is merely a "shadow". But if
+you turn on C<< $self->shadows(1) >>, then these "shadow" files are
+inspected too, and are noted in the pathname2podname return hash.
+
+This attribute's default value is false; and normally you won't
+need to turn it on.
+
+
+=item $search->limit_re( I<some-regxp> );
+
+Setting this attribute (to a value that's a regexp) means that you want
+to limit the results just to items whose podnames match the given
+regexp. Normally this option is not needed, and the more efficient
+C<limit_glob> attribute is used instead.
+
+
+=item $search->dir_prefix( I<some-string-value> );
+
+Setting this attribute to a string value means that the searches should
+begin in the specified subdirectory name (like "Pod" or "File::Find",
+also expressable as "File/Find"). For example, the search option
+C<< $search->limit_glob("File::Find::R*") >>
+is the same as the combination of the search options
+C<< $search->limit_re("^File::Find::R") -> dir_prefix("File::Find") >>.
+
+Normally you don't need to know about the C<dir_prefix> option, but I
+include it in case it might prove useful for someone somewhere.
+
+(Implementationally, searching with limit_glob ends up setting limit_re
+and usually dir_prefix.)
+
+
+=item $search->progress( I<some-progress-object> );
+
+If you set a value for this attribute, the value is expected
+to be an object (probably of a class that you define) that has a
+C<reach> method and a C<done> method. This is meant for reporting
+progress during the search, if you don't want to use a simple
+callback.
+
+Normally you don't need to know about the C<progress> option, but I
+include it in case it might prove useful for someone somewhere.
+
+While a search is in progress, the progress object's C<reach> and
+C<done> methods are called like this:
+
+ # Every time a file is being scanned for pod:
+ $progress->reach($count, "Scanning $file"); ++$count;
+
+ # And then at the end of the search:
+ $progress->done("Noted $count Pod files total");
+
+Internally, we often set this to an object of class
+Pod::Simple::Progress. That class is probably undocumented,
+but you may wish to look at its source.
+
+
+=item $name2path = $self->name2path;
+
+This attribute is not a search parameter, but is used to report the
+result of C<survey> method, as discussed in the next section.
+
+=item $path2name = $self->path2name;
+
+This attribute is not a search parameter, but is used to report the
+result of C<survey> method, as discussed in the next section.
+
+=back
+
+=head1 MAIN SEARCH METHODS
+
+Once you've actually set any options you want (if any), you can go
+ahead and use the following methods to search for Pod files
+in particular ways.
+
+
+=head2 C<< $search->survey( @directories ) >>
+
+The method C<survey> searches for POD documents in a given set of
+files and/or directories. This runs the search according to the various
+options set by the accessors above. (For example, if the C<inc> attribute
+is on, as it is by default, then the perl @INC directories are implicitly
+added to the list of directories (if any) that you specify.)
+
+The return value of C<survey> is two hashes:
+
+=over
+
+=item C<name2path>
+
+A hash that maps from each pod-name to the filespec (like
+"Stuff::Thing" => "/whatever/plib/Stuff/Thing.pm")
+
+=item C<path2name>
+
+A hash that maps from each Pod filespec to its pod-name (like
+"/whatever/plib/Stuff/Thing.pm" => "Stuff::Thing")
+
+=back
+
+Besides saving these hashes as the hashref attributes
+C<name2path> and C<path2name>, calling this function also returns
+these hashrefs. In list context, the return value of
+C<< $search->survey >> is the list C<(\%name2path, \%path2name)>.
+In scalar context, the return value is C<\%name2path>.
+Or you can just call this in void context.
+
+Regardless of calling context, calling C<survey> saves
+its results in its C<name2path> and C<path2name> attributes.
+
+E.g., when searching in F<$HOME/perl5lib>, the file
+F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>,
+whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be
+I<Myclass::Subclass>. The name information can be used for POD
+translators.
+
+Only text files containing at least one valid POD command are found.
+
+In verbose mode, a warning is printed if shadows are found (i.e., more
+than one POD file with the same POD name is found, e.g. F<CPAN.pm> in
+different directories). This usually indicates duplicate occurrences of
+modules in the I<@INC> search path, which is occasionally inadvertent
+(but is often simply a case of a user's path dir having a more recent
+version than the system's general path dirs in general.)
+
+The options to this argument is a list of either directories that are
+searched recursively, or files. (Usually you wouldn't specify files,
+but just dirs.) Or you can just specify an empty-list, as in
+$name2path; with the
+C<inc> option on, as it is by default, teh
+
+The POD names of files are the plain basenames with any Perl-like
+extension (.pm, .pl, .pod) stripped, and path separators replaced by
+C<::>'s.
+
+Calling Pod::Simple::Search->search(...) is short for
+Pod::Simple::Search->new->search(...). That is, a throwaway object
+with default attribute values is used.
+
+
+=head2 C<< $search->simplify_name( $str ) >>
+
+The method B<simplify_name> is equivalent to B<basename>, but also
+strips Perl-like extensions (.pm, .pl, .pod) and extensions like
+F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively.
+
+
+=head2 C<< $search->find( $pod ) >>
+
+=head2 C<< $search->find( $pod, @search_dirs ) >>
+
+Returns the location of a Pod file, given a Pod/module/script name
+(like "Foo::Bar" or "perlvar" or "perldoc"), and an idea of
+what files/directories to look in.
+It searches according to the various options set by the accessors above.
+(For example, if the C<inc> attribute is on, as it is by default, then
+the perl @INC directories are implicitly added to the list of
+directories (if any) that you specify.)
+
+This returns the full path of the first occurrence to the file.
+Package names (eg 'A::B') are automatically converted to directory
+names in the selected directory. Additionally, '.pm', '.pl' and '.pod'
+are automatically appended to the search as required.
+(So, for example, under Unix, "A::B" is converted to "somedir/A/B.pm",
+"somedir/A/B.pod", or "somedir/A/B.pl", as appropriate.)
+
+If no such Pod file is found, this method returns undef.
+
+If any of the given search directories contains a F<pod/> subdirectory,
+then it is searched. (That's how we manage to find F<perlfunc>,
+for example, which is usually in F<pod/perlfunc> in most Perl dists.)
+
+The C<verbose> and C<inc> attributes influence the behavior of this
+search; notably, C<inc>, if true, adds @INC I<and also
+$Config::Config{'scriptdir'}> to the list of directories to search.
+
+It is common to simply say C<< $filename = Pod::Simple::Search-> new
+->find("perlvar") >> so that just the @INC (well, and scriptdir)
+directories are searched. (This happens because the C<inc>
+attribute is true by default.)
+
+Calling Pod::Simple::Search->find(...) is short for
+Pod::Simple::Search->new->find(...). That is, a throwaway object
+with default attribute values is used.
+
+
+=head2 C<< $self->contains_pod( $file ) >>
+
+Returns true if the supplied filename (not POD module) contains some Pod
+documentation.
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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> with code borrowed
+from Marek Rouchal's L<Pod::Find>, which in turn heavily borrowed code from
+Nick Ing-Simmons' C<PodToHtml>.
+
+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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm
new file mode 100755
index 00000000000..7f39680103d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm
@@ -0,0 +1,180 @@
+
+
+require 5;
+package Pod::Simple::SimpleTree;
+use strict;
+use Carp ();
+use Pod::Simple ();
+use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
+$VERSION = '3.13';
+BEGIN {
+ @ISA = ('Pod::Simple');
+ *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
+}
+
+__PACKAGE__->_accessorize(
+ 'root', # root of the tree
+);
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub _handle_element_start { # self, tagname, attrhash
+ DEBUG > 2 and print "Handling $_[1] start-event\n";
+ my $x = [$_[1], $_[2]];
+ if($_[0]{'_currpos'}) {
+ push @{ $_[0]{'_currpos'}[0] }, $x; # insert in parent's child-list
+ unshift @{ $_[0]{'_currpos'} }, $x; # prefix to stack
+ } else {
+ DEBUG and print " And oo, it gets to be root!\n";
+ $_[0]{'_currpos'} = [ $_[0]{'root'} = $x ];
+ # first event! set to stack, and set as root.
+ }
+ DEBUG > 3 and print "Stack is now: ",
+ join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
+ return;
+}
+
+sub _handle_element_end { # self, tagname
+ DEBUG > 2 and print "Handling $_[1] end-event\n";
+ shift @{$_[0]{'_currpos'}};
+ DEBUG > 3 and print "Stack is now: ",
+ join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n";
+ return;
+}
+
+sub _handle_text { # self, text
+ DEBUG > 2 and print "Handling $_[1] text-event\n";
+ push @{ $_[0]{'_currpos'}[0] }, $_[1];
+ return;
+}
+
+
+# A bit of evil from the black box... please avert your eyes, kind souls.
+sub _traverse_treelet_bit {
+ DEBUG > 2 and print "Handling $_[1] paragraph event\n";
+ my $self = shift;
+ push @{ $self->{'_currpos'}[0] }, [@_];
+ return;
+}
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1;
+__END__
+
+=head1 NAME
+
+Pod::Simple::SimpleTree -- parse Pod into a simple parse tree
+
+=head1 SYNOPSIS
+
+ % cat ptest.pod
+
+ =head1 PIE
+
+ I like B<pie>!
+
+ % perl -MPod::Simple::SimpleTree -MData::Dumper -e \
+ "print Dumper(Pod::Simple::SimpleTree->new->parse_file(shift)->root)" \
+ ptest.pod
+
+ $VAR1 = [
+ 'Document',
+ { 'start_line' => 1 },
+ [
+ 'head1',
+ { 'start_line' => 1 },
+ 'PIE'
+ ],
+ [
+ 'Para',
+ { 'start_line' => 3 },
+ 'I like ',
+ [
+ 'B',
+ {},
+ 'pie'
+ ],
+ '!'
+ ]
+ ];
+
+=head1 DESCRIPTION
+
+This class is of interest to people writing a Pod processor/formatter.
+
+This class takes Pod and parses it, returning a parse tree made just
+of arrayrefs, and hashrefs, and strings.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+This class is inspired by XML::Parser's "Tree" parsing-style, although
+it doesn't use exactly the same LoL format.
+
+=head1 METHODS
+
+At the end of the parse, call C<< $parser->root >> to get the
+tree's top node.
+
+=head1 Tree Contents
+
+Every element node in the parse tree is represented by an arrayref of
+the form: C<[ I<elementname>, \%attributes, I<...subnodes...> ]>.
+See the example tree dump in the Synopsis, above.
+
+Every text node in the tree is represented by a simple (non-ref)
+string scalar. So you can test C<ref($node)> to see whather you have
+an element node or just a text node.
+
+The top node in the tree is C<[ 'Document', \%attributes,
+I<...subnodes...> ]>
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple>
+
+L<perllol>
+
+L<The "Tree" subsubsection in XML::Parser|XML::Parser/"Tree">
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod
new file mode 100755
index 00000000000..f2011d5a5ce
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod
@@ -0,0 +1,946 @@
+
+=head1 NAME
+
+Pod::Simple::Subclassing -- write a formatter as a Pod::Simple subclass
+
+=head1 SYNOPSIS
+
+ package Pod::SomeFormatter;
+ use Pod::Simple;
+ @ISA = qw(Pod::Simple);
+ $VERSION = '1.01';
+ use strict;
+
+ sub _handle_element_start {
+ my($parser, $element_name, $attr_hash_r) = @_;
+ ...
+ }
+
+ sub _handle_element_end {
+ my($parser, $element_name) = @_;
+ ...
+ }
+
+ sub _handle_text {
+ my($parser, $text) = @_;
+ ...
+ }
+ 1;
+
+=head1 DESCRIPTION
+
+This document is about using Pod::Simple to write a Pod processor,
+generally a Pod formatter. If you just want to know about using an
+existing Pod formatter, instead see its documentation and see also the
+docs in L<Pod::Simple>.
+
+The zeroeth step in writing a Pod formatter is to make sure that there
+isn't already a decent one in CPAN. See L<http://search.cpan.org/>, and
+run a search on the name of the format you want to render to. Also
+consider joining the Pod People list
+L<http://lists.perl.org/showlist.cgi?name=pod-people> and asking whether
+anyone has a formatter for that format -- maybe someone cobbled one
+together but just hasn't released it.
+
+The first step in writing a Pod processor is to read L<perlpodspec>,
+which contains notes information on writing a Pod parser (which has been
+largely taken care of by Pod::Simple), but also a lot of requirements
+and recommendations for writing a formatter.
+
+The second step is to actually learn the format you're planning to
+format to -- or at least as much as you need to know to represent Pod,
+which probably isn't much.
+
+The third step is to pick which of Pod::Simple's interfaces you want to
+use -- the basic interface via Pod::Simple or L<Pod::Simple::Methody> is
+event-based, sort of like L<HTML::Parser>'s interface, or sort of like
+L<XML::Parser>'s "Handlers" interface), but L<Pod::Simple::PullParser>
+provides a token-stream interface, sort of like L<HTML::TokeParser>'s
+interface; L<Pod::Simple::SimpleTree> provides a simple tree interface,
+rather like XML::Parser's "Tree" interface. Users familiar with
+XML-handling will find one of these styles relatively familiar; but if
+you would be even more at home with XML, there are classes that produce
+an XML representation of the Pod stream, notably
+L<Pod::Simple::XMLOutStream>; you can feed the output of such a class to
+whatever XML parsing system you are most at home with.
+
+The last step is to write your code based on how the events (or tokens,
+or tree-nodes, or the XML, or however you're parsing) will map to
+constructs in the output format. Also sure to consider how to escape
+text nodes containing arbitrary text, and also what to do with text
+nodes that represent preformatted text (from verbatim sections).
+
+
+
+=head1 Events
+
+TODO intro... mention that events are supplied for implicits, like for
+missing >'s
+
+
+In the following section, we use XML to represent the event structure
+associated with a particular construct. That is, TODO
+
+=over
+
+=item C<< $parser->_handle_element_start( I<element_name>, I<attr_hashref> ) >>
+
+=item C<< $parser->_handle_element_end( I<element_name> ) >>
+
+=item C<< $parser->_handle_text( I<text_string> ) >>
+
+=back
+
+TODO describe
+
+
+=over
+
+=item events with an element_name of Document
+
+Parsing a document produces this event structure:
+
+ <Document start_line="543">
+ ...all events...
+ </Document>
+
+The value of the I<start_line> attribute will be the line number of the first
+Pod directive in the document.
+
+If there is no Pod in the given document, then the
+event structure will be this:
+
+ <Document contentless="1" start_line="543">
+ </Document>
+
+In that case, the value of the I<start_line> attribute will not be meaningful;
+under current implementations, it will probably be the line number of the
+last line in the file.
+
+=item events with an element_name of Para
+
+Parsing a plain (non-verbatim, non-directive, non-data) paragraph in
+a Pod document produces this event structure:
+
+ <Para start_line="543">
+ ...all events in this paragraph...
+ </Para>
+
+The value of the I<start_line> attribute will be the line number of the start
+of the paragraph.
+
+For example, parsing this paragraph of Pod:
+
+ The value of the I<start_line> attribute will be the
+ line number of the start of the paragraph.
+
+produces this event structure:
+
+ <Para start_line="129">
+ The value of the
+ <I>
+ start_line
+ </I>
+ attribute will be the line number of the first Pod directive
+ in the document.
+ </Para>
+
+=item events with an element_name of B, C, F, or I.
+
+Parsing a BE<lt>...E<gt> formatting code (or of course any of its
+semantically identical syntactic variants
+S<BE<lt>E<lt> ... E<gt>E<gt>>,
+or S<BE<lt>E<lt>E<lt>E<lt> ... E<gt>E<gt>E<gt>E<gt>>, etc.)
+produces this event structure:
+
+ <B>
+ ...stuff...
+ </B>
+
+Currently, there are no attributes conveyed.
+
+Parsing C, F, or I codes produce the same structure, with only a
+different element name.
+
+If your parser object has been set to accept other formatting codes,
+then they will be presented like these B/C/F/I codes -- i.e., without
+any attributes.
+
+=item events with an element_name of S
+
+Normally, parsing an SE<lt>...E<gt> sequence produces this event
+structure, just as if it were a B/C/F/I code:
+
+ <S>
+ ...stuff...
+ </S>
+
+However, Pod::Simple (and presumably all derived parsers) offers the
+C<nbsp_for_S> option which, if enabled, will suppress all S events, and
+instead change all spaces in the content to non-breaking spaces. This is
+intended for formatters that output to a format that has no code that
+means the same as SE<lt>...E<gt>, but which has a code/character that
+means non-breaking space.
+
+=item events with an element_name of X
+
+Normally, parsing an XE<lt>...E<gt> sequence produces this event
+structure, just as if it were a B/C/F/I code:
+
+ <X>
+ ...stuff...
+ </X>
+
+However, Pod::Simple (and presumably all derived parsers) offers the
+C<nix_X_codes> option which, if enabled, will suppress all X events
+and ignore their content. For formatters/processors that don't use
+X events, this is presumably quite useful.
+
+
+=item events with an element_name of L
+
+Because the LE<lt>...E<gt> is the most complex construct in the
+language, it should not surprise you that the events it generates are
+the most complex in the language. Most of complexity is hidden away in
+the attribute values, so for those of you writing a Pod formatter that
+produces a non-hypertextual format, you can just ignore the attributes
+and treat an L event structure like a formatting element that
+(presumably) doesn't actually produce a change in formatting. That is,
+the content of the L event structure (as opposed to its
+attributes) is always what text should be displayed.
+
+There are, at first glance, three kinds of L links: URL, man, and pod.
+
+When a LE<lt>I<some_url>E<gt> code is parsed, it produces this event
+structure:
+
+ <L content-implicit="yes" to="that_url" type="url">
+ that_url
+ </L>
+
+The C<type="url"> attribute is always specified for this type of
+L code.
+
+For example, this Pod source:
+
+ L<http://www.perl.com/CPAN/authors/>
+
+produces this event structure:
+
+ <L content-implicit="yes" to="http://www.perl.com/CPAN/authors/" type="url">
+ http://www.perl.com/CPAN/authors/
+ </L>
+
+When a LE<lt>I<manpage(section)>E<gt> code is parsed (and these are
+fairly rare and not terribly useful), it produces this event structure:
+
+ <L content-implicit="yes" to="manpage(section)" type="man">
+ manpage(section)
+ </L>
+
+The C<type="man"> attribute is always specified for this type of
+L code.
+
+For example, this Pod source:
+
+ L<crontab(5)>
+
+produces this event structure:
+
+ <L content-implicit="yes" to="crontab(5)" type="man">
+ crontab(5)
+ </L>
+
+In the rare cases where a man page link has a specified, that text appears
+in a I<section> attribute. For example, this Pod source:
+
+ L<crontab(5)/"ENVIRONMENT">
+
+will produce this event structure:
+
+ <L content-implicit="yes" section="ENVIRONMENT" to="crontab(5)" type="man">
+ "ENVIRONMENT" in crontab(5)
+ </L>
+
+In the rare case where the Pod document has code like
+LE<lt>I<sometext>|I<manpage(section)>E<gt>, then the I<sometext> will appear
+as the content of the element, the I<manpage(section)> text will appear
+only as the value of the I<to> attribute, and there will be no
+C<content-implicit="yes"> attribute (whose presence means that the Pod parser
+had to infer what text should appear as the link text -- as opposed to
+cases where that attribute is absent, which means that the Pod parser did
+I<not> have to infer the link text, because that L code explicitly specified
+some link text.)
+
+For example, this Pod source:
+
+ L<hell itself!|crontab(5)>
+
+will produce this event structure:
+
+ <L to="crontab(5)" type="man">
+ hell itself!
+ </L>
+
+The last type of L structure is for links to/within Pod documents. It is
+the most complex because it can have a I<to> attribute, I<or> a
+I<section> attribute, or both. The C<type="pod"> attribute is always
+specified for this type of L code.
+
+In the most common case, the simple case of a LE<lt>podpageE<gt> code
+produces this event structure:
+
+ <L content-implicit="yes" to="Net::Ping" type="pod">
+ podpage
+ </L>
+
+For example, this Pod source:
+
+ L<Net::Ping>
+
+produces this event structure:
+
+ <L content-implicit="yes" to="Net::Ping" type="pod">
+ Net::Ping
+ </L>
+
+In cases where there is link-text explicitly specified, it
+is to be found in the content of the element (and not the
+attributes), just as with the LE<lt>I<sometext>|I<manpage(section)>E<gt>
+case discussed above. For example, this Pod source:
+
+ L<Perl Error Messages|perldiag>
+
+produces this event structure:
+
+ <L to="perldiag" type="pod">
+ Perl Error Messages
+ </L>
+
+In cases of links to a section in the current Pod document,
+there is a I<section> attribute instead of a I<to> attribute.
+For example, this Pod source:
+
+ L</"Member Data">
+
+produces this event structure:
+
+ <L content-implicit="yes" section="Member Data" type="pod">
+ "Member Data"
+ </L>
+
+As another example, this Pod source:
+
+ L<the various attributes|/"Member Data">
+
+produces this event structure:
+
+ <L section="Member Data" type="pod">
+ the various attributes
+ </L>
+
+In cases of links to a section in a different Pod document,
+there are both a I<section> attribute and a L<to> attribute.
+For example, this Pod source:
+
+ L<perlsyn/"Basic BLOCKs and Switch Statements">
+
+produces this event structure:
+
+ <L content-implicit="yes" section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
+ "Basic BLOCKs and Switch Statements" in perlsyn
+ </L>
+
+As another example, this Pod source:
+
+ L<SWITCH statements|perlsyn/"Basic BLOCKs and Switch Statements">
+
+produces this event structure:
+
+ <L section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
+ SWITCH statements
+ </L>
+
+Incidentally, note that we do not distinguish between these syntaxes:
+
+ L</"Member Data">
+ L<"Member Data">
+ L</Member Data>
+ L<Member Data> [deprecated syntax]
+
+That is, they all produce the same event structure, namely:
+
+ <L content-implicit="yes" section="Member Data" type="pod">
+ &#34;Member Data&#34;
+ </L>
+
+=item events with an element_name of E or Z
+
+While there are Pod codes EE<lt>...E<gt> and ZE<lt>E<gt>, these
+I<do not> produce any E or Z events -- that is, there are no such
+events as E or Z.
+
+=item events with an element_name of Verbatim
+
+When a Pod verbatim paragraph (AKA "codeblock") is parsed, it
+produces this event structure:
+
+ <Verbatim start_line="543" xml:space="preserve">
+ ...text...
+ </Verbatim>
+
+The value of the I<start_line> attribute will be the line number of the
+first line of this verbatim block. The I<xml:space> attribute is always
+present, and always has the value "preserve".
+
+The text content will have tabs already expanded.
+
+
+=item events with an element_name of head1 .. head4
+
+When a "=head1 ..." directive is parsed, it produces this event
+structure:
+
+ <head1>
+ ...stuff...
+ </head1>
+
+For example, a directive consisting of this:
+
+ =head1 Options to C<new> et al.
+
+will produce this event structure:
+
+ <head1 start_line="543">
+ Options to
+ <C>
+ new
+ </C>
+ et al.
+ </head1>
+
+"=head2" thru "=head4" directives are the same, except for the element
+names in the event structure.
+
+=item events with an element_name of over-bullet
+
+When an "=over ... Z<>=back" block is parsed where the items are
+a bulletted list, it will produce this event structure:
+
+ <over-bullet indent="4" start_line="543">
+ <item-bullet start_line="545">
+ ...Stuff...
+ </item-bullet>
+ ...more item-bullets...
+ </over-bullet>
+
+The value of the I<indent> attribute is whatever value is after the
+"=over" directive, as in "=over 8". If no such value is specified
+in the directive, then the I<indent> attribute has the value "4".
+
+For example, this Pod source:
+
+ =over
+
+ =item *
+
+ Stuff
+
+ =item *
+
+ Bar I<baz>!
+
+ =back
+
+produces this event structure:
+
+ <over-bullet indent="4" start_line="10">
+ <item-bullet start_line="12">
+ Stuff
+ </item-bullet>
+ <item-bullet start_line="14">
+ Bar <I>baz</I>!
+ </item-bullet>
+ </over-bullet>
+
+=item events with an element_name of over-number
+
+When an "=over ... Z<>=back" block is parsed where the items are
+a numbered list, it will produce this event structure:
+
+ <over-number indent="4" start_line="543">
+ <item-number number="1" start_line="545">
+ ...Stuff...
+ </item-number>
+ ...more item-number...
+ </over-bullet>
+
+This is like the "over-bullet" event structure; but note that the contents
+are "item-number" instead of "item-bullet", and note that they will have
+a "number" attribute, which some formatters/processors may ignore
+(since, for example, there's no need for it in HTML when producing
+an "<UL><LI>...</LI>...</UL>" structure), but which any processor may use.
+
+Note that the values for the I<number> attributes of "item-number"
+elements in a given "over-number" area I<will> start at 1 and go up by
+one each time. If the Pod source doesn't follow that order (even though
+it really should should!), whatever numbers it has will be ignored (with
+the correct values being put in the I<number> attributes), and an error
+message might be issued to the user.
+
+=item events with an element_name of over-text
+
+These events are are somewhat unlike the other over-*
+structures, as far as what their contents are. When
+an "=over ... Z<>=back" block is parsed where the items are
+a list of text "subheadings", it will produce this event structure:
+
+ <over-text indent="4" start_line="543">
+ <item-text>
+ ...stuff...
+ </item-text>
+ ...stuff (generally Para or Verbatim elements)...
+ <item-text>
+ ...more item-text and/or stuff...
+ </over-text>
+
+The I<indent> attribute is as with the other over-* events.
+
+For example, this Pod source:
+
+ =over
+
+ =item Foo
+
+ Stuff
+
+ =item Bar I<baz>!
+
+ Quux
+
+ =back
+
+produces this event structure:
+
+ <over-text indent="4" start_line="20">
+ <item-text start_line="22">
+ Foo
+ </item-text>
+ <Para start_line="24">
+ Stuff
+ </Para>
+ <item-text start_line="26">
+ Bar
+ <I>
+ baz
+ </I>
+ !
+ </item-text>
+ <Para start_line="28">
+ Quux
+ </Para>
+ </over-text>
+
+
+
+=item events with an element_name of over-block
+
+These events are are somewhat unlike the other over-*
+structures, as far as what their contents are. When
+an "=over ... Z<>=back" block is parsed where there are no items,
+it will produce this event structure:
+
+ <over-block indent="4" start_line="543">
+ ...stuff (generally Para or Verbatim elements)...
+ </over-block>
+
+The I<indent> attribute is as with the other over-* events.
+
+For example, this Pod source:
+
+ =over
+
+ For cutting off our trade with all parts of the world
+
+ For transporting us beyond seas to be tried for pretended offenses
+
+ He is at this time transporting large armies of foreign mercenaries to
+ complete the works of death, desolation and tyranny, already begun with
+ circumstances of cruelty and perfidy scarcely paralleled in the most
+ barbarous ages, and totally unworthy the head of a civilized nation.
+
+ =cut
+
+will produce this event structure:
+
+ <over-block indent="4" start_line="2">
+ <Para start_line="4">
+ For cutting off our trade with all parts of the world
+ </Para>
+ <Para start_line="6">
+ For transporting us beyond seas to be tried for pretended offenses
+ </Para>
+ <Para start_line="8">
+ He is at this time transporting large armies of [...more text...]
+ </Para>
+ </over-block>
+
+=item events with an element_name of item-bullet
+
+See L</"events with an element_name of over-bullet">, above.
+
+=item events with an element_name of item-number
+
+See L</"events with an element_name of over-number">, above.
+
+=item events with an element_name of item-text
+
+See L</"events with an element_name of over-text">, above.
+
+=item events with an element_name of for
+
+TODO...
+
+=item events with an element_name of Data
+
+TODO...
+
+=back
+
+
+
+=head1 More Pod::Simple Methods
+
+Pod::Simple provides a lot of methods that aren't generally interesting
+to the end user of an existing Pod formatter, but some of which you
+might find useful in writing a Pod formatter. They are listed below. The
+first several methods (the accept_* methods) are for declaring the
+capabilites of your parser, notably what C<=for I<targetname>> sections
+it's interested in, what extra NE<lt>...E<gt> codes it accepts beyond
+the ones described in the I<perlpod>.
+
+=over
+
+=item C<< $parser->accept_targets( I<SOMEVALUE> ) >>
+
+As the parser sees sections like:
+
+ =for html <img src="fig1.jpg">
+
+or
+
+ =begin html
+
+ <img src="fig1.jpg">
+
+ =end html
+
+...the parser will ignore these sections unless your subclass has
+specified that it wants to see sections targetted to "html" (or whatever
+the formatter name is).
+
+If you want to process all sections, even if they're not targetted for you,
+call this before you start parsing:
+
+ $parser->accept_targets('*');
+
+=item C<< $parser->accept_targets_as_text( I<SOMEVALUE> ) >>
+
+This is like accept_targets, except that it specifies also that the
+content of sections for this target should be treated as Pod text even
+if the target name in "=for I<targetname>" doesn't start with a ":".
+
+At time of writing, I don't think you'll need to use this.
+
+
+=item C<< $parser->accept_codes( I<Codename>, I<Codename>... ) >>
+
+This tells the parser that you accept additional formatting codes,
+beyond just the standard ones (I B C L F S X, plus the two weird ones
+you don't actually see in the parse tree, Z and E). For example, to also
+accept codes "N", "R", and "W":
+
+ $parser->accept_codes( qw( N R W ) );
+
+B<TODO: document how this interacts with =extend, and long element names>
+
+
+=item C<< $parser->accept_directive_as_data( I<directive_name> ) >>
+
+=item C<< $parser->accept_directive_as_verbatim( I<directive_name> ) >>
+
+=item C<< $parser->accept_directive_as_processed( I<directive_name> ) >>
+
+In the unlikely situation that you need to tell the parser that you will
+accept additional directives ("=foo" things), you need to first set the
+parset to treat its content as data (i.e., not really processed at
+all), or as verbatim (mostly just expanding tabs), or as processed text
+(parsing formatting codes like BE<lt>...E<gt>).
+
+For example, to accept a new directive "=method", you'd presumably
+use:
+
+ $parser->accept_directive_as_processed("method");
+
+so that you could have Pod lines like:
+
+ =method I<$whatever> thing B<um>
+
+Making up your own directives breaks compatibility with other Pod
+formatters, in a way that using "=for I<target> ..." lines doesn't;
+however, you may find this useful if you're making a Pod superset
+format where you don't need to worry about compatibility.
+
+
+=item C<< $parser->nbsp_for_S( I<BOOLEAN> ); >>
+
+Setting this attribute to a true value (and by default it is false) will
+turn "SE<lt>...E<gt>" sequences into sequences of words separated by
+C<\xA0> (non-breaking space) characters. For example, it will take this:
+
+ I like S<Dutch apple pie>, don't you?
+
+and treat it as if it were:
+
+ I like DutchE<nbsp>appleE<nbsp>pie, don't you?
+
+This is handy for output formats that don't have anything quite like an
+"SE<lt>...E<gt>" code, but which do have a code for non-breaking space.
+
+There is currently no method for going the other way; but I can
+probably provide one upon request.
+
+
+=item C<< $parser->version_report() >>
+
+This returns a string reporting the $VERSION value from your module (and
+its classname) as well as the $VERSION value of Pod::Simple. Note that
+L<perlpodspec> requires output formats (wherever possible) to note
+this detail in a comment in the output format. For example, for
+some kind of SGML output format:
+
+ print OUT "<!-- \n", $parser->version_report, "\n -->";
+
+
+=item C<< $parser->pod_para_count() >>
+
+This returns the count of Pod paragraphs seen so far.
+
+
+=item C<< $parser->line_count() >>
+
+This is the current line number being parsed. But you might find the
+"line_number" event attribute more accurate, when it is present.
+
+
+=item C<< $parser->nix_X_codes( I<SOMEVALUE> ) >>
+
+This attribute, when set to a true value (and it is false by default)
+ignores any "XE<lt>...E<gt>" sequences in the document being parsed.
+Many formats don't actually use the content of these codes, so have
+no reason to process them.
+
+
+=item C<< $parser->merge_text( I<SOMEVALUE> ) >>
+
+This attribute, when set to a true value (and it is false by default)
+makes sure that only one event (or token, or node) will be created
+for any single contiguous sequence of text. For example, consider
+this somewhat contrived example:
+
+ I just LOVE Z<>hotE<32>apple pie!
+
+When that is parsed and events are about to be called on it, it may
+actually seem to be four different text events, one right after another:
+one event for "I just LOVE ", one for "hot", one for " ", and one for
+"apple pie!". But if you have merge_text on, then you're guaranteed
+that it will be fired as one text event: "I just LOVE hot apple pie!".
+
+
+=item C<< $parser->code_handler( I<CODE_REF> ) >>
+
+This specifies code that should be called when a code line is seen
+(i.e., a line outside of the Pod). Normally this is undef, meaning
+that no code should be called. If you provide a routine, it should
+start out like this:
+
+ sub get_code_line { # or whatever you'll call it
+ my($line, $line_number, $parser) = @_;
+ ...
+ }
+
+Note, however, that sometimes the Pod events aren't processed in exactly
+the same order as the code lines are -- i.e., if you have a file with
+Pod, then code, then more Pod, sometimes the code will be processed (via
+whatever you have code_handler call) before the all of the preceding Pod
+has been processed.
+
+
+=item C<< $parser->cut_handler( I<CODE_REF> ) >>
+
+This is just like the code_handler attribute, except that it's for
+"=cut" lines, not code lines. The same caveats apply. "=cut" lines are
+unlikely to be interesting, but this is included for completeness.
+
+
+=item C<< $parser->whine( I<linenumber>, I<complaint string> ) >>
+
+This notes a problem in the Pod, which will be reported to in the "Pod
+Errors" section of the document and/or send to STDERR, depending on the
+values of the attributes C<no_whining>, C<no_errata_section>, and
+C<complain_stderr>.
+
+=item C<< $parser->scream( I<linenumber>, I<complaint string> ) >>
+
+This notes an error like C<whine> does, except that it is not
+suppressable with C<no_whining>. This should be used only for very
+serious errors.
+
+
+=item C<< $parser->source_dead(1) >>
+
+This aborts parsing of the current document, by switching on the flag
+that indicates that EOF has been seen. In particularly drastic cases,
+you might want to do this. It's rather nicer than just calling
+C<die>!
+
+=item C<< $parser->hide_line_numbers( I<SOMEVALUE> ) >>
+
+Some subclasses that indescriminately dump event attributes (well,
+except for ones beginning with "~") can use this object attribute for
+refraining to dump the "start_line" attribute.
+
+=item C<< $parser->no_whining( I<SOMEVALUE> ) >>
+
+This attribute, if set to true, will suppress reports of non-fatal
+error messages. The default value is false, meaning that complaints
+I<are> reported. How they get reported depends on the values of
+the attributes C<no_errata_section> and C<complain_stderr>.
+
+=item C<< $parser->no_errata_section( I<SOMEVALUE> ) >>
+
+This attribute, if set to true, will suppress generation of an errata
+section. The default value is false -- i.e., an errata section will be
+generated.
+
+=item C<< $parser->complain_stderr( I<SOMEVALUE> ) >>
+
+This attribute, if set to true will send complaints to STDERR. The
+default value is false -- i.e., complaints do not go to STDERR.
+
+=item C<< $parser->bare_output( I<SOMEVALUE> ) >>
+
+Some formatter subclasses use this as a flag for whether output should
+have prologue and epilogue code omitted. For example, setting this to
+true for an HTML formatter class should omit the
+"<html><head><title>...</title><body>..." prologue and the
+"</body></html>" epilogue.
+
+If you want to set this to true, you should probably also set
+C<no_whining> or at least C<no_errata_section> to true.
+
+=item C<< $parser->preserve_whitespace( I<SOMEVALUE> ) >>
+
+If you set this attribute to a true value, the parser will try to
+preserve whitespace in the output. This means that such formatting
+conventions as two spaces after periods will be preserved by the parser.
+This is primarily useful for output formats that treat whitespace as
+significant (such as text or *roff, but not HTML).
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple> -- event-based Pod-parsing framework
+
+L<Pod::Simple::Methody> -- like Pod::Simple, but each sort of event
+calls its own method (like C<start_head3>)
+
+L<Pod::Simple::PullParser> -- a Pod-parsing framework like Pod::Simple,
+but with a token-stream interface
+
+L<Pod::Simple::SimpleTree> -- a Pod-parsing framework like Pod::Simple,
+but with a tree interface
+
+L<Pod::Simple::Checker> -- a simple Pod::Simple subclass that reads
+documents, and then makes a plaintext report of any errors found in the
+document
+
+L<Pod::Simple::DumpAsXML> -- for dumping Pod documents as tidily
+indented XML, showing each event on its own line
+
+L<Pod::Simple::XMLOutStream> -- dumps a Pod document as XML (without
+introducing extra whitespace as Pod::Simple::DumpAsXML does).
+
+L<Pod::Simple::DumpAsText> -- for dumping Pod documents as tidily
+indented text, showing each event on its own line
+
+L<Pod::Simple::LinkSection> -- class for objects representing the values
+of the TODO and TODO attributes of LE<lt>...E<gt> elements
+
+L<Pod::Escapes> -- the module the Pod::Simple uses for evaluating
+EE<lt>...E<gt> content
+
+L<Pod::Simple::Text> -- a simple plaintext formatter for Pod
+
+L<Pod::Simple::TextContent> -- like Pod::Simple::Text, but
+makes no effort for indent or wrap the text being formatted
+
+L<perlpod|perlpod>
+
+L<perlpodspec|perlpodspec>
+
+L<perldoc>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
+
+=for notes
+Hm, my old podchecker version (1.2) says:
+ *** WARNING: node 'http://search.cpan.org/' contains non-escaped | or / at line 38 in file Subclassing.pod
+ *** WARNING: node 'http://lists.perl.org/showlist.cgi?name=pod-people' contains non-escaped | or / at line 41 in file Subclassing.pod
+Yes, L<...> is hard.
+
+
+=cut
+
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm
new file mode 100755
index 00000000000..fe89806eaba
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm
@@ -0,0 +1,185 @@
+
+require 5;
+package Pod::Simple::Text;
+use strict;
+use Carp ();
+use Pod::Simple::Methody ();
+use Pod::Simple ();
+use vars qw( @ISA $VERSION $FREAKYMODE);
+$VERSION = '3.13';
+@ISA = ('Pod::Simple::Methody');
+BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
+ ? \&Pod::Simple::DEBUG
+ : sub() {0}
+ }
+
+use Text::Wrap 98.112902 ();
+$Text::Wrap::wrap = 'overflow';
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->accept_target_as_text(qw( text plaintext plain ));
+ $new->nix_X_codes(1);
+ $new->nbsp_for_S(1);
+ $new->{'Thispara'} = '';
+ $new->{'Indent'} = 0;
+ $new->{'Indentstring'} = ' ';
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub handle_text { $_[0]{'Thispara'} .= $_[1] }
+
+sub start_Para { $_[0]{'Thispara'} = '' }
+sub start_head1 { $_[0]{'Thispara'} = '' }
+sub start_head2 { $_[0]{'Thispara'} = '' }
+sub start_head3 { $_[0]{'Thispara'} = '' }
+sub start_head4 { $_[0]{'Thispara'} = '' }
+
+sub start_Verbatim { $_[0]{'Thispara'} = '' }
+sub start_item_bullet { $_[0]{'Thispara'} = $FREAKYMODE ? '' : '* ' }
+sub start_item_number { $_[0]{'Thispara'} = $FREAKYMODE ? '' : "$_[1]{'number'}. " }
+sub start_item_text { $_[0]{'Thispara'} = '' }
+
+sub start_over_bullet { ++$_[0]{'Indent'} }
+sub start_over_number { ++$_[0]{'Indent'} }
+sub start_over_text { ++$_[0]{'Indent'} }
+sub start_over_block { ++$_[0]{'Indent'} }
+
+sub end_over_bullet { --$_[0]{'Indent'} }
+sub end_over_number { --$_[0]{'Indent'} }
+sub end_over_text { --$_[0]{'Indent'} }
+sub end_over_block { --$_[0]{'Indent'} }
+
+
+# . . . . . Now the actual formatters:
+
+sub end_head1 { $_[0]->emit_par(-4) }
+sub end_head2 { $_[0]->emit_par(-3) }
+sub end_head3 { $_[0]->emit_par(-2) }
+sub end_head4 { $_[0]->emit_par(-1) }
+sub end_Para { $_[0]->emit_par( 0) }
+sub end_item_bullet { $_[0]->emit_par( 0) }
+sub end_item_number { $_[0]->emit_par( 0) }
+sub end_item_text { $_[0]->emit_par(-2) }
+sub start_L { $_[0]{'Link'} = $_[1] if $_[1]->{type} eq 'url' }
+sub end_L {
+ if (my $link = delete $_[0]{'Link'}) {
+ # Append the URL to the output unless it's already present.
+ $_[0]{'Thispara'} .= " <$link->{to}>"
+ unless $_[0]{'Thispara'} =~ /\b\E$link->{to}/;
+ }
+}
+
+sub emit_par {
+ my($self, $tweak_indent) = splice(@_,0,2);
+ my $indent = ' ' x ( 2 * $self->{'Indent'} + 4 + ($tweak_indent||0) );
+ # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0
+
+ $self->{'Thispara'} =~ tr{\xAD}{}d if Pod::Simple::ASCII;
+ my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n");
+ $out =~ tr{\xA0}{ } if Pod::Simple::ASCII;
+ print {$self->{'output_fh'}} $out, "\n";
+ $self->{'Thispara'} = '';
+
+ return;
+}
+
+# . . . . . . . . . . And then off by its lonesome:
+
+sub end_Verbatim {
+ my $self = shift;
+ if(Pod::Simple::ASCII) {
+ $self->{'Thispara'} =~ tr{\xA0}{ };
+ $self->{'Thispara'} =~ tr{\xAD}{}d;
+ }
+
+ my $i = ' ' x ( 2 * $self->{'Indent'} + 4);
+ #my $i = ' ' x (4 + $self->{'Indent'});
+
+ $self->{'Thispara'} =~ s/^/$i/mg;
+
+ print { $self->{'output_fh'} } '',
+ $self->{'Thispara'},
+ "\n\n"
+ ;
+ $self->{'Thispara'} = '';
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::Text -- format Pod as plaintext
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::Text -e \
+ "exit Pod::Simple::Text->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+This class is a formatter that takes Pod and renders it as
+wrapped plaintext.
+
+Its wrapping is done by L<Text::Wrap>, so you can change
+C<$Text::Wrap::columns> as you like.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::TextContent>, L<Pod::Text>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm
new file mode 100755
index 00000000000..badce4ddcad
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm
@@ -0,0 +1,112 @@
+
+
+require 5;
+package Pod::Simple::TextContent;
+use strict;
+use Carp ();
+use Pod::Simple ();
+use vars qw( @ISA $VERSION );
+$VERSION = '3.13';
+@ISA = ('Pod::Simple');
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->nix_X_codes(1);
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub _handle_element_start {
+ print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
+ return;
+}
+
+sub _handle_text {
+ if( chr(65) eq 'A' ) { # in ASCIIworld
+ $_[1] =~ tr/\xAD//d;
+ $_[1] =~ tr/\xA0/ /;
+ }
+ print {$_[0]{'output_fh'}} $_[1];
+ return;
+}
+
+sub _handle_element_end {
+ print {$_[0]{'output_fh'}} "\n" unless $_[1] =~ m/^[A-Z]$/s;
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::TextContent -- get the text content of Pod
+
+=head1 SYNOPSIS
+
+ TODO
+
+ perl -MPod::Simple::TextContent -e \
+ "exit Pod::Simple::TextContent->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+This class is that parses Pod and dumps just the text content. It is
+mainly meant for use by the Pod::Simple test suite, but you may find
+some other use for it.
+
+This is a subclass of L<Pod::Simple> and inherits all its methods.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002 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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm
new file mode 100755
index 00000000000..2899c0dbc82
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm
@@ -0,0 +1,105 @@
+
+use strict;
+package Pod::Simple::TiedOutFH;
+use Symbol ('gensym');
+use Carp ();
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub handle_on { # some horrible frightening things are encapsulated in here
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ Carp::croak "Usage: ${class}->handle_on(\$somescalar)" unless @_;
+
+ my $x = (defined($_[0]) and ref($_[0]))
+ ? $_[0]
+ : ( \( $_[0] ) )[0]
+ ;
+ $$x = '' unless defined $$x;
+
+ #Pod::Simple::DEBUG and print "New $class handle on $x = \"$$x\"\n";
+
+ my $new = gensym();
+ tie *$new, $class, $x;
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub TIEHANDLE { # Ties to just a scalar ref
+ my($class, $scalar_ref) = @_;
+ $$scalar_ref = '' unless defined $$scalar_ref;
+ return bless \$scalar_ref, ref($class) || $class;
+}
+
+sub PRINT {
+ my $it = shift;
+ foreach my $x (@_) { $$$it .= $x }
+
+ #Pod::Simple::DEBUG > 10 and print " appended to $$it = \"$$$it\"\n";
+
+ return 1;
+}
+
+sub FETCH {
+ return ${$_[0]};
+}
+
+sub PRINTF {
+ my $it = shift;
+ my $format = shift;
+ $$$it .= sprintf $format, @_;
+ return 1;
+}
+
+sub FILENO { ${ $_[0] } + 100 } # just to produce SOME number
+
+sub CLOSE { 1 }
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1;
+__END__
+
+Chole
+
+ * 1 large red onion
+ * 2 tomatillos
+ * 4 or 5 roma tomatoes (optionally with the pulp discarded)
+ * 1 tablespoons chopped ginger root (or more, to taste)
+ * 2 tablespoons canola oil (or vegetable oil)
+
+ * 1 tablespoon garam masala
+ * 1/2 teaspoon red chili powder, or to taste
+ * Salt, to taste (probably quite a bit)
+ * 2 (15-ounce) cans chick peas or garbanzo beans, drained and rinsed
+ * juice of one smallish lime
+ * a dash of balsamic vinegar (to taste)
+ * cooked rice, preferably long-grain white rice (whether plain,
+ basmati rice, jasmine rice, or even a mild pilaf)
+
+In a blender or food processor, puree the onions, tomatoes, tomatillos,
+and ginger root. You can even do it with a Braun hand "mixer", if you
+chop things finer to start with, and work at it.
+
+In a saucepan set over moderate heat, warm the oil until hot.
+
+Add the puree and the balsamic vinegar, and cook, stirring occasionally,
+for 20 to 40 minutes. (Cooking it longer will make it sweeter.)
+
+Add the Garam Masala, chili powder, and cook, stirring occasionally, for
+5 minutes.
+
+Add the salt and chick peas and cook, stirring, until heated through.
+
+Stir in the lime juice, and optionally one or two teaspoons of tahini.
+You can let it simmer longer, depending on how much softer you want the
+garbanzos to get.
+
+Serve over rice, like a curry.
+
+Yields 5 to 7 servings.
+
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm
new file mode 100755
index 00000000000..80f9f1c1be6
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm
@@ -0,0 +1,35 @@
+
+require 5;
+package Pod::Simple::Transcode;
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+BEGIN {
+ if(defined &DEBUG) {;} # Okay
+ elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG; }
+ else { *DEBUG = sub () {0}; }
+}
+
+foreach my $class (
+ 'Pod::Simple::TranscodeSmart',
+ 'Pod::Simple::TranscodeDumb',
+ '',
+) {
+ $class or die "Couldn't load any encoding classes";
+ DEBUG and print "About to try loading $class...\n";
+ eval "require $class;";
+ if($@) {
+ DEBUG and print "Couldn't load $class: $@\n";
+ } else {
+ DEBUG and print "OK, loaded $class.\n";
+ @ISA = ($class);
+ last;
+ }
+}
+
+sub _blorp { return; } # just to avoid any "empty class" warning
+
+1;
+__END__
+
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm
new file mode 100755
index 00000000000..afdc0c43a0d
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm
@@ -0,0 +1,63 @@
+
+require 5;
+## This module is to be use()'d only by Pod::Simple::Transcode
+
+package Pod::Simple::TranscodeDumb;
+use strict;
+use vars qw($VERSION %Supported);
+$VERSION = '3.13';
+# This module basically pretends it knows how to transcode, except
+# only for null-transcodings! We use this when Encode isn't
+# available.
+
+%Supported = (
+ 'ascii' => 1,
+ 'ascii-ctrl' => 1,
+ 'iso-8859-1' => 1,
+ 'null' => 1,
+ 'latin1' => 1,
+ 'latin-1' => 1,
+ %Supported,
+);
+
+sub is_dumb {1}
+sub is_smart {0}
+
+sub all_encodings {
+ return sort keys %Supported;
+}
+
+sub encoding_is_available {
+ return exists $Supported{lc $_[1]};
+}
+
+sub encmodver {
+ return __PACKAGE__ . " v" .($VERSION || '?');
+}
+
+sub make_transcoder {
+ my($e) = $_[1];
+ die "WHAT ENCODING!?!?" unless $e;
+ my $x;
+ return sub {;
+ #foreach $x (@_) {
+ # if(Pod::Simple::ASCII and !Pod::Simple::UNICODE and $] > 5.005) {
+ # # We're in horrible gimp territory, so we need to knock out
+ # # all the highbit things
+ # $x =
+ # pack 'C*',
+ # map {; ($_ < 128) ? $_ : 0x7e }
+ # unpack "C*",
+ # $x
+ # ;
+ # }
+ #}
+ #
+ #return;
+ };
+}
+
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm
new file mode 100755
index 00000000000..d6dc62cbe82
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm
@@ -0,0 +1,44 @@
+
+require 5;
+use 5.008;
+## Anything before 5.8.0 is GIMPY!
+## This module is to be use()'d only by Pod::Simple::Transcode
+
+package Pod::Simple::TranscodeSmart;
+use strict;
+use Pod::Simple;
+require Encode;
+use vars qw($VERSION );
+$VERSION = '3.13';
+
+sub is_dumb {0}
+sub is_smart {1}
+
+sub all_encodings {
+ return Encode::->encodings(':all');
+}
+
+sub encoding_is_available {
+ return Encode::resolve_alias($_[1]);
+}
+
+sub encmodver {
+ return "Encode.pm v" .($Encode::VERSION || '?');
+}
+
+sub make_transcoder {
+ my($e) = $_[1];
+ die "WHAT ENCODING!?!?" unless $e;
+ my $x;
+ return sub {
+ foreach $x (@_) {
+ $x = Encode::decode($e, $x);
+ }
+ return;
+ };
+}
+
+
+1;
+
+
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm
new file mode 100755
index 00000000000..fd4c9d6f7f9
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm
@@ -0,0 +1,717 @@
+=pod
+
+=head1 NAME
+
+Pod::Simple::XHTML -- format Pod as validating XHTML
+
+=head1 SYNOPSIS
+
+ use Pod::Simple::XHTML;
+
+ my $parser = Pod::Simple::XHTML->new();
+
+ ...
+
+ $parser->parse_file('path/to/file.pod');
+
+=head1 DESCRIPTION
+
+This class is a formatter that takes Pod and renders it as XHTML
+validating HTML.
+
+This is a subclass of L<Pod::Simple::Methody> and inherits all its
+methods. The implementation is entirely different than
+L<Pod::Simple::HTML>, but it largely preserves the same interface.
+
+=cut
+
+package Pod::Simple::XHTML;
+use strict;
+use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES );
+$VERSION = '3.13';
+use Carp ();
+use Pod::Simple::Methody ();
+@ISA = ('Pod::Simple::Methody');
+
+BEGIN {
+ $HAS_HTML_ENTITIES = eval "require HTML::Entities; 1";
+}
+
+my %entities = (
+ q{>} => 'gt',
+ q{<} => 'lt',
+ q{'} => '#39',
+ q{"} => 'quot',
+ q{&} => 'amp',
+);
+
+sub encode_entities {
+ return HTML::Entities::encode_entities( $_[0] ) if $HAS_HTML_ENTITIES;
+ my $str = $_[0];
+ my $ents = join '', keys %entities;
+ $str =~ s/([$ents])/'&' . $entities{$1} . ';'/ge;
+ return $str;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+=head1 METHODS
+
+Pod::Simple::XHTML offers a number of methods that modify the format of
+the HTML output. Call these after creating the parser object, but before
+the call to C<parse_file>:
+
+ my $parser = Pod::PseudoPod::HTML->new();
+ $parser->set_optional_param("value");
+ $parser->parse_file($file);
+
+=head2 perldoc_url_prefix
+
+In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what
+to put before the "Foo%3a%3aBar". The default value is
+"http://search.cpan.org/perldoc?".
+
+=head2 perldoc_url_postfix
+
+What to put after "Foo%3a%3aBar" in the URL. This option is not set by
+default.
+
+=head2 man_url_prefix
+
+In turning C<< L<crontab(5)> >> into http://whatever/man/1/crontab, what
+to put before the "1/crontab". The default value is
+"http://man.he.net/man".
+
+=head2 man_url_postfix
+
+What to put after "1/crontab" in the URL. This option is not set by default.
+
+=head2 title_prefix, title_postfix
+
+What to put before and after the title in the head. The values should
+already be &-escaped.
+
+=head2 html_css
+
+ $parser->html_css('path/to/style.css');
+
+The URL or relative path of a CSS file to include. This option is not
+set by default.
+
+=head2 html_javascript
+
+The URL or relative path of a JavaScript file to pull in. This option is
+not set by default.
+
+=head2 html_doctype
+
+A document type tag for the file. This option is not set by default.
+
+=head2 html_header_tags
+
+Additional arbitrary HTML tags for the header of the document. The
+default value is just a content type header tag:
+
+ <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
+
+Add additional meta tags here, or blocks of inline CSS or JavaScript
+(wrapped in the appropriate tags).
+
+=head2 html_h_level
+
+This is the level of HTML "Hn" element to which a Pod "head1" corresponds. For
+example, if C<html_h_level> is set to 2, a head1 will produce an H2, a head2
+will produce an H3, and so on.
+
+=head2 default_title
+
+Set a default title for the page if no title can be determined from the
+content. The value of this string should already be &-escaped.
+
+=head2 force_title
+
+Force a title for the page (don't try to determine it from the content).
+The value of this string should already be &-escaped.
+
+=head2 html_header, html_footer
+
+Set the HTML output at the beginning and end of each file. The default
+header includes a title, a doctype tag (if C<html_doctype> is set), a
+content tag (customized by C<html_header_tags>), a tag for a CSS file
+(if C<html_css> is set), and a tag for a Javascript file (if
+C<html_javascript> is set). The default footer simply closes the C<html>
+and C<body> tags.
+
+The options listed above customize parts of the default header, but
+setting C<html_header> or C<html_footer> completely overrides the
+built-in header or footer. These may be useful if you want to use
+template tags instead of literal HTML headers and footers or are
+integrating converted POD pages in a larger website.
+
+If you want no headers or footers output in the HTML, set these options
+to the empty string.
+
+=head2 index
+
+Whether to add a table-of-contents at the top of each page (called an
+index for the sake of tradition).
+
+
+=cut
+
+__PACKAGE__->_accessorize(
+ 'perldoc_url_prefix',
+ 'perldoc_url_postfix',
+ 'man_url_prefix',
+ 'man_url_postfix',
+ 'title_prefix', 'title_postfix',
+ 'html_css',
+ 'html_javascript',
+ 'html_doctype',
+ 'html_header_tags',
+ 'html_h_level',
+ 'title', # Used internally for the title extracted from the content
+ 'default_title',
+ 'force_title',
+ 'html_header',
+ 'html_footer',
+ 'index',
+ 'batch_mode', # whether we're in batch mode
+ 'batch_mode_current_level',
+ # When in batch mode, how deep the current module is: 1 for "LWP",
+ # 2 for "LWP::Procotol", 3 for "LWP::Protocol::GHTTP", etc
+);
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+=head1 SUBCLASSING
+
+If the standard options aren't enough, you may want to subclass
+Pod::Simple::XHMTL. These are the most likely candidates for methods
+you'll want to override when subclassing.
+
+=cut
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ $new->perldoc_url_prefix('http://search.cpan.org/perldoc?');
+ $new->man_url_prefix('http://man.he.net/man');
+ $new->html_header_tags('<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />');
+ $new->nix_X_codes(1);
+ $new->codes_in_verbatim(1);
+ $new->{'scratch'} = '';
+ $new->{'to_index'} = [];
+ $new->{'output'} = [];
+ $new->{'saved'} = [];
+ $new->{'ids'} = {};
+
+ $new->{'__region_targets'} = [];
+ $new->{'__literal_targets'} = {};
+ $new->accept_targets_as_html( 'html', 'HTML' );
+
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+=head2 handle_text
+
+This method handles the body of text within any element: it's the body
+of a paragraph, or everything between a "=begin" tag and the
+corresponding "=end" tag, or the text within an L entity, etc. You would
+want to override this if you are adding a custom element type that does
+more than just display formatted text. Perhaps adding a way to generate
+HTML tables from an extended version of POD.
+
+So, let's say you want add a custom element called 'foo'. In your
+subclass's C<new> method, after calling C<SUPER::new> you'd call:
+
+ $new->accept_targets_as_text( 'foo' );
+
+Then override the C<start_for> method in the subclass to check for when
+"$flags->{'target'}" is equal to 'foo' and set a flag that marks that
+you're in a foo block (maybe "$self->{'in_foo'} = 1"). Then override the
+C<handle_text> method to check for the flag, and pass $text to your
+custom subroutine to construct the HTML output for 'foo' elements,
+something like:
+
+ sub handle_text {
+ my ($self, $text) = @_;
+ if ($self->{'in_foo'}) {
+ $self->{'scratch'} .= build_foo_html($text);
+ } else {
+ $self->{'scratch'} .= $text;
+ }
+ }
+
+=head2 accept_targets_as_html
+
+This method behaves like C<accept_targets_as_text>, but also marks the region
+as one whose content should be emitted literally, without HTML entity escaping
+or wrapping in a C<div> element.
+
+=cut
+
+sub __in_literal_xhtml_region {
+ return unless @{ $_[0]{__region_targets} };
+ my $target = $_[0]{__region_targets}[-1];
+ return $_[0]{__literal_targets}{ $target };
+}
+
+sub accept_targets_as_html {
+ my ($self, @targets) = @_;
+ $self->accept_targets(@targets);
+ $self->{__literal_targets}{$_} = 1 for @targets;
+}
+
+sub handle_text {
+ # escape special characters in HTML (<, >, &, etc)
+ $_[0]{'scratch'} .= $_[0]->__in_literal_xhtml_region
+ ? $_[1]
+ : encode_entities( $_[1] );
+}
+
+sub start_Para { $_[0]{'scratch'} = '<p>' }
+sub start_Verbatim { $_[0]{'scratch'} = '<pre><code>' }
+
+sub start_head1 { $_[0]{'in_head'} = 1 }
+sub start_head2 { $_[0]{'in_head'} = 2 }
+sub start_head3 { $_[0]{'in_head'} = 3 }
+sub start_head4 { $_[0]{'in_head'} = 4 }
+
+sub start_item_number {
+ $_[0]{'scratch'} = "</li>\n" if $_[0]{'in_li'};
+ $_[0]{'scratch'} .= '<li><p>';
+ $_[0]{'in_li'} = 1
+}
+
+sub start_item_bullet {
+ $_[0]{'scratch'} = "</li>\n" if $_[0]{'in_li'};
+ $_[0]{'scratch'} .= '<li><p>';
+ $_[0]{'in_li'} = 1
+}
+
+sub start_item_text {
+ if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
+ $_[0]{'scratch'} = "</dd>\n";
+ $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
+ }
+ $_[0]{'scratch'} .= '<dt>';
+}
+
+sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
+sub start_over_block { $_[0]{'scratch'} = '<ul>'; $_[0]->emit }
+sub start_over_number { $_[0]{'scratch'} = '<ol>'; $_[0]->emit }
+sub start_over_text {
+ $_[0]{'scratch'} = '<dl>';
+ $_[0]{'dl_level'}++;
+ $_[0]{'in_dd'} ||= [];
+ $_[0]->emit
+}
+
+sub end_over_block { $_[0]{'scratch'} .= '</ul>'; $_[0]->emit }
+
+sub end_over_number {
+ $_[0]{'scratch'} = "</li>\n" if delete $_[0]{'in_li'};
+ $_[0]{'scratch'} .= '</ol>';
+ $_[0]->emit;
+}
+
+sub end_over_bullet {
+ $_[0]{'scratch'} = "</li>\n" if delete $_[0]{'in_li'};
+ $_[0]{'scratch'} .= '</ul>';
+ $_[0]->emit;
+}
+
+sub end_over_text {
+ if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
+ $_[0]{'scratch'} = "</dd>\n";
+ $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
+ }
+ $_[0]{'scratch'} .= '</dl>';
+ $_[0]{'dl_level'}--;
+ $_[0]->emit;
+}
+
+# . . . . . Now the actual formatters:
+
+sub end_Para { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
+sub end_Verbatim {
+ $_[0]{'scratch'} .= '</code></pre>';
+ $_[0]->emit;
+}
+
+sub _end_head {
+ my $h = delete $_[0]{in_head};
+
+ my $add = $_[0]->html_h_level;
+ $add = 1 unless defined $add;
+ $h += $add - 1;
+
+ my $id = $_[0]->idify($_[0]{scratch});
+ my $text = $_[0]{scratch};
+ $_[0]{'scratch'} = qq{<h$h id="$id">$text</h$h>};
+ $_[0]->emit;
+ push @{ $_[0]{'to_index'} }, [$h, $id, $text];
+}
+
+sub end_head1 { shift->_end_head(@_); }
+sub end_head2 { shift->_end_head(@_); }
+sub end_head3 { shift->_end_head(@_); }
+sub end_head4 { shift->_end_head(@_); }
+
+sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
+sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
+
+sub end_item_text {
+ $_[0]{'scratch'} .= "</dt>\n<dd>";
+ $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
+ $_[0]->emit;
+}
+
+# This handles =begin and =for blocks of all kinds.
+sub start_for {
+ my ($self, $flags) = @_;
+
+ push @{ $self->{__region_targets} }, $flags->{target_matching};
+
+ unless ($self->__in_literal_xhtml_region) {
+ $self->{scratch} .= '<div';
+ $self->{scratch} .= qq( class="$flags->{target}") if $flags->{target};
+ $self->{scratch} .= '>';
+ }
+
+ $self->emit;
+
+}
+sub end_for {
+ my ($self) = @_;
+
+ $self->{'scratch'} .= '</div>' unless $self->__in_literal_xhtml_region;
+
+ pop @{ $self->{__region_targets} };
+ $self->emit;
+}
+
+sub start_Document {
+ my ($self) = @_;
+ if (defined $self->html_header) {
+ $self->{'scratch'} .= $self->html_header;
+ $self->emit unless $self->html_header eq "";
+ } else {
+ my ($doctype, $title, $metatags);
+ $doctype = $self->html_doctype || '';
+ $title = $self->force_title || $self->title || $self->default_title || '';
+ $metatags = $self->html_header_tags || '';
+ if ($self->html_css) {
+ $metatags .= "\n<link rel='stylesheet' href='" .
+ $self->html_css . "' type='text/css'>";
+ }
+ if ($self->html_javascript) {
+ $metatags .= "\n<script type='text/javascript' src='" .
+ $self->html_javascript . "'></script>";
+ }
+ $self->{'scratch'} .= <<"HTML";
+$doctype
+<html>
+<head>
+<title>$title</title>
+$metatags
+</head>
+<body>
+HTML
+ $self->emit;
+ }
+}
+
+sub end_Document {
+ my ($self) = @_;
+ my $to_index = $self->{'to_index'};
+ if ($self->index && @{ $to_index } ) {
+ my @out;
+ my $level = 0;
+ my $indent = -1;
+ my $space = '';
+ my $id = ' id="index"';
+
+ for my $h (@{ $to_index }, [0]) {
+ my $target_level = $h->[0];
+ # Get to target_level by opening or closing ULs
+ if ($level == $target_level) {
+ $out[-1] .= '</li>';
+ } elsif ($level > $target_level) {
+ $out[-1] .= '</li>' if $out[-1] =~ /^\s+<li>/;
+ while ($level > $target_level) {
+ --$level;
+ push @out, (' ' x --$indent) . '</li>' if @out && $out[-1] =~ m{^\s+<\/ul};
+ push @out, (' ' x --$indent) . '</ul>';
+ }
+ push @out, (' ' x --$indent) . '</li>' if $level;
+ } else {
+ while ($level < $target_level) {
+ ++$level;
+ push @out, (' ' x ++$indent) . '<li>' if @out && $out[-1]=~ /^\s*<ul/;
+ push @out, (' ' x ++$indent) . "<ul$id>";
+ $id = '';
+ }
+ ++$indent;
+ }
+
+ next unless $level;
+ $space = ' ' x $indent;
+ push @out, sprintf '%s<li><a href="#%s">%s</a>',
+ $space, $h->[1], $h->[2];
+ }
+ # Splice the index in between the HTML headers and the first element.
+ my $offset = defined $self->html_header ? $self->html_header eq '' ? 0 : 1 : 1;
+ splice @{ $self->{'output'} }, $offset, 0, join "\n", @out;
+ }
+
+ if (defined $self->html_footer) {
+ $self->{'scratch'} .= $self->html_footer;
+ $self->emit unless $self->html_footer eq "";
+ } else {
+ $self->{'scratch'} .= "</body>\n</html>";
+ $self->emit;
+ }
+
+ if ($self->index) {
+ print {$self->{'output_fh'}} join ("\n\n", @{ $self->{'output'} }), "\n\n";
+ @{$self->{'output'}} = ();
+ }
+
+}
+
+# Handling code tags
+sub start_B { $_[0]{'scratch'} .= '<b>' }
+sub end_B { $_[0]{'scratch'} .= '</b>' }
+
+sub start_C { $_[0]{'scratch'} .= '<code>' }
+sub end_C { $_[0]{'scratch'} .= '</code>' }
+
+sub start_F { $_[0]{'scratch'} .= '<i>' }
+sub end_F { $_[0]{'scratch'} .= '</i>' }
+
+sub start_I { $_[0]{'scratch'} .= '<i>' }
+sub end_I { $_[0]{'scratch'} .= '</i>' }
+
+sub start_L {
+ my ($self, $flags) = @_;
+ my ($type, $to, $section) = @{$flags}{'type', 'to', 'section'};
+ my $url = $type eq 'url' ? $to
+ : $type eq 'pod' ? $self->resolve_pod_page_link($to, $section)
+ : $type eq 'man' ? $self->resolve_man_page_link($to, $section)
+ : undef;
+
+ # If it's an unknown type, use an attribute-less <a> like HTML.pm.
+ $self->{'scratch'} .= '<a' . ($url ? ' href="'. $url . '">' : '>');
+}
+
+sub end_L { $_[0]{'scratch'} .= '</a>' }
+
+sub start_S { $_[0]{'scratch'} .= '<nobr>' }
+sub end_S { $_[0]{'scratch'} .= '</nobr>' }
+
+sub emit {
+ my($self) = @_;
+ if ($self->index) {
+ push @{ $self->{'output'} }, $self->{'scratch'};
+ } else {
+ print {$self->{'output_fh'}} $self->{'scratch'}, "\n\n";
+ }
+ $self->{'scratch'} = '';
+ return;
+}
+
+=head2 resolve_pod_page_link
+
+ my $url = $pod->resolve_pod_page_link('Net::Ping', 'INSTALL');
+ my $url = $pod->resolve_pod_page_link('perlpodspec');
+ my $url = $pod->resolve_pod_page_link(undef, 'SYNOPSIS');
+
+Resolves a POD link target (typically a module or POD file name) and section
+name to a URL. The resulting link will be returned for the above examples as:
+
+ http://search.cpan.org/perldoc?Net::Ping#INSTALL
+ http://search.cpan.org/perldoc?perlpodspec
+ #SYNOPSIS
+
+Note that when there is only a section argument the URL will simply be a link
+to a section in the current document.
+
+=cut
+
+sub resolve_pod_page_link {
+ my ($self, $to, $section) = @_;
+ return undef unless defined $to || defined $section;
+ if (defined $section) {
+ $section = '#' . $self->idify($section, 1);
+ return $section unless defined $to;
+ } else {
+ $section = ''
+ }
+
+ return ($self->perldoc_url_prefix || '')
+ . encode_entities($to) . $section
+ . ($self->perldoc_url_postfix || '');
+}
+
+=head2 resolve_man_page_link
+
+ my $url = $pod->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE');
+ my $url = $pod->resolve_man_page_link('crontab');
+
+Resolves a man page link target and numeric section to a URL. The resulting
+link will be returned for the above examples as:
+
+ http://man.he.net/man5/crontab
+ http://man.he.net/man1/crontab
+
+Note that the first argument is required. The section number will be parsed
+from it, and if it's missing will default to 1. The second argument is
+currently ignored, as L<man.he.net|http://man.he.net> does not currently
+include linkable IDs or anchor names in its pages. Subclass to link to a
+different man page HTTP server.
+
+=cut
+
+sub resolve_man_page_link {
+ my ($self, $to, $section) = @_;
+ return undef unless defined $to;
+ my ($page, $part) = $to =~ /^([^(]+)(?:[(](\d+)[)])?$/;
+ return undef unless $page;
+ return ($self->man_url_prefix || '')
+ . ($part || 1) . "/" . encode_entities($page)
+ . ($self->man_url_postfix || '');
+
+}
+
+=head2 idify
+
+ my $id = $pod->idify($text);
+ my $hash = $pod->idify($text, 1);
+
+This method turns an arbitrary string into a valid XHTML ID attribute value.
+The rules enforced, following
+L<http://webdesign.about.com/od/htmltags/a/aa031707.htm>, are:
+
+=over
+
+=item *
+
+The id must start with a letter (a-z or A-Z)
+
+=item *
+
+All subsequent characters can be letters, numbers (0-9), hyphens (-),
+underscores (_), colons (:), and periods (.).
+
+=item *
+
+Each id must be unique within the document.
+
+=back
+
+In addition, the returned value will be unique within the context of the
+Pod::Simple::XHTML object unless a second argument is passed a true value. ID
+attributes should always be unique within a single XHTML document, but pass
+the true value if you are creating not an ID but a URL hash to point to
+an ID (i.e., if you need to put the "#foo" in C<< <a href="#foo">foo</a> >>.
+
+=cut
+
+sub idify {
+ my ($self, $t, $not_unique) = @_;
+ for ($t) {
+ s/<[^>]+>//g; # Strip HTML.
+ s/&[^;]+;//g; # Strip entities.
+ s/^([^a-zA-Z]+)$/pod$1/; # Prepend "pod" if no valid chars.
+ s/^[^a-zA-Z]+//; # First char must be a letter.
+ s/[^-a-zA-Z0-9_:.]+/-/g; # All other chars must be valid.
+ }
+ return $t if $not_unique;
+ my $i = '';
+ $i++ while $self->{ids}{"$t$i"}++;
+ return "$t$i";
+}
+
+=head2 batch_mode_page_object_init
+
+ $pod->batch_mode_page_object_init($batchconvobj, $module, $infile, $outfile, $depth);
+
+Called by L<Pod::Simple::HTMLBatch> so that the class has a chance to
+initialize the converter. Internally it sets the C<batch_mode> property to
+true and sets C<batch_mode_current_level()>, but Pod::Simple::XHTML does not
+currently use those features. Subclasses might, though.
+
+=cut
+
+sub batch_mode_page_object_init {
+ my ($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_;
+ $self->batch_mode(1);
+ $self->batch_mode_current_level($depth);
+ return $self;
+}
+
+1;
+
+__END__
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2003-2005 Allison Randal.
+
+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 ACKNOWLEDGEMENTS
+
+Thanks to L<Hurricane Electrict|http://he.net/> for permission to use its
+L<Linux man pages online|http://man.he.net/> site for man page links.
+
+Thanks to L<search.cpan.org|http://search.cpan.org/> for permission to use the
+site for Perl module links.
+
+=head1 AUTHOR
+
+Pod::Simpele::XHTML was created by Allison Randal <allison@perl.org>.
+
+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
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm
new file mode 100755
index 00000000000..afe30cec2b7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm
@@ -0,0 +1,185 @@
+
+require 5;
+package Pod::Simple::XMLOutStream;
+use strict;
+use Carp ();
+use Pod::Simple ();
+use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
+$VERSION = '3.13';
+BEGIN {
+ @ISA = ('Pod::Simple');
+ *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
+}
+
+$ATTR_PAD = "\n" unless defined $ATTR_PAD;
+ # Don't mess with this unless you know what you're doing.
+
+$SORT_ATTRS = 0 unless defined $SORT_ATTRS;
+
+sub new {
+ my $self = shift;
+ my $new = $self->SUPER::new(@_);
+ $new->{'output_fh'} ||= *STDOUT{IO};
+ #$new->accept_codes('VerbatimFormatted');
+ return $new;
+}
+
+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+sub _handle_element_start {
+ # ($self, $element_name, $attr_hash_r)
+ my $fh = $_[0]{'output_fh'};
+ my($key, $value);
+ DEBUG and print "++ $_[1]\n";
+ print $fh "<", $_[1];
+ if($SORT_ATTRS) {
+ foreach my $key (sort keys %{$_[2]}) {
+ unless($key =~ m/^~/s) {
+ next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
+ _xml_escape($value = $_[2]{$key});
+ print $fh $ATTR_PAD, $key, '="', $value, '"';
+ }
+ }
+ } else { # faster
+ while(($key,$value) = each %{$_[2]}) {
+ unless($key =~ m/^~/s) {
+ next if $key eq 'start_line' and $_[0]{'hide_line_numbers'};
+ _xml_escape($value);
+ print $fh $ATTR_PAD, $key, '="', $value, '"';
+ }
+ }
+ }
+ print $fh ">";
+ return;
+}
+
+sub _handle_text {
+ DEBUG and print "== \"$_[1]\"\n";
+ if(length $_[1]) {
+ my $text = $_[1];
+ _xml_escape($text);
+ print {$_[0]{'output_fh'}} $text;
+ }
+ return;
+}
+
+sub _handle_element_end {
+ DEBUG and print "-- $_[1]\n";
+ print {$_[0]{'output_fh'}} "</", $_[1], ">";
+ return;
+}
+
+# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+
+sub _xml_escape {
+ foreach my $x (@_) {
+ # Escape things very cautiously:
+ $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg;
+ # Yes, stipulate the list without a range, so that this can work right on
+ # all charsets that this module happens to run under.
+ # Altho, hmm, what about that ord? Presumably that won't work right
+ # under non-ASCII charsets. Something should be done about that.
+ }
+ return;
+}
+
+#@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+1;
+
+__END__
+
+=head1 NAME
+
+Pod::Simple::XMLOutStream -- turn Pod into XML
+
+=head1 SYNOPSIS
+
+ perl -MPod::Simple::XMLOutStream -e \
+ "exit Pod::Simple::XMLOutStream->filter(shift)->any_errata_seen" \
+ thingy.pod
+
+=head1 DESCRIPTION
+
+Pod::Simple::XMLOutStream is a subclass of L<Pod::Simple> that parses
+Pod and turns it into XML.
+
+Pod::Simple::XMLOutStream inherits methods from
+L<Pod::Simple>.
+
+
+=head1 SEE ALSO
+
+L<Pod::Simple::DumpAsXML> is rather like this class; see its
+documentation for a discussion of the differences.
+
+L<Pod::Simple>, L<Pod::Simple::DumpAsXML>, L<Pod::SAX>
+
+L<Pod::Simple::Subclassing>
+
+The older (and possibly obsolete) libraries L<Pod::PXML>, L<Pod::XML>
+
+
+=head1 ABOUT EXTENDING POD
+
+TODO: An example or two of =extend, then point to Pod::Simple::Subclassing
+
+
+=head1 ASK ME!
+
+If you actually want to use Pod as a format that you want to render to
+XML (particularly if to an XML instance with more elements than normal
+Pod has), please email me (C<sburke@cpan.org>) and I'll probably have
+some recommendations.
+
+For reasons of concision and energetic laziness, some methods and
+options in this module (and the dozen modules it depends on) are
+undocumented; but one of those undocumented bits might be just what
+you're looking for.
+
+=head1 SEE ALSO
+
+L<Pod::Simple>, L<Pod::Simple::Text>, L<Pod::Spell>
+
+=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<http://github.com/theory/pod-simple/>. Feel free to fork and contribute, or
+to clone L<git://github.com/theory/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) 2002-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