diff options
| author | Karl Berry <karl@freefriends.org> | 2017-04-18 23:10:57 +0000 |
|---|---|---|
| committer | Karl Berry <karl@freefriends.org> | 2017-04-18 23:10:57 +0000 |
| commit | 40b4b6e177c62a14c166dbba6adf3abc415af4b2 (patch) | |
| tree | 2996bf29509c806bd8064fb6cf38092c1b375ff8 /Master/tlpkg/tlperl/lib/Pod | |
| parent | 8e743c86b6872f30b7a35c72aa944455157d4b3f (diff) | |
tlperl 5.24.1 from siep
git-svn-id: svn://tug.org/texlive/trunk@43914 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod')
39 files changed, 1221 insertions, 811 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Functions.pm b/Master/tlpkg/tlperl/lib/Pod/Functions.pm index 87b64d178d7..55d6e826659 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Functions.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Functions.pm @@ -54,7 +54,7 @@ L<perlfunc/"Perl Functions by Category"> section. =cut -our $VERSION = '1.09'; +our $VERSION = '1.10'; require Exporter; @@ -207,7 +207,7 @@ glob File expand filenames using wildcards gmtime Time convert UNIX time into record or string using Greenwich time goto Flow create spaghetti code grep LIST locate elements in a list test true against a given criterion -hex Math String convert a string to a hexadecimal number +hex Math String convert a hexadecimal string to a number import Modules Namespace patch a module's namespace into your own index String find a substring within a string int Math get the integer portion of a number @@ -280,7 +280,7 @@ say I/O output a list to a filehandle, appending a newline scalar Misc force a scalar context seek I/O reposition file pointer for random-access I/O seekdir I/O reposition directory pointer -select I/O reset default output or do I/O multiplexing +select File I/O reset default output or do I/O multiplexing semctl SysV SysV semaphore control operations semget SysV get set of SysV semaphores semop SysV SysV semaphore operations diff --git a/Master/tlpkg/tlperl/lib/Pod/Html.pm b/Master/tlpkg/tlperl/lib/Pod/Html.pm index 34729a9c241..cef329e1ef9 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Html.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Html.pm @@ -3,7 +3,7 @@ use strict; require Exporter; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = 1.22; +$VERSION = 1.2201; @ISA = qw(Exporter); @EXPORT = qw(pod2html htmlify); @EXPORT_OK = qw(anchorify); diff --git a/Master/tlpkg/tlperl/lib/Pod/Man.pm b/Master/tlpkg/tlperl/lib/Pod/Man.pm index 72ca9ff1da9..b739559551d 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Man.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Man.pm @@ -11,9 +11,10 @@ # me any patches at the address above in addition to sending them to the # standard Perl mailing lists. # -# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, -# 2010, 2012, 2013 Russ Allbery <rra@stanford.edu> +# Written by Russ Allbery <rra@cpan.org> # Substantial contributions by Sean Burke <sburke@cpan.org> +# Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, +# 2010, 2012, 2013, 2014, 2015, 2016 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -24,19 +25,25 @@ package Pod::Man; -require 5.005; - +use 5.006; use strict; +use warnings; + use subs qw(makespace); use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); -use Carp qw(croak); -use Encode qw(encode); +use Carp qw(carp croak); use Pod::Simple (); +# Conditionally import Encode and set $HAS_ENCODE if it is available. +our $HAS_ENCODE; +BEGIN { + $HAS_ENCODE = eval { require Encode }; +} + @ISA = qw(Pod::Simple); -$VERSION = '2.28'; +$VERSION = '4.07'; # Set the debugging level. If someone has inserted a debug function into this # class already, use that. Otherwise, use any Pod::Simple debug function @@ -139,6 +146,22 @@ sub new { } delete $$self{errors}; + # Degrade back to non-utf8 if Encode is not available. + # + # Suppress the warning message when PERL_CORE is set, indicating this is + # running as part of the core Perl build. Perl builds podlators (and all + # pure Perl modules) before Encode and other XS modules, so Encode won't + # yet be available. Rely on the Perl core build to generate man pages + # later, after all the modules are available, so that UTF-8 handling will + # be correct. + if ($$self{utf8} and !$HAS_ENCODE) { + if (!$ENV{PERL_CORE}) { + carp ('utf8 mode requested but Encode module not available,' + . ' falling back to non-utf8'); + } + delete $$self{utf8}; + } + # Initialize various other internal constants based on our arguments. $self->init_fonts; $self->init_quotes; @@ -204,10 +227,10 @@ sub init_quotes { $$self{LQUOTE} = $$self{RQUOTE} = ''; } elsif (length ($$self{quotes}) == 1) { $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; - } elsif ($$self{quotes} =~ /^(.)(.)$/ - || $$self{quotes} =~ /^(..)(..)$/) { - $$self{LQUOTE} = $1; - $$self{RQUOTE} = $2; + } elsif (length ($$self{quotes}) % 2 == 0) { + my $length = length ($$self{quotes}) / 2; + $$self{LQUOTE} = substr ($$self{quotes}, 0, $length); + $$self{RQUOTE} = substr ($$self{quotes}, $length); } else { croak(qq(Invalid quote specification "$$self{quotes}")) } @@ -662,10 +685,11 @@ sub switchquotes { # to Roman rather than the actual previous font when used in headings. # troff output may still be broken, but at least we can fix nroff by # just switching the font changes to the non-fixed versions. - $nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f[PR]/$1/g; - $nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)\\f([PR])/\\fI$1\\f$2/g; - $nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)\\f([PR])/\\fB$1\\f$2/g; - $nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)\\f([PR])/\\f\(BI$1\\f$2/g; + my $font_end = "(?:\\f[PR]|\Q$$self{FONTS}{100}\E)"; + $nroff =~ s/\Q$$self{FONTS}{100}\E(.*?)\\f([PR])/$1/g; + $nroff =~ s/\Q$$self{FONTS}{101}\E(.*?)$font_end/\\fI$1\\fP/g; + $nroff =~ s/\Q$$self{FONTS}{110}\E(.*?)$font_end/\\fB$1\\fP/g; + $nroff =~ s/\Q$$self{FONTS}{111}\E(.*?)$font_end/\\f\(BI$1\\fP/g; # Now finally output the command. Bother with .ie only if the nroff # and troff output aren't the same. @@ -741,7 +765,7 @@ sub outindex { sub output { my ($self, @text) = @_; if ($$self{ENCODE}) { - print { $$self{output_fh} } encode ('UTF-8', join ('', @text)); + print { $$self{output_fh} } Encode::encode ('UTF-8', join ('', @text)); } else { print { $$self{output_fh} } @text; } @@ -788,7 +812,7 @@ sub start_document { } else { ($name, $section) = $self->devise_title; } - my $date = $$self{date} || $self->devise_date; + my $date = defined($$self{date}) ? $$self{date} : $self->devise_date; $self->preamble ($name, $section, $date) unless $self->bare_output or DEBUG > 9; } @@ -828,45 +852,61 @@ sub devise_title { $section = 3 if (!$$self{section} && $name =~ /\.pm\z/i); $name =~ s/\.p(od|[lm])\z//i; + # If Pod::Parser gave us an IO::File reference as the source file name, + # convert that to the empty string as well. Then, if we don't have a + # valid name, emit a warning and convert it to STDIN. + if ($name =~ /^IO::File(?:=\w+)\(0x[\da-f]+\)$/i) { + $name = ''; + } + if ($name eq '') { + $self->whine (1, 'No name given for document'); + $name = 'STDIN'; + } + # If the section isn't 3, then the name defaults to just the basename of - # the file. Otherwise, assume we're dealing with a module. We want to - # figure out the full module name from the path to the file, but we don't - # want to include too much of the path into the module name. Lose - # anything up to the first off: - # - # */lib/*perl*/ standard or site_perl module - # */*perl*/lib/ from -Dprefix=/opt/perl - # */*perl*/ random module hierarchy - # - # which works. Also strip off a leading site, site_perl, or vendor_perl - # component, any OS-specific component, and any version number component, - # and strip off an initial component of "lib" or "blib/lib" since that's - # what ExtUtils::MakeMaker creates. splitdir requires at least File::Spec - # 0.8. + # the file. if ($section !~ /^3/) { require File::Basename; $name = uc File::Basename::basename ($name); } else { require File::Spec; my ($volume, $dirs, $file) = File::Spec->splitpath ($name); + + # Otherwise, assume we're dealing with a module. We want to figure + # out the full module name from the path to the file, but we don't + # want to include too much of the path into the module name. Lose + # anything up to the first of: + # + # */lib/*perl*/ standard or site_perl module + # */*perl*/lib/ from -Dprefix=/opt/perl + # */*perl*/ random module hierarchy + # + # Also strip off a leading site, site_perl, or vendor_perl component, + # any OS-specific component, and any version number component, and + # strip off an initial component of "lib" or "blib/lib" since that's + # what ExtUtils::MakeMaker creates. + # + # splitdir requires at least File::Spec 0.8. my @dirs = File::Spec->splitdir ($dirs); - my $cut = 0; - my $i; - for ($i = 0; $i < @dirs; $i++) { - if ($dirs[$i] =~ /perl/) { - $cut = $i + 1; - $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib'); - last; + if (@dirs) { + my $cut = 0; + my $i; + for ($i = 0; $i < @dirs; $i++) { + if ($dirs[$i] =~ /perl/) { + $cut = $i + 1; + $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib'); + last; + } } + if ($cut > 0) { + splice (@dirs, 0, $cut); + shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/); + shift @dirs if ($dirs[0] =~ /^[\d.]+$/); + shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/); + } + shift @dirs if $dirs[0] eq 'lib'; + splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib'); } - if ($cut > 0) { - splice (@dirs, 0, $cut); - shift @dirs if ($dirs[0] =~ /^(site|vendor)(_perl)?$/); - shift @dirs if ($dirs[0] =~ /^[\d.]+$/); - shift @dirs if ($dirs[0] =~ /^(.*-$^O|$^O-.*|$^O)$/); - } - shift @dirs if $dirs[0] eq 'lib'; - splice (@dirs, 0, 2) if ($dirs[0] eq 'blib' && $dirs[1] eq 'lib'); # Remove empty directories when building the module name; they # occur too easily on Unix by doubling slashes. @@ -876,25 +916,55 @@ sub devise_title { } # Determine the modification date and return that, properly formatted in ISO -# format. If we can't get the modification date of the input, instead use the -# current time. Pod::Simple returns a completely unuseful stringified file -# handle as the source_filename for input from a file handle, so we have to -# deal with that as well. +# format. +# +# If POD_MAN_DATE is set, that overrides anything else. This can be used for +# reproducible generation of the same file even if the input file timestamps +# are unpredictable or the POD coms from standard input. +# +# Otherwise, if SOURCE_DATE_EPOCH is set and can be parsed as seconds since +# the UNIX epoch, base the timestamp on that. See +# <https://reproducible-builds.org/specs/source-date-epoch/> +# +# Otherwise, use the modification date of the input if we can stat it. Be +# aware that Pod::Simple returns the stringification of the file handle as +# source_filename for input from a file handle, so we'll stat some random ref +# string in that case. If that fails, instead use the current time. +# +# $self - Pod::Man object, used to get the source file +# +# Returns: YYYY-MM-DD date suitable for the left-hand footer sub devise_date { my ($self) = @_; - my $input = $self->source_filename; + + # If POD_MAN_DATE is set, always use it. + if (defined($ENV{POD_MAN_DATE})) { + return $ENV{POD_MAN_DATE}; + } + + # If SOURCE_DATE_EPOCH is set and can be parsed, use that. my $time; - if ($input) { - $time = (stat $input)[9] || time; - } else { - $time = time; + if (defined($ENV{SOURCE_DATE_EPOCH}) && $ENV{SOURCE_DATE_EPOCH} !~ /\D/) { + $time = $ENV{SOURCE_DATE_EPOCH}; } - # Can't use POSIX::strftime(), which uses Fcntl, because MakeMaker - # uses this and it has to work in the core which can't load dynamic - # libraries. - my ($year, $month, $day) = (localtime $time)[5,4,3]; - return sprintf ("%04d-%02d-%02d", $year + 1900, $month + 1, $day); + # Otherwise, get the input filename and try to stat it. If that fails, + # use the current time. + if (!defined $time) { + my $input = $self->source_filename; + if ($input) { + $time = (stat($input))[9] || time(); + } else { + $time = time(); + } + } + + # Can't use POSIX::strftime(), which uses Fcntl, because MakeMaker uses + # this and it has to work in the core which can't load dynamic libraries. + # Use gmtime instead of localtime so that the generated man page does not + # depend on the local time zone setting and is more reproducible + my ($year, $month, $day) = (gmtime($time))[5,4,3]; + return sprintf("%04d-%02d-%02d", $year + 1900, $month + 1, $day); } # Print out the preamble and the title. The meaning of the arguments to .TH @@ -1461,7 +1531,7 @@ sub preamble_template { .ie \n(.g .ds Aq \(aq .el .ds Aq ' .\" -.\" If the F register is turned on, we'll generate index entries on stderr for +.\" If the F register is >0, we'll generate index entries on stderr for .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index .\" entries marked with X<> in POD. Of course, you'll have to process the .\" output yourself in some meaningful fashion. @@ -1469,20 +1539,16 @@ sub preamble_template { .\" Avoid warning from groff about undefined register 'F'. .de IX .. -.nr rF 0 -.if \n(.g .if rF .nr rF 1 -.if (\n(rF:(\n(.g==0)) \{ -. if \nF \{ -. de IX -. tm Index:\\$1\t\\n%\t"\\$2" +.if !\nF .nr F 0 +.if \nF>0 \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" .. -. if !\nF==2 \{ -. nr % 0 -. nr F 2 -. \} +. if !\nF==2 \{\ +. nr % 0 +. nr F 2 . \} .\} -.rr rF ----END OF PREAMBLE---- #'# for cperl-mode @@ -1566,7 +1632,7 @@ __END__ =for stopwords en em ALLCAPS teeny fixedbold fixeditalic fixedbolditalic stderr utf8 UTF-8 Allbery Sean Burke Ossanna Solaris formatters troff uppercased -Christiansen nourls parsers +Christiansen nourls parsers Kernighan =head1 NAME @@ -1629,8 +1695,19 @@ argument. =item center -Sets the centered page header to use instead of "User Contributed Perl -Documentation". +Sets the centered page header for the C<.TH> macro. The default, if this +option is not specified, is "User Contributed Perl Documentation". + +=item date + +Sets the left-hand footer for the C<.TH> macro. If this option is not set, +the contents of the environment variable POD_MAN_DATE, if set, will be used. +Failing that, the value of SOURCE_DATE_EPOCH, the modification date of the +input file, or the current time if stat() can't find that file (which will be +the case if the input is from C<STDIN>) will be used. If obtained from the +file modification date or the current time, the date will be formatted as +C<YYYY-MM-DD> and will be based on UTC (so that the output will be +reproducible regardless of local time zone). =item errors @@ -1642,13 +1719,6 @@ POD errors entirely, as much as possible. The default is C<pod>. -=item date - -Sets the left-hand footer. By default, the modification date of the input -file will be used, or the current date if stat() can't find that file (the -case if the input is from C<STDIN>), and the date will be formatted as -C<YYYY-MM-DD>. - =item fixed The fixed-width font to use for verbatim text and code. Defaults to @@ -1675,12 +1745,16 @@ for B<troff> output. =item name -Set the name of the manual page. Without this option, the manual name is -set to the uppercased base name of the file being converted unless the -manual section is 3, in which case the path is parsed to see if it is a Perl -module path. If it is, a path like C<.../lib/Pod/Man.pm> is converted into -a name like C<Pod::Man>. This option, if given, overrides any automatic -determination of the name. +Set the name of the manual page for the C<.TH> macro. Without this +option, the manual name is set to the uppercased base name of the file +being converted unless the manual section is 3, in which case the path is +parsed to see if it is a Perl module path. If it is, a path like +C<.../lib/Pod/Man.pm> is converted into a name like C<Pod::Man>. This +option, if given, overrides any automatic determination of the name. + +If generating a manual page from standard input, this option is required, +since there's otherwise no way for Pod::Man to know what to use for the +manual page name. =item nourls @@ -1701,10 +1775,9 @@ important. =item quotes Sets the quote marks used to surround CE<lt>> text. If the value is a -single character, it is used as both the left and right quote; if it is two -characters, the first character is used as the left quote and the second as -the right quoted; and if it is four characters, the first two are used as -the left quote and the second two as the right quote. +single character, it is used as both the left and right quote. Otherwise, +it is split in half, and the first half of the string is used as the left +quote and the second is used as the right quote. This may also be set to the special value C<none>, in which case no quote marks are added around CE<lt>> text (but the font is still changed for troff @@ -1712,11 +1785,16 @@ output). =item release -Set the centered footer. By default, this is the version of Perl you run -Pod::Man under. Note that some system an macro sets assume that the -centered footer will be a modification date and will prepend something like -"Last modified: "; if this is the case, you may want to set C<release> to -the last modified date and C<date> to the version number. +Set the centered footer for the C<.TH> macro. By default, this is set to +the version of Perl you run Pod::Man under. Setting this to the empty +string will cause some *roff implementations to use the system default +value. + +Note that some system C<an> macro sets assume that the centered footer +will be a modification date and will prepend something like "Last +modified: ". If this is the case for your target system, you may want to +set C<release> to the last modified date and C<date> to the version +number. =item section @@ -1756,10 +1834,10 @@ by many implementations and may even result in segfaults and other bad behavior. Be aware that, when using this option, the input encoding of your POD -source must be properly declared unless it is US-ASCII or Latin-1. POD -input without an C<=encoding> command will be assumed to be in Latin-1, -and if it's actually in UTF-8, the output will be double-encoded. See -L<perlpod(1)> for more information on the C<=encoding> command. +source should be properly declared unless it's US-ASCII. Pod::Simple will +attempt to guess the encoding and may be successful if it's Latin-1 or +UTF-8, but it will produce warnings. Use the C<=encoding> command to +declare the encoding. See L<perlpod(1)> for more information. =back @@ -1800,8 +1878,8 @@ canonical versions of B<nroff> and B<troff> don't either). =item Invalid quote specification "%s" (F) The quote specification given (the C<quotes> option to the -constructor) was invalid. A quote specification must be one, two, or four -characters long. +constructor) was invalid. A quote specification must be either one +character long or an even number (greater than one) characters long. =item POD document had syntax errors @@ -1810,6 +1888,43 @@ option was set to C<die>. =back +=head1 ENVIRONMENT + +=over 4 + +=item PERL_CORE + +If set and Encode is not available, silently fall back to non-UTF-8 mode +without complaining to standard error. This environment variable is set +during Perl core builds, which build Encode after podlators. Encode is +expected to not (yet) be available in that case. + +=item POD_MAN_DATE + +If set, this will be used as the value of the left-hand footer unless the +C<date> option is explicitly set, overriding the timestamp of the input +file or the current time. This is primarily useful to ensure reproducible +builds of the same output file given the same source and Pod::Man version, +even when file timestamps may not be consistent. + +=item SOURCE_DATE_EPOCH + +If set, and POD_MAN_DATE and the C<date> options are not set, this will be +used as the modification time of the source file, overriding the timestamp of +the input file or the current time. It should be set to the desired time in +seconds since UNIX epoch. This is primarily useful to ensure reproducible +builds of the same output file given the same source and Pod::Man version, +even when file timestamps may not be consistent. See +L<https://reproducible-builds.org/specs/source-date-epoch/> for the full +specification. + +(Arguably, according to the specification, this variable should be used only +if the timestamp of the input file is not available and Pod::Man uses the +current time. However, for reproducible builds in Debian, results were more +reliable if this variable overrode the timestamp of the input file.) + +=back + =head1 BUGS Encoding handling assumes that PerlIO is available and does not work @@ -1860,7 +1975,7 @@ only matters for troff output. =head1 AUTHOR -Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original +Russ Allbery <rra@cpan.org>, based I<very> heavily on the original B<pod2man> by Tom Christiansen <tchrist@mox.perl.com>. The modifications to work with Pod::Simple instead of Pod::Parser were originally contributed by Sean Burke (but I've since hacked them beyond recognition and all bugs are @@ -1869,7 +1984,7 @@ mine). =head1 COPYRIGHT AND LICENSE Copyright 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -2009, 2010, 2012, 2013 Russ Allbery <rra@stanford.edu>. +2009, 2010, 2012, 2013, 2014, 2015, 2016 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm b/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm index 750fdfb88dc..a9e6b34d3ab 100644 --- a/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm +++ b/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm @@ -1,6 +1,6 @@ # Pod::ParseLink -- Parse an L<> formatting code in POD text. # -# Copyright 2001, 2008, 2009 by Russ Allbery <rra@stanford.edu> +# Copyright 2001, 2008, 2009, 2014 by Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -21,16 +21,17 @@ package Pod::ParseLink; -require 5.004; - +use 5.006; use strict; +use warnings; + use vars qw(@EXPORT @ISA $VERSION); use Exporter; @ISA = qw(Exporter); @EXPORT = qw(parselink); -$VERSION = '1.10'; +$VERSION = '4.07'; ############################################################################## # Implementation @@ -123,7 +124,8 @@ markup Allbery URL =head1 SYNOPSIS use Pod::ParseLink; - my ($text, $inferred, $name, $section, $type) = parselink ($link); + my $link = get_link(); + my ($text, $inferred, $name, $section, $type) = parselink($link); =head1 DESCRIPTION @@ -180,11 +182,11 @@ L<http://www.eyrie.org/~eagle/software/podlators/>. =head1 AUTHOR -Russ Allbery <rra@stanford.edu>. +Russ Allbery <rra@cpan.org>. =head1 COPYRIGHT AND LICENSE -Copyright 2001, 2008, 2009 Russ Allbery <rra@stanford.edu>. +Copyright 2001, 2008, 2009 Russ Allbery <rra@cpan.org>. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm index 969019d89ad..787353ba588 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm @@ -12,7 +12,8 @@ use File::Spec::Functions qw(catfile catdir splitdir); use vars qw($VERSION @Pagers $Bindir $Pod2man $Temp_Files_Created $Temp_File_Lifetime ); -$VERSION = '3.25'; +$VERSION = '3.25_03'; # patched in perl5.git +$VERSION =~ s/_//; #.......................................................................... @@ -69,6 +70,7 @@ BEGIN { *is_cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &is_cygwin; *is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux; *is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux; + *is_amigaos = $^O eq 'amigaos' ? \&TRUE : \&FALSE unless defined &is_amigaos; } $Temp_File_Lifetime ||= 60 * 60 * 24 * 5; @@ -484,7 +486,7 @@ sub init_formatter_class_list { $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru $self->opt_o_with('text'); - $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos + $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos || $self->is_amigaos || !($ENV{TERM} && ( ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i )); @@ -573,6 +575,9 @@ sub find_good_formatter_class { my @class_list = @{ $self->{'formatter_classes'} || [] }; $self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list; + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; + my $good_class_found; foreach my $c (@class_list) { DEBUG > 4 and print "Trying to load $c...\n"; @@ -1004,6 +1009,8 @@ sub new_translator { # $tr = $self->new_translator($lang); my $self = shift; my $lang = shift; + local @INC = @INC; + pop @INC if $INC[-1] eq '.'; my $pack = 'POD2::' . uc($lang); eval "require $pack"; if ( !$@ && $pack->can('new') ) { @@ -1662,6 +1669,10 @@ sub pagers_guessing { push @pagers, qw( less.exe more.com< ); unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; } + elsif ( $self->is_amigaos) { + push @pagers, qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE ); + unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER}; + } else { if ($self->is_os2) { unshift @pagers, 'less', 'cmd /c more <'; @@ -1912,10 +1923,15 @@ sub page { # apply a pager to the output file # many many corners of the OS don't like it. So we # have to force it to be "\" to make everyone happy. + # if we are on an amiga convert unix path to an amiga one + $output =~ s/^\/(.*)\/(.*)/$1:$2/ if $self->is_amigaos; + foreach my $pager (@pagers) { $self->aside("About to try calling $pager $output\n"); if ($self->is_vms) { last if system("$pager $output") == 0; + } elsif($self->is_amigaos) { + last if system($pager, $output) == 0; } else { # fix visible escape codes in ToTerm output # https://bugs.debian.org/758689 diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple.pm b/Master/tlpkg/tlperl/lib/Pod/Simple.pm index 538969d9fb2..d8521b2e8be 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple.pm @@ -18,7 +18,7 @@ use vars qw( ); @ISA = ('Pod::Simple::BlackBox'); -$VERSION = '3.29'; +$VERSION = '3.32'; @Known_formatting_codes = qw(I B C L E F S X Z); %Known_formatting_codes = map(($_=>1), @Known_formatting_codes); @@ -35,7 +35,7 @@ BEGIN { else { *ASCII = sub () {''} } unless(defined &MANY_LINES) { *MANY_LINES = sub () {20} } - DEBUG > 4 and print "MANY_LINES is ", MANY_LINES(), "\n"; + DEBUG > 4 and print STDERR "MANY_LINES is ", MANY_LINES(), "\n"; unless(MANY_LINES() >= 1) { die "MANY_LINES is too small (", MANY_LINES(), ")!\nAborting"; } @@ -44,8 +44,24 @@ BEGIN { else { *UNICODE = sub() {''} } } if(DEBUG > 2) { - print "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n"; - print "# We are under a Unicode-safe Perl.\n"; + print STDERR "# We are ", ASCII ? '' : 'not ', "in ASCII-land\n"; + print STDERR "# We are under a Unicode-safe Perl.\n"; +} + +# The NO BREAK SPACE and SOFT HYHPEN are used in several submodules. +if ($] ge 5.007_003) { # On sufficiently modern Perls we can handle any + # character set + $Pod::Simple::nbsp = chr utf8::unicode_to_native(0xA0); + $Pod::Simple::shy = chr utf8::unicode_to_native(0xAD); +} +elsif (Pod::Simple::ASCII) { # Hard code ASCII early Perl + $Pod::Simple::nbsp = "\xA0"; + $Pod::Simple::shy = "\xAD"; +} +else { # EBCDIC on early Perl. We know what the values are for the code + # pages supported then. + $Pod::Simple::nbsp = "\x41"; + $Pod::Simple::shy = "\xCA"; } # Design note: @@ -114,6 +130,10 @@ sub any_errata_seen { # good for using as an exit() value... return shift->{'errors_seen'} || 0; } +sub errata_seen { + return shift->{'all_errata'} || {}; +} + # Returns the encoding only if it was recognized as being handled and set sub detected_encoding { return shift->{'detected_encoding'}; @@ -127,7 +147,7 @@ sub encoding { if ($this->{'_processed_encoding'}) { delete $this->{'_processed_encoding'}; if(! $this->{'encoding_command_statuses'} ) { - DEBUG > 2 and print " CRAZY ERROR: encoding wasn't really handled?!\n"; + DEBUG > 2 and print STDERR " CRAZY ERROR: encoding wasn't really handled?!\n"; } elsif( $this->{'encoding_command_statuses'}[-1] ) { $this->scream( "=encoding $_[0]", sprintf "Couldn't do %s: %s", @@ -135,7 +155,7 @@ sub encoding { $this->{'encoding_command_statuses'}[-1], ); } else { - DEBUG > 2 and print " (encoding successfully handled.)\n"; + DEBUG > 2 and print STDERR " (encoding successfully handled.)\n"; } return $this->{'encoding'}; } else { @@ -179,7 +199,7 @@ sub output_string { require Pod::Simple::TiedOutFH; my $x = (defined($_[0]) and ref($_[0])) ? $_[0] : \( $_[0] ); $$x = '' unless defined $$x; - DEBUG > 4 and print "# Output string set to $x ($$x)\n"; + DEBUG > 4 and print STDERR "# Output string set to $x ($$x)\n"; $this->{'output_fh'} = Pod::Simple::TiedOutFH->handle_on($_[0]); return $this->{'output_string'} = $_[0]; @@ -244,9 +264,9 @@ sub _accept_directives { Carp::croak "\"$d\" is already a reserved Pod directive name" if exists $Known_directives{$d}; $this->{'accept_directives'}{$d} = $type; - DEBUG > 2 and print "Learning to accept \"=$d\" as directive of type $type\n"; + DEBUG > 2 and print STDERR "Learning to accept \"=$d\" as directive of type $type\n"; } - DEBUG > 6 and print "$this\'s accept_directives : ", + DEBUG > 6 and print STDERR "$this\'s accept_directives : ", pretty($this->{'accept_directives'}), "\n"; return sort keys %{ $this->{'accept_directives'} } if wantarray; @@ -267,7 +287,7 @@ sub unaccept_directives { Carp::croak "But you must accept \"$d\" directives -- it's a builtin!" if exists $Known_directives{$d}; delete $this->{'accept_directives'}{$d}; - DEBUG > 2 and print "OK, won't accept \"=$d\" as directive.\n"; + DEBUG > 2 and print STDERR "OK, won't accept \"=$d\" as directive.\n"; } return sort keys %{ $this->{'accept_directives'} } if wantarray; return @@ -292,7 +312,7 @@ sub _accept_targets { next unless defined $t and length $t; # TODO: enforce some limitations on what a target name can be? $this->{'accept_targets'}{$t} = $type; - DEBUG > 2 and print "Learning to accept \"$t\" as target of type $type\n"; + DEBUG > 2 and print STDERR "Learning to accept \"$t\" as target of type $type\n"; } return sort keys %{ $this->{'accept_targets'} } if wantarray; return; @@ -307,7 +327,7 @@ sub unaccept_targets { next unless defined $t and length $t; # TODO: enforce some limitations on what a target name can be? delete $this->{'accept_targets'}{$t}; - DEBUG > 2 and print "OK, won't accept \"$t\" as target.\n"; + DEBUG > 2 and print STDERR "OK, won't accept \"$t\" as target.\n"; } return sort keys %{ $this->{'accept_targets'} } if wantarray; return; @@ -317,6 +337,13 @@ sub unaccept_targets { # # And now codes (not targets or directives) +# XXX Probably it is an error that the digit '9' is excluded from these re's. +# Broken for early Perls on EBCDIC +my $xml_name_re = eval "qr/[^-.0-8:A-Z_a-z[:^ascii:]]/"; +if (! defined $xml_name_re) { + $xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/; +} + sub accept_code { shift->accept_codes(@_) } # alias sub accept_codes { # Add some codes @@ -324,20 +351,17 @@ sub accept_codes { # Add some codes foreach my $new_code (@_) { next unless defined $new_code and length $new_code; - if(ASCII) { - # A good-enough check that it's good as an XML Name symbol: - Carp::croak "\"$new_code\" isn't a valid element name" - if $new_code =~ - m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ - # Characters under 0x80 that aren't legal in an XML Name. - or $new_code =~ m/^[-\.0-9]/s - or $new_code =~ m/:[-\.0-9]/s; - # The legal under-0x80 Name characters that - # an XML Name still can't start with. - } - + # A good-enough check that it's good as an XML Name symbol: + Carp::croak "\"$new_code\" isn't a valid element name" + if $new_code =~ $xml_name_re + # Characters under 0x80 that aren't legal in an XML Name. + or $new_code =~ m/^[-\.0-9]/s + or $new_code =~ m/:[-\.0-9]/s; + # The legal under-0x80 Name characters that + # an XML Name still can't start with. + $this->{'accept_codes'}{$new_code} = $new_code; - + # Yes, map to itself -- just so that when we # see "=extend W [whatever] thatelementname", we say that W maps # to whatever $this->{accept_codes}{thatelementname} is, @@ -359,24 +383,21 @@ sub unaccept_codes { # remove some codes foreach my $new_code (@_) { next unless defined $new_code and length $new_code; - if(ASCII) { - # A good-enough check that it's good as an XML Name symbol: - Carp::croak "\"$new_code\" isn't a valid element name" - if $new_code =~ - m/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ - # Characters under 0x80 that aren't legal in an XML Name. - or $new_code =~ m/^[-\.0-9]/s - or $new_code =~ m/:[-\.0-9]/s; - # The legal under-0x80 Name characters that - # an XML Name still can't start with. - } - + # A good-enough check that it's good as an XML Name symbol: + Carp::croak "\"$new_code\" isn't a valid element name" + if $new_code =~ $xml_name_re + # Characters under 0x80 that aren't legal in an XML Name. + or $new_code =~ m/^[-\.0-9]/s + or $new_code =~ m/:[-\.0-9]/s; + # The legal under-0x80 Name characters that + # an XML Name still can't start with. + Carp::croak "But you must accept \"$new_code\" codes -- it's a builtin!" if grep $new_code eq $_, @Known_formatting_codes; delete $this->{'accept_codes'}{$new_code}; - DEBUG > 2 and print "OK, won't accept the code $new_code<...>.\n"; + DEBUG > 2 and print STDERR "OK, won't accept the code $new_code<...>.\n"; } return; @@ -411,7 +432,7 @@ sub parse_string_document { sub _init_fh_source { my($self, $source) = @_; - #DEBUG > 1 and print "Declaring $source as :raw for starters\n"; + #DEBUG > 1 and print STDERR "Declaring $source as :raw for starters\n"; #$self->_apply_binmode($source, ':raw'); #binmode($source, ":raw"); @@ -504,7 +525,7 @@ sub parse_from_file { } else { require Symbol; my $out_fh = Symbol::gensym(); - DEBUG and print "Write-opening to $to\n"; + DEBUG and print STDERR "Write-opening to $to\n"; open($out_fh, ">$to") or Carp::croak "Can't write-open $to: $!"; binmode($out_fh) if $self->can('write_with_binmode') and $self->write_with_binmode; @@ -521,9 +542,10 @@ sub whine { my $self = shift(@_); ++$self->{'errors_seen'}; if($self->{'no_whining'}) { - DEBUG > 9 and print "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n"; + DEBUG > 9 and print STDERR "Discarding complaint (at line $_[0]) $_[1]\n because no_whining is on.\n"; return; } + push @{$self->{'all_errata'}{$_[0]}}, $_[1]; return $self->_complain_warn(@_) if $self->{'complain_stderr'}; return $self->_complain_errata(@_); } @@ -532,6 +554,7 @@ sub scream { # like whine, but not suppressible #my($self,$line,$complaint) = @_; my $self = shift(@_); ++$self->{'errors_seen'}; + push @{$self->{'all_errata'}{$_[0]}}, $_[1]; return $self->_complain_warn(@_) if $self->{'complain_stderr'}; return $self->_complain_errata(@_); } @@ -545,9 +568,9 @@ sub _complain_warn { sub _complain_errata { my($self,$line,$complaint) = @_; if( $self->{'no_errata_section'} ) { - DEBUG > 9 and print "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n"; + DEBUG > 9 and print STDERR "Discarding erratum (at line $line) $complaint\n because no_errata_section is on.\n"; } else { - DEBUG > 9 and print "Queuing erratum (at line $line) $complaint\n"; + DEBUG > 9 and print STDERR "Queuing erratum (at line $line) $complaint\n"; push @{$self->{'errata'}{$line}}, $complaint # for a report to be generated later! } @@ -589,7 +612,7 @@ sub _get_item_type { # mutates the item!! # Like: "=item * Foo bar baz"; $para->[1]{'~orig_content'} = $content; $para->[1]{'~_freaky_para_hack'} = $1; - DEBUG > 2 and print " Tolerating $$para[2] as =item *\\n\\n$1\n"; + DEBUG > 2 and print STDERR " Tolerating $$para[2] as =item *\\n\\n$1\n"; splice @$para, 2; # so it ends up just being ['=item', { attrhash } ] return $para->[1]{'~type'} = 'bullet'; @@ -621,7 +644,7 @@ sub _make_treelet { # just have the first line be a reference to a ['~Top', {}, ...] # We use this feechure in gen_errata and stuff. - DEBUG and print "Applying precooked treelet hack to $_[0][0]\n"; + DEBUG and print STDERR "Applying precooked treelet hack to $_[0][0]\n"; $treelet = $_[0][0]; splice @$treelet, 0, 2; # lop the top off return $treelet; @@ -638,7 +661,7 @@ sub _make_treelet { $self->_wrap_up($treelet); # Nix X's and merge texties } else { - DEBUG and print "Formatless treelet gets fast-tracked.\n"; + DEBUG and print STDERR "Formatless treelet gets fast-tracked.\n"; # Very common case! } @@ -655,7 +678,7 @@ sub _wrap_up { my $merge = $self->{'merge_text' }; return unless $nixx or $merge; - DEBUG > 2 and print "\nStarting _wrap_up traversal.\n", + DEBUG > 2 and print STDERR "\nStarting _wrap_up traversal.\n", $merge ? (" Merge mode on\n") : (), $nixx ? (" Nix-X mode on\n") : (), ; @@ -663,11 +686,11 @@ sub _wrap_up { my($i, $treelet); while($treelet = shift @stack) { - DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n"; + DEBUG > 3 and print STDERR " Considering children of this $treelet->[0] node...\n"; for($i = 2; $i < @$treelet; ++$i) { # iterate over children - DEBUG > 3 and print " Considering child at $i ", pretty($treelet->[$i]), "\n"; + DEBUG > 3 and print STDERR " Considering child at $i ", pretty($treelet->[$i]), "\n"; if($nixx and ref $treelet->[$i] and $treelet->[$i][0] eq 'X') { - DEBUG > 3 and print " Nixing X node at $i\n"; + DEBUG > 3 and print STDERR " Nixing X node at $i\n"; splice(@$treelet, $i, 1); # just nix this node (and its descendants) # no need to back-update the counter just yet redo; @@ -675,17 +698,17 @@ sub _wrap_up { } elsif($merge and $i != 2 and # non-initial !ref $treelet->[$i] and !ref $treelet->[$i - 1] ) { - DEBUG > 3 and print " Merging ", $i-1, + DEBUG > 3 and print STDERR " Merging ", $i-1, ":[$treelet->[$i-1]] and $i\:[$treelet->[$i]]\n"; $treelet->[$i-1] .= ( splice(@$treelet, $i, 1) )[0]; - DEBUG > 4 and print " Now: ", $i-1, ":[$treelet->[$i-1]]\n"; + DEBUG > 4 and print STDERR " Now: ", $i-1, ":[$treelet->[$i-1]]\n"; --$i; next; # since we just pulled the possibly last node out from under # ourselves, we can't just redo() } elsif( ref $treelet->[$i] ) { - DEBUG > 4 and print " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n"; + DEBUG > 4 and print STDERR " Enqueuing ", pretty($treelet->[$i]), " for traversal.\n"; push @stack, $treelet->[$i]; if($treelet->[$i][0] eq 'L') { @@ -693,7 +716,7 @@ sub _wrap_up { foreach my $attrname ('section', 'to') { if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) { unshift @stack, $thing; - DEBUG > 4 and print " +Enqueuing ", + DEBUG > 4 and print STDERR " +Enqueuing ", pretty( $treelet->[$i][1]{$attrname} ), " as an attribute value to tweak.\n"; } @@ -702,7 +725,7 @@ sub _wrap_up { } } } - DEBUG > 2 and print "End of _wrap_up traversal.\n\n"; + DEBUG > 2 and print STDERR "End of _wrap_up traversal.\n\n"; return; } @@ -714,7 +737,7 @@ sub _remap_sequences { if(@stack == 1 and @{ $stack[0] } == 3 and !ref $stack[0][2]) { # VERY common case: abort it. - DEBUG and print "Skipping _remap_sequences: formatless treelet.\n"; + DEBUG and print STDERR "Skipping _remap_sequences: formatless treelet.\n"; return 0; } @@ -725,7 +748,7 @@ sub _remap_sequences { "\nAbout to start _remap_sequences on treelet from line %s.\n", $start_line || '[?]' ; - DEBUG > 3 and print " Map: ", + DEBUG > 3 and print STDERR " Map: ", join('; ', map "$_=" . ( ref($map->{$_}) ? join(",", @{$map->{$_}}) : $map->{$_} ), @@ -738,20 +761,20 @@ sub _remap_sequences { my($is, $was, $i, $treelet); # scratch while($treelet = shift @stack) { - DEBUG > 3 and print " Considering children of this $treelet->[0] node...\n"; + DEBUG > 3 and print STDERR " Considering children of this $treelet->[0] node...\n"; for($i = 2; $i < @$treelet; ++$i) { # iterate over children next unless ref $treelet->[$i]; # text nodes are uninteresting - DEBUG > 4 and print " Noting child $i : $treelet->[$i][0]<...>\n"; + DEBUG > 4 and print STDERR " Noting child $i : $treelet->[$i][0]<...>\n"; $is = $treelet->[$i][0] = $map->{ $was = $treelet->[$i][0] }; if( DEBUG > 3 ) { if(!defined $is) { - print " Code $was<> is UNKNOWN!\n"; + print STDERR " Code $was<> is UNKNOWN!\n"; } elsif($is eq $was) { - DEBUG > 4 and print " Code $was<> stays the same.\n"; + DEBUG > 4 and print STDERR " Code $was<> stays the same.\n"; } else { - print " Code $was<> maps to ", + print STDERR " Code $was<> maps to ", ref($is) ? ( "tags ", map("$_<", @$is), '...', map('>', @$is), "\n" ) : "tag $is<...>.\n"; @@ -766,7 +789,7 @@ sub _remap_sequences { } if(ref $is) { my @dynasty = @$is; - DEBUG > 4 and print " Renaming $was node to $dynasty[-1]\n"; + DEBUG > 4 and print STDERR " Renaming $was node to $dynasty[-1]\n"; $treelet->[$i][0] = pop @dynasty; my $nugget; while(@dynasty) { @@ -795,10 +818,10 @@ sub _remap_sequences { } } - DEBUG > 2 and print "End of _remap_sequences traversal.\n\n"; + DEBUG > 2 and print STDERR "End of _remap_sequences traversal.\n\n"; if(@_ == 2 and @{ $_[1] } == 3 and !ref $_[1][2]) { - DEBUG and print "Noting that the treelet is now formatless.\n"; + DEBUG and print STDERR "Noting that the treelet is now formatless.\n"; return 0; } return 1; @@ -816,7 +839,7 @@ sub _ponder_extend { $content =~ s/^\s+//s; $content =~ s/\s+$//s; - DEBUG > 2 and print "Ogling extensor: =extend $content\n"; + DEBUG > 2 and print STDERR "Ogling extensor: =extend $content\n"; if($content =~ m/^ @@ -833,10 +856,10 @@ sub _ponder_extend { my $elements_one; $elements_one = defined($3) ? $3 : $1; - DEBUG > 2 and print "Extensor has good syntax.\n"; + DEBUG > 2 and print STDERR "Extensor has good syntax.\n"; unless($new_letter =~ m/^[A-Z]$/s or $new_letter) { - DEBUG > 2 and print " $new_letter isn't a valid thing to entend.\n"; + DEBUG > 2 and print STDERR " $new_letter isn't a valid thing to entend.\n"; $self->whine( $para->[1]{'start_line'}, "You can extend only formatting codes A-Z, not like \"$new_letter\"" @@ -845,7 +868,7 @@ sub _ponder_extend { } if(grep $new_letter eq $_, @Known_formatting_codes) { - DEBUG > 2 and print " $new_letter isn't a good thing to extend, because known.\n"; + DEBUG > 2 and print STDERR " $new_letter isn't a good thing to extend, because known.\n"; $self->whine( $para->[1]{'start_line'}, "You can't extend an established code like \"$new_letter\"" @@ -882,7 +905,7 @@ sub _ponder_extend { foreach my $f (@fallbacks) { next if exists $Known_formatting_codes{$f} or $f eq '0' or $f eq '1'; - DEBUG > 2 and print " Can't fall back on unknown code $f\n"; + DEBUG > 2 and print STDERR " Can't fall back on unknown code $f\n"; $self->whine( $para->[1]{'start_line'}, "Can't use unknown formatting code '$f' as a fallback for '$new_letter'" @@ -890,17 +913,17 @@ sub _ponder_extend { return; } - DEBUG > 3 and printf "Extensor: Fallbacks <%s> Elements <%s>.\n", + DEBUG > 3 and printf STDERR "Extensor: Fallbacks <%s> Elements <%s>.\n", @fallbacks, @elements; my $canonical_form; foreach my $e (@elements) { if(exists $self->{'accept_codes'}{$e}) { - DEBUG > 1 and print " Mapping '$new_letter' to known extension '$e'\n"; + DEBUG > 1 and print STDERR " Mapping '$new_letter' to known extension '$e'\n"; $canonical_form = $e; last; # first acceptable elementname wins! } else { - DEBUG > 1 and print " Can't map '$new_letter' to unknown extension '$e'\n"; + DEBUG > 1 and print STDERR " Can't map '$new_letter' to unknown extension '$e'\n"; } } @@ -919,7 +942,7 @@ sub _ponder_extend { } } else { - DEBUG > 2 and print "Extensor has bad syntax.\n"; + DEBUG > 2 and print STDERR "Extensor has bad syntax.\n"; $self->whine( $para->[1]{'start_line'}, "Unknown =extend syntax: $content" @@ -947,7 +970,7 @@ sub _treat_Zs { # Nix Z<...>'s next; } - DEBUG > 1 and print "Nixing Z node @{$treelet->[$i]}\n"; + DEBUG > 1 and print STDERR "Nixing Z node @{$treelet->[$i]}\n"; # bitch UNLESS it's empty unless( @{$treelet->[$i]} == 2 @@ -1057,7 +1080,7 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences # By here, $treelet->[$i] is definitely an L node my $ell = $treelet->[$i]; - DEBUG > 1 and print "Ogling L node $ell\n"; + DEBUG > 1 and print STDERR "Ogling L node $ell\n"; # bitch if it's empty if( @{$ell} == 2 @@ -1134,7 +1157,7 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences my $it = $ell->[2]; if($it =~ m{^[^/|]+[(][-a-zA-Z0-9]+[)]$}s) { # man sections # Hopefully neither too broad nor too restrictive a RE - DEBUG > 1 and print "Catching \"$it\" as manpage link.\n"; + DEBUG > 1 and print STDERR "Catching \"$it\" as manpage link.\n"; $ell->[1]{'type'} = 'man'; # This's the only place where man links can get made. $ell->[1]{'content-implicit'} = 'yes'; @@ -1146,7 +1169,7 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences if($it =~ m/^[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+(\:\:[^\/\|,\$\%\@\ \"\<\>\:\#\&\*\{\}\[\]\(\)]+)*$/s) { # Extremely forgiving idea of what constitutes a bare # modulename link like L<Foo::Bar> or even L<Thing::1.0::Docs::Tralala> - DEBUG > 1 and print "Catching \"$it\" as ho-hum L<Modulename> link.\n"; + DEBUG > 1 and print STDERR "Catching \"$it\" as ho-hum L<Modulename> link.\n"; $ell->[1]{'type'} = 'pod'; $ell->[1]{'content-implicit'} = 'yes'; $ell->[1]{'to' } = @@ -1161,32 +1184,32 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences # ...Uhoh, here's the real L<...> parsing stuff... # "With the ill behavior, with the ill behavior, with the ill behavior..." - DEBUG > 1 and print "Running a real parse on this non-trivial L\n"; + DEBUG > 1 and print STDERR "Running a real parse on this non-trivial L\n"; my $link_text; # set to an arrayref if found my @ell_content = @$ell; splice @ell_content,0,2; # Knock off the 'L' and {} bits - DEBUG > 3 and print " Ell content to start: ", + DEBUG > 3 and print STDERR " Ell content to start: ", pretty(@ell_content), "\n"; # Look for the "|" -- only in CHILDREN (not all underlings!) # Like L<I like the strictness|strict> DEBUG > 3 and - print " Peering at L content for a '|' ...\n"; + print STDERR " Peering at L content for a '|' ...\n"; for(my $j = 0; $j < @ell_content; ++$j) { next if ref $ell_content[$j]; DEBUG > 3 and - print " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n"; + print STDERR " Peering at L-content text bit \"$ell_content[$j]\" for a '|'.\n"; if($ell_content[$j] =~ m/^([^\|]*)\|(.*)$/s) { my @link_text = ($1); # might be 0-length $ell_content[$j] = $2; # might be 0-length DEBUG > 3 and - print " FOUND a '|' in it. Splitting into [$1] + [$2]\n"; + print STDERR " FOUND a '|' in it. Splitting into [$1] + [$2]\n"; if ($link_text[0] =~ m{[|/]}) { $self->whine( @@ -1211,18 +1234,18 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences # And afterward, anything left in @ell_content will be the raw name # Like L<Foo::Bar/Object Methods> my $section_name; # set to arrayref if found - DEBUG > 3 and print " Peering at L-content for a '/' ...\n"; + DEBUG > 3 and print STDERR " Peering at L-content for a '/' ...\n"; for(my $j = 0; $j < @ell_content; ++$j) { next if ref $ell_content[$j]; DEBUG > 3 and - print " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n"; + print STDERR " Peering at L-content text bit \"$ell_content[$j]\" for a '/'.\n"; if($ell_content[$j] =~ m/^([^\/]*)\/(.*)$/s) { my @section_name = ($2); # might be 0-length $ell_content[$j] = $1; # might be 0-length DEBUG > 3 and - print " FOUND a '/' in it.", + print STDERR " FOUND a '/' in it.", " Splitting to page [...$1] + section [$2...]\n"; push @section_name, splice @ell_content, 1+$j; @@ -1243,10 +1266,10 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences $section_name[ 0] =~ s/^\"//s; $section_name[-1] =~ s/\"$//s; DEBUG > 3 and - print " Quotes removed: ", pretty(@section_name), "\n"; + print STDERR " Quotes removed: ", pretty(@section_name), "\n"; } else { DEBUG > 3 and - print " No need to remove quotes in ", pretty(@section_name), "\n"; + print STDERR " No need to remove quotes in ", pretty(@section_name), "\n"; } $section_name = \@section_name; @@ -1301,30 +1324,30 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences and $ell_content[0] =~ m{^[^/]+[(][-a-zA-Z0-9]+[)]$}s ) { $ell->[1]{'type'} = 'man'; - DEBUG > 3 and print "Considering this ($ell_content[0]) a man link.\n"; + DEBUG > 3 and print STDERR "Considering this ($ell_content[0]) a man link.\n"; } else { $ell->[1]{'type'} = 'pod'; - DEBUG > 3 and print "Considering this a pod link (not man or url).\n"; + DEBUG > 3 and print STDERR "Considering this a pod link (not man or url).\n"; } if( defined $section_name ) { $ell->[1]{'section'} = Pod::Simple::LinkSection->new( ['', {}, @$section_name] ); - DEBUG > 3 and print "L-section content: ", pretty($ell->[1]{'section'}), "\n"; + DEBUG > 3 and print STDERR "L-section content: ", pretty($ell->[1]{'section'}), "\n"; } if( @ell_content ) { $ell->[1]{'to'} = Pod::Simple::LinkSection->new( ['', {}, @ell_content] ); - DEBUG > 3 and print "L-to content: ", pretty($ell->[1]{'to'}), "\n"; + DEBUG > 3 and print STDERR "L-to content: ", pretty($ell->[1]{'to'}), "\n"; } # And update children to be the link-text: @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : ''); - DEBUG > 2 and print "End of L-parsing for this node $treelet->[$i]\n"; + DEBUG > 2 and print STDERR "End of L-parsing for this node $treelet->[$i]\n"; unshift @stack, $treelet->[$i]; # might as well recurse } @@ -1358,7 +1381,7 @@ sub _treat_Es { foreach my $attrname ('section', 'to') { if(defined($thing = $treelet->[$i][1]{$attrname}) and ref $thing) { unshift @stack, $thing; - DEBUG > 2 and print " Enqueuing ", + DEBUG > 2 and print STDERR " Enqueuing ", pretty( $treelet->[$i][1]{$attrname} ), " as an attribute value to tweak.\n"; } @@ -1371,7 +1394,7 @@ sub _treat_Es { next; } - DEBUG > 1 and print "Ogling E node ", pretty($treelet->[$i]), "\n"; + DEBUG > 1 and print STDERR "Ogling E node ", pretty($treelet->[$i]), "\n"; # bitch if it's empty if( @{$treelet->[$i]} == 2 @@ -1395,27 +1418,27 @@ sub _treat_Es { next; } - DEBUG > 1 and print "Ogling E<$content>\n"; + DEBUG > 1 and print STDERR "Ogling E<$content>\n"; # XXX E<>'s contents *should* be a valid char in the scope of the current # =encoding directive. Defaults to iso-8859-1, I believe. Fix this in the # future sometime. $charnum = Pod::Escapes::e2charnum($content); - DEBUG > 1 and print " Considering E<$content> with char ", + DEBUG > 1 and print STDERR " Considering E<$content> with char ", defined($charnum) ? $charnum : "undef", ".\n"; if(!defined( $charnum )) { - DEBUG > 1 and print "I don't know how to deal with E<$content>.\n"; + DEBUG > 1 and print STDERR "I don't know how to deal with E<$content>.\n"; $self->whine( $start_line, "Unknown E content in E<$content>" ); $replacer = "E<$content>"; # better than nothing } elsif($charnum >= 255 and !UNICODE) { $replacer = ASCII ? "\xA4" : "?"; - DEBUG > 1 and print "This Perl version can't handle ", + DEBUG > 1 and print STDERR "This Perl version can't handle ", "E<$content> (chr $charnum), so replacing with $replacer\n"; } else { $replacer = Pod::Escapes::e2char($content); - DEBUG > 1 and print " Replacing E<$content> with $replacer\n"; + DEBUG > 1 and print STDERR " Replacing E<$content> with $replacer\n"; } splice(@$treelet, $i, 1, $replacer); # no need to back up $i, tho @@ -1441,15 +1464,6 @@ sub _treat_Ss { return; } -# We can get NO BREAK SPACE accurately for any platform for recent Perls; for -# earlier ones use the ASCII value for those platforms, and assume the typical -# EBCDIC value for any others. -my $nbsp = ($] >= 5.007003) - ? chr utf8::unicode_to_native(0xA0) - : (ASCII) - ? "\xA0" - : "\x41"; - sub _change_S_to_nbsp { # a recursive function # Sanely assumes that the top node in the excursion won't be an S node. my($treelet, $in_s) = @_; @@ -1467,7 +1481,7 @@ sub _change_S_to_nbsp { # a recursive function $i += @$to_pull_up - 1; # Make $i skip the pulled-up stuff } } else { - $treelet->[$i] =~ s/\s/$nbsp/g if $in_s; + $treelet->[$i] =~ s/\s/$Pod::Simple::nbsp/g if $in_s; # Note that if you apply nbsp_for_S to text, and so turn # "foo S<bar baz> quux" into "foo bar faz quux", you @@ -1532,7 +1546,7 @@ sub _out { my $mutor = shift(@_) if @_ and ref($_[0] || '') eq 'CODE'; - DEBUG and print "\n\n", '#' x 76, + DEBUG and print STDERR "\n\n", '#' x 76, "\nAbout to parse source: {{\n$_[0]\n}}\n\n"; @@ -1541,12 +1555,12 @@ sub _out { my $out = ''; $parser->output_string( \$out ); - DEBUG and print " _out to ", \$out, "\n"; + DEBUG and print STDERR " _out to ", \$out, "\n"; $mutor->($parser) if $mutor; $parser->parse_string_document( $_[0] ); - # use Data::Dumper; print Dumper($parser), "\n"; + # use Data::Dumper; print STDERR Dumper($parser), "\n"; return $out; } @@ -1574,13 +1588,13 @@ sub _duo { push @out, ''; $parser->output_string( \( $out[-1] ) ); - DEBUG and print " _duo out to ", $parser->output_string(), + DEBUG and print STDERR " _duo out to ", $parser->output_string(), " = $parser->{'output_string'}\n"; $parser->hide_line_numbers(1); $mutor->($parser) if $mutor; $parser->parse_string_document( shift( @_ ) ); - # use Data::Dumper; print Dumper($parser), "\n"; + # use Data::Dumper; print STDERR Dumper($parser), "\n"; } return @out; diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple.pod b/Master/tlpkg/tlperl/lib/Pod/Simple.pod index aadba19e941..67a18df0d64 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple.pod +++ b/Master/tlpkg/tlperl/lib/Pod/Simple.pod @@ -12,7 +12,7 @@ Pod::Simple - framework for parsing Pod Pod::Simple is a Perl library for parsing text in the Pod ("plain old documentation") markup language that is typically used for writing documentation for Perl and for Perl modules. The Pod format is explained -L<perlpod>; the most common formatter is called C<perldoc>. +in L<perlpod>; the most common formatter is called C<perldoc>. Be sure to read L</ENCODING> if your Pod contains non-ASCII characters. @@ -289,6 +289,16 @@ I<Example:> die "too many errors\n" if $parser->any_errata_seen(); +=item C<< $parser->errata_seen() >>X<errata_seen> + +Returns a hash reference of all errata seen, both whines and screams. The hash reference's keys are the line number and the value is an array reference of the errors for that line. + +I<Example:> + + if ( $parser->any_errata_seen() ) { + $logger->log( $parser->errata_seen() ); + } + =item C<< $parser->detected_encoding() >>X<detected_encoding> Return the encoding corresponding to C<< =encoding >>, but only if the @@ -349,21 +359,15 @@ octets into Perl's internal character string representation using the value of the C<=encoding> declaration in the POD source. If the POD source does not include an C<=encoding> declaration, the parser will -attempt to guess the encoding (selecting one of UTF-8 or Latin-1) by examining +attempt to guess the encoding (selecting one of UTF-8 or CP 1252) by examining the first non-ASCII bytes and applying the heuristic described in -L<perlpodspec>. +L<perlpodspec>. (If the POD source contains only ASCII bytes, the +encoding is assumed to be ASCII.) If you set the C<parse_characters> option to a true value the parser will expect characters rather than octets; will ignore any C<=encoding>; and will make no attempt to decode the input. -=head1 CAVEATS - -This is just a beta release -- there are a good number of things still -left to do. Notably, support for EBCDIC platforms is still half-done, -an untested. - - =head1 SEE ALSO L<Pod::Simple::Subclassing> @@ -383,8 +387,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm index ee6e747a6a0..7021e6c9f15 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm @@ -22,13 +22,27 @@ use integer; # vroom! use strict; use Carp (); use vars qw($VERSION ); -$VERSION = '3.29'; +$VERSION = '3.32'; #use constant DEBUG => 7; BEGIN { require Pod::Simple; *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } +# Matches a character iff the character will have a different meaning +# if we choose CP1252 vs UTF-8 if there is no =encoding line. +# This is broken for early Perls on non-ASCII platforms. +my $non_ascii_re = eval "qr/[[:^ascii:]]/"; +$non_ascii_re = qr/[\x80-\xFF]/ if ! defined $non_ascii_re; + +my $utf8_bom; +if (($] ge 5.007_003)) { + $utf8_bom = "\x{FEFF}"; + utf8::encode($utf8_bom); +} else { + $utf8_bom = "\xEF\xBB\xBF"; # No EBCDIC BOM detection for early Perls. +} + #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ sub parse_line { shift->parse_lines(@_) } # alias @@ -47,10 +61,10 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) my $scratch; DEBUG > 4 and - print "# Parsing starting at line ", $self->{'line_count'}, ".\n"; + print STDERR "# Parsing starting at line ", $self->{'line_count'}, ".\n"; DEBUG > 5 and - print "# About to parse lines: ", + print STDERR "# About to parse lines: ", join(' ', map defined($_) ? "[$_]" : "EOF", @_), "\n"; my $paras = ($self->{'paras'} ||= []); @@ -63,12 +77,12 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) my $line; foreach my $source_line (@_) { if( $self->{'source_dead'} ) { - DEBUG > 4 and print "# Source is dead.\n"; + DEBUG > 4 and print STDERR "# Source is dead.\n"; last; } unless( defined $source_line ) { - DEBUG > 4 and print "# Undef-line seen.\n"; + DEBUG > 4 and print STDERR "# Undef-line seen.\n"; push @$paras, ['~end', {'start_line' => $self->{'line_count'}}]; push @$paras, $paras->[-1], $paras->[-1]; @@ -85,16 +99,16 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # tr/// modding the (potentially read-only) original source line! } else { - DEBUG > 2 and print "First line: [$source_line]\n"; + DEBUG > 2 and print STDERR "First line: [$source_line]\n"; - if( ($line = $source_line) =~ s/^\xEF\xBB\xBF//s ) { - DEBUG and print "UTF-8 BOM seen. Faking a '=encoding utf8'.\n"; + if( ($line = $source_line) =~ s/^$utf8_bom//s ) { + DEBUG and print STDERR "UTF-8 BOM seen. Faking a '=encoding utf8'.\n"; $self->_handle_encoding_line( "=encoding utf8" ); delete $self->{'_processed_encoding'}; $line =~ tr/\n\r//d; } elsif( $line =~ s/^\xFE\xFF//s ) { - DEBUG and print "Big-endian UTF-16 BOM seen. Aborting parsing.\n"; + DEBUG and print STDERR "Big-endian UTF-16 BOM seen. Aborting parsing.\n"; $self->scream( $self->{'line_count'}, "UTF16-BE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet." @@ -106,7 +120,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # TODO: implement somehow? } elsif( $line =~ s/^\xFF\xFE//s ) { - DEBUG and print "Little-endian UTF-16 BOM seen. Aborting parsing.\n"; + DEBUG and print STDERR "Little-endian UTF-16 BOM seen. Aborting parsing.\n"; $self->scream( $self->{'line_count'}, "UTF16-LE Byte Encoding Mark found; but Pod::Simple v$Pod::Simple::VERSION doesn't implement UTF16 yet." @@ -118,33 +132,107 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # TODO: implement somehow? } else { - DEBUG > 2 and print "First line is BOM-less.\n"; + DEBUG > 2 and print STDERR "First line is BOM-less.\n"; ($line = $source_line) =~ tr/\n\r//d; } } - # Try to guess encoding. Inlined for performance reasons. if(!$self->{'parse_characters'} && !$self->{'encoding'} && ($self->{'in_pod'} || $line =~ /^=/s) - && $line =~ /[[:^ascii:]]/ + && $line =~ /$non_ascii_re/ ) { + my $encoding; - if (ord("A") != 65) { - # Hard to figure out on non-ASCII platform if UTF-8 or not. This - # won't work if it isn't UTF-8, so just assume it is and hope for the - # best. It's not clear that the other encodings work on non-ASCII - # platforms anyway. - $encoding = 'UTF-8'; - } - else { - $encoding = $line =~ /^[\x00-\x7f]*[\xC0-\xFD][\x80-\xBF]/ ? 'UTF-8' : 'ISO8859-1'; - } + # No =encoding line, and we are at the first line in the input that + # contains a non-ascii byte, that is one whose meaning varies depending + # on whether the file is encoded in UTF-8 or CP1252, which are the two + # possibilities permitted by the pod spec. (ASCII is assumed if the + # file only contains ASCII bytes.) In order to process this line, we + # need to figure out what encoding we will use for the file. + # + # Strictly speaking ISO 8859-1 (Latin 1) refers to the code points + # 160-255, but it is used here, as it often colloquially is, to refer to + # the complete set of code points 0-255, including ASCII (0-127), the C1 + # controls (128-159), and strict Latin 1 (160-255). + # + # CP1252 is effectively a superset of Latin 1, because it differs only + # from colloquial 8859-1 in the C1 controls, which are very unlikely to + # actually be present in 8859-1 files, so can be used for other purposes + # without conflict. CP 1252 uses most of them for graphic characters. + # + # Note that all ASCII-range bytes represent their corresponding code + # points in CP1252 and UTF-8. In ASCII platform UTF-8 all other code + # points require multiple (non-ASCII) bytes to represent. (A separate + # paragraph for EBCDIC is below.) The multi-byte representation is + # quite structured. If we find an isolated byte that requires multiple + # bytes to represent in UTF-8, we know that the encoding is not UTF-8. + # If we find a sequence of bytes that violates the UTF-8 structure, we + # also can presume the encoding isn't UTF-8, and hence must be 1252. + # + # But there are ambiguous cases where we could guess wrong. If so, the + # user will end up having to supply an =encoding line. We use all + # readily available information to improve our chances of guessing + # right. The odds of something not being UTF-8, but still passing a + # UTF-8 validity test go down very rapidly with increasing length of the + # sequence. Therefore we look at all the maximal length non-ascii + # sequences on the line. If any of the sequences can't be UTF-8, we + # quit there and choose CP1252. If all could be UTF-8, we guess UTF-8. + # + # On EBCDIC platforms, the situation is somewhat different. In + # UTF-EBCDIC, not only do ASCII-range bytes represent their code points, + # but so do the bytes that are for the C1 controls. Recall that these + # correspond to the unused portion of 8859-1 that 1252 mostly takes + # over. That means that there are fewer code points that are + # represented by multi-bytes. But, note that the these controls are + # very unlikely to be in pod text. So if we encounter one of them, it + # means that it is quite likely CP1252 and not UTF-8. The net result is + # the same code below is used for both platforms. + while ($line =~ m/($non_ascii_re+)/g) { + my $non_ascii_seq = $1; + + if (length $non_ascii_seq == 1) { + $encoding = 'CP1252'; + goto guessed; + } elsif ($] ge 5.007_003) { + + # On Perls that have this function, we can see if the sequence is + # valid UTF-8 or not. + if (! utf8::decode($non_ascii_seq)) { + $encoding = 'CP1252'; + goto guessed; + } + } elsif (ord("A") == 65) { # An early Perl, ASCII platform + + # Without utf8::decode, it's a lot harder to do a rigorous check + # (though some early releases had a different function that + # accomplished the same thing). Since these are ancient Perls, not + # likely to be in use today, we take the easy way out, and look at + # just the first two bytes of the sequence to see if they are the + # start of a UTF-8 character. In ASCII UTF-8, continuation bytes + # must be between 0x80 and 0xBF. Start bytes can range from 0xC2 + # through 0xFF, but anything above 0xF4 is not Unicode, and hence + # extremely unlikely to be in a pod. + if ($non_ascii_seq !~ /^[\xC2-\xF4][\x80-\xBF]/) { + $encoding = 'CP1252'; + goto guessed; + } + + # We don't bother doing anything special for EBCDIC on early Perls. + # If there is a solitary variant, CP1252 will be chosen; otherwise + # UTF-8. + } + } # End of loop through all variant sequences on the line + + # All sequences in the line could be UTF-8. Guess that. + $encoding = 'UTF-8'; + + guessed: $self->_handle_encoding_line( "=encoding $encoding" ); delete $self->{'_processed_encoding'}; $self->{'_transcoder'} && $self->{'_transcoder'}->($line); - my ($word) = $line =~ /(\S*[[:^ascii:]]\S*)/; + my ($word) = $line =~ /(\S*$non_ascii_re\S*)/; $self->whine( $self->{'line_count'}, @@ -152,10 +240,10 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) ); } - DEBUG > 5 and print "# Parsing line: [$line]\n"; + DEBUG > 5 and print STDERR "# Parsing line: [$line]\n"; if(!$self->{'in_pod'}) { - if($line =~ m/^=([a-zA-Z]+)/s) { + if($line =~ m/^=([a-zA-Z][a-zA-Z0-9]*)(?:\s|$)/s) { if($1 eq 'cut') { $self->scream( $self->{'line_count'}, @@ -175,7 +263,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # And fall thru to the pod-mode block further down } } else { - DEBUG > 5 and print "# It's a code-line.\n"; + DEBUG > 5 and print STDERR "# It's a code-line.\n"; $code_handler->(map $_, $line, $self->{'line_count'}, $self) if $code_handler; # Note: this may cause code to be processed out of order relative @@ -187,8 +275,8 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) 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"; + #DEBUG > 1 and defined $2 and print STDERR "# Setting fname to \"$fname\"\n"; + DEBUG > 1 and print STDERR "# Setting nextline to $1\n"; $self->{'line_count'} = $1 - 1; } @@ -210,7 +298,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) 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"; + DEBUG > 1 and print STDERR "Noting =cut at line ${$self}{'line_count'}\n"; $self->{'in_pod'} = 0; # ++$self->{'pod_para_count'}; $self->_ponder_paragraph_buffer(); @@ -228,12 +316,12 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) } 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"; + DEBUG > 1 and print STDERR "Saving blank line at line ${$self}{'line_count'}\n"; push @{$paras->[-1]}, $line; } # otherwise it's not interesting if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) { - DEBUG > 1 and print "Noting para ends with blank line at ${$self}{'line_count'}\n"; + DEBUG > 1 and print STDERR "Noting para ends with blank line at ${$self}{'line_count'}\n"; } $self->{'last_was_blank'} = 1; @@ -252,18 +340,18 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # 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"; + DEBUG > 1 and print STDERR "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n"; } elsif($line =~ m/^\s/s) { if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { - DEBUG > 1 and print "Resuming verbatim para at line ${$self}{'line_count'}\n"; + DEBUG > 1 and print STDERR "Resuming verbatim para at line ${$self}{'line_count'}\n"; push @{$paras->[-1]}, $line; } else { ++$self->{'pod_para_count'}; $self->_ponder_paragraph_buffer(); # by now it's safe to consider the previous paragraph as done. - DEBUG > 1 and print "Starting verbatim para at line ${$self}{'line_count'}\n"; + DEBUG > 1 and print STDERR "Starting verbatim para at line ${$self}{'line_count'}\n"; push @$paras, ['~Verbatim', {'start_line' => $self->{'line_count'}}, $line]; } } else { @@ -271,14 +359,14 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) $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"; + DEBUG > 1 and print STDERR "Starting plain para at line ${$self}{'line_count'}\n"; } $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; } else { # It's a non-blank line /continuing/ the current para if(@$paras) { - DEBUG > 2 and print "Line ${$self}{'line_count'} continues current paragraph\n"; + DEBUG > 2 and print STDERR "Line ${$self}{'line_count'} continues current paragraph\n"; push @{$paras->[-1]}, $line; } else { # Unexpected case! @@ -289,7 +377,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) } # ends the big while loop - DEBUG > 1 and print(pretty(@$paras), "\n"); + DEBUG > 1 and print STDERR (pretty(@$paras), "\n"); return $self; } @@ -303,7 +391,7 @@ sub _handle_encoding_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"; + DEBUG > 1 and print STDERR "Found an encoding line \"=encoding $1\"\n"; my $e = $1; my $orig = $e; @@ -323,24 +411,24 @@ sub _handle_encoding_line { $that =~ s/[-_]//g; } if($norm_current eq $norm_e) { - DEBUG > 1 and print "The '=encoding $orig' line is ", + DEBUG > 1 and print STDERR "The '=encoding $orig' line is ", "redundant. ($norm_current eq $norm_e). Ignoring.\n"; $enc_error = ''; # But that doesn't necessarily mean that the earlier one went okay } else { $enc_error = "Encoding is already set to " . $self->{'encoding'}; - DEBUG > 1 and print $enc_error; + DEBUG > 1 and print STDERR $enc_error; } } elsif ( # OK, let's turn on the encoding do { - DEBUG > 1 and print " Setting encoding to $e\n"; + DEBUG > 1 and print STDERR " Setting encoding to $e\n"; $self->{'encoding'} = $e; 1; } and $e eq 'HACKRAW' ) { - DEBUG and print " Putting in HACKRAW (no-op) encoding mode.\n"; + DEBUG and print STDERR " Putting in HACKRAW (no-op) encoding mode.\n"; } elsif( Pod::Simple::Transcode::->encoding_is_available($e) ) { @@ -361,7 +449,7 @@ sub _handle_encoding_line { my @supported = Pod::Simple::Transcode::->all_encodings; # Note unsupported, and complain - DEBUG and print " Encoding [$e] is unsupported.", + DEBUG and print STDERR " Encoding [$e] is unsupported.", "\nSupporteds: @supported\n"; my $suggestion = ''; @@ -406,7 +494,7 @@ sub _handle_encoding_second_level { $content =~ s/^\s+//s; $content =~ s/\s+$//s; - DEBUG > 2 and print "Ogling encoding directive: =encoding $content\n"; + DEBUG > 2 and print STDERR "Ogling encoding directive: =encoding $content\n"; if (defined($self->{'_processed_encoding'})) { #if($content ne $self->{'_processed_encoding'}) { @@ -415,7 +503,7 @@ sub _handle_encoding_second_level { delete $self->{'_processed_encoding'}; # 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"; + DEBUG > 2 and print STDERR " CRAZY ERROR: It wasn't really handled?!\n"; } elsif( $self->{'encoding_command_statuses'}[-1] ) { $self->whine( $para->[1]{'start_line'}, sprintf "Couldn't do %s: %s", @@ -423,7 +511,7 @@ sub _handle_encoding_second_level { $self->{'encoding_command_statuses'}[-1], ); } else { - DEBUG > 2 and print " (Yup, it was successfully handled already.)\n"; + DEBUG > 2 and print STDERR " (Yup, it was successfully handled already.)\n"; } } else { @@ -480,7 +568,7 @@ sub _gen_errata { ['=back', {'start_line' => $m, 'errata' => 1}, ''], ; - DEBUG and print "\n<<\n", pretty(\@out), "\n>>\n\n"; + DEBUG and print STDERR "\n<<\n", pretty(\@out), "\n>>\n\n"; return @out; } @@ -526,7 +614,7 @@ sub _ponder_paragraph_buffer { my $scratch; - DEBUG > 10 and print "# Paragraph buffer: <<", pretty($paras), ">>\n"; + DEBUG > 10 and print STDERR "# Paragraph buffer: <<", pretty($paras), ">>\n"; # We have something in our buffer. So apparently the document has started. unless($self->{'doc_has_started'}) { @@ -540,7 +628,7 @@ sub _ponder_paragraph_buffer { # i.e., if the paras is all ~ends ) ; - DEBUG and print "# Starting ", + DEBUG and print STDERR "# Starting ", $starting_contentless ? 'contentless' : 'contentful', " document\n" ; @@ -572,7 +660,7 @@ sub _ponder_paragraph_buffer { $para = shift @$paras; $para_type = $para->[0]; - DEBUG > 1 and print "Pondering a $para_type paragraph, given the stack: (", + DEBUG > 1 and print STDERR "Pondering a $para_type paragraph, given the stack: (", $self->_dump_curr_open(), ")\n"; if($para_type eq '=for') { @@ -593,7 +681,7 @@ sub _ponder_paragraph_buffer { #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ if(grep $_->[1]{'~ignore'}, @$curr_open) { DEBUG > 1 and - print "Skipping $para_type paragraph because in ignore mode.\n"; + print STDERR "Skipping $para_type paragraph because in ignore mode.\n"; next; } #~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ @@ -616,7 +704,7 @@ sub _ponder_paragraph_buffer { # mean how it should get treated, not as what the element name # should be. - DEBUG > 1 and print "Pondering non-magical $para_type\n"; + DEBUG > 1 and print STDERR "Pondering non-magical $para_type\n"; my $i; @@ -626,7 +714,7 @@ sub _ponder_paragraph_buffer { and @$curr_open and $curr_open->[-1][0] eq '=over' ) { - DEBUG > 2 and print "'=$para_type' inside an '=over'!\n"; + DEBUG > 2 and print STDERR "'=$para_type' inside an '=over'!\n"; $self->whine( $para->[1]{'start_line'}, "You forgot a '=back' before '$para_type'" @@ -678,7 +766,7 @@ sub _ponder_paragraph_buffer { } 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"; + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; if($item_type eq 'text') { # Nothing special needs doing for 'text' @@ -701,7 +789,7 @@ sub _ponder_paragraph_buffer { } 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"; + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; @@ -728,10 +816,10 @@ sub _ponder_paragraph_buffer { 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"; + DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n"; } else { - DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'}, + DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'}, " instead of the expected value of $expected_value\n"; $self->whine( $para->[1]{'start_line'}, @@ -744,10 +832,10 @@ sub _ponder_paragraph_buffer { 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"; + DEBUG and print STDERR "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"; + DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n"; push @$para, ''; # Just so it's not contentless } } @@ -756,13 +844,13 @@ sub _ponder_paragraph_buffer { } 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"; + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; if($item_type eq 'bullet') { # as expected! if( $para->[1]{'~_freaky_para_hack'} ) { - DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n"; + DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n"; push @$para, delete $para->[1]{'~_freaky_para_hack'}; } @@ -790,10 +878,10 @@ sub _ponder_paragraph_buffer { 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"; + DEBUG and print STDERR "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"; + DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n"; push @$para, ''; # Just so it's not contentless } } @@ -829,10 +917,10 @@ sub _ponder_paragraph_buffer { } 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"; + DEBUG > 1 and print STDERR " Pondering known directive ${$para}[0] as $para_type\n"; } else { # An unknown directive! - DEBUG > 1 and printf "Unhandled directive %s (Handled: %s)\n", + DEBUG > 1 and printf STDERR "Unhandled directive %s (Handled: %s)\n", $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} ) ; $self->whine( @@ -846,14 +934,14 @@ sub _ponder_paragraph_buffer { if($para_type =~ s/^\?//s) { if(! @$curr_open) { # usual case - DEBUG and print "Treating $para_type paragraph as such because stack is empty.\n"; + DEBUG and print STDERR "Treating $para_type paragraph as such because stack is empty.\n"; } else { my @fors = grep $_->[0] eq '=for', @$curr_open; - DEBUG > 1 and print "Containing fors: ", + DEBUG > 1 and print STDERR "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"; + DEBUG and print STDERR "Treating $para_type paragraph as such because stack has no =for's\n"; #} elsif(grep $_->[1]{'~resolve'}, @fors) { #} elsif(not grep !$_->[1]{'~resolve'}, @fors) { @@ -861,14 +949,14 @@ sub _ponder_paragraph_buffer { # 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"; + DEBUG and print STDERR "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; $para->[0] = 'Para'; $para_type = 'Plain'; } else { - DEBUG and print "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; + DEBUG and print STDERR "Treating $para_type paragraph as such because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; } } else { - DEBUG and print "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n"; + DEBUG and print STDERR "Treating $para_type paragraph as Data because the containing =for ($fors[-1][1]{'target'}) is a non-resolver\n"; $para->[0] = $para_type = 'Data'; } } @@ -889,7 +977,7 @@ sub _ponder_paragraph_buffer { #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ $para->[0] =~ s/^[~=]//s; - DEBUG and print "\n", pretty($para), "\n"; + DEBUG and print STDERR "\n", pretty($para), "\n"; # traverse the treelet (which might well be just one string scalar) $self->{'content_seen'} ||= 1; @@ -912,7 +1000,7 @@ sub _ponder_for { my $target; if(grep $_->[1]{'~ignore'}, @$curr_open) { - DEBUG > 1 and print "Ignoring ignorable =for\n"; + DEBUG > 1 and print STDERR "Ignoring ignorable =for\n"; return 1; } @@ -930,7 +1018,7 @@ sub _ponder_for { return 1; } DEBUG > 1 and - print "Faking out a =for $target as a =begin $target / =end $target\n"; + print STDERR "Faking out a =for $target as a =begin $target / =end $target\n"; $para->[0] = 'Data'; @@ -959,7 +1047,7 @@ sub _ponder_begin { $para->[1]{'start_line'}, "=begin without a target?" ); - DEBUG and print "Ignoring targetless =begin\n"; + DEBUG and print STDERR "Ignoring targetless =begin\n"; return 1; } @@ -981,11 +1069,11 @@ sub _ponder_begin { $neg ? () : '*' ) { DEBUG > 2 and - print " Considering whether =begin $content matches $target_name\n"; + print STDERR " 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"; + print STDERR " It DOES match the acceptable target $target_name!\n"; $to_resolve = 1 if $self->{'accept_targets'}{$target_name} eq 'force_resolve'; $dont_ignore = 1; @@ -997,11 +1085,11 @@ sub _ponder_begin { 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"; + DEBUG > 2 and print STDERR " But the leading ! means that this is a NON-match!\n"; } else { $dont_ignore = 1; $para->[1]{'target_matching'} = '!'; - DEBUG > 2 and print " But the leading ! means that this IS a match!\n"; + DEBUG > 2 and print STDERR " But the leading ! means that this IS a match!\n"; } } @@ -1010,15 +1098,15 @@ sub _ponder_begin { $para->[1]{'~ignore'} = (! $dont_ignore) || 0; $para->[1]{'~resolve'} = $to_resolve || 0; - DEBUG > 1 and print " Making note to ", $dont_ignore ? 'not ' : '', + DEBUG > 1 and print STDERR " 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 ", + DEBUG > 1 and $dont_ignore and print STDERR " Making note to treat contents as ", ($to_resolve ? 'verbatim/plain' : 'data'), " paragraphs\n"; - DEBUG > 1 and print " (Stack now: ", $self->_dump_curr_open(), ")\n"; + DEBUG > 1 and print STDERR " (Stack now: ", $self->_dump_curr_open(), ")\n"; push @$curr_open, $para; if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) { - DEBUG > 1 and print "Ignoring ignorable =begin\n"; + DEBUG > 1 and print STDERR "Ignoring ignorable =begin\n"; } else { $self->{'content_seen'} ||= 1; $self->_handle_element_start((my $scratch='for'), $para->[1]); @@ -1032,7 +1120,7 @@ sub _ponder_end { my $content = join ' ', splice @$para, 2; $content =~ s/^\s+//s; $content =~ s/\s+$//s; - DEBUG and print "Ogling '=end $content' directive\n"; + DEBUG and print STDERR "Ogling '=end $content' directive\n"; unless(length($content)) { $self->whine( @@ -1043,7 +1131,7 @@ sub _ponder_end { : '' ) ); - DEBUG and print "Ignoring targetless =end\n"; + DEBUG and print STDERR "Ignoring targetless =end\n"; return 1; } @@ -1053,7 +1141,7 @@ sub _ponder_end { "'=end $content' is invalid. (Stack: " . $self->_dump_curr_open() . ')' ); - DEBUG and print "Ignoring mistargetted =end $content\n"; + DEBUG and print STDERR "Ignoring mistargetted =end $content\n"; return 1; } @@ -1063,7 +1151,7 @@ sub _ponder_end { "=end $content without matching =begin. (Stack: " . $self->_dump_curr_open() . ')' ); - DEBUG and print "Ignoring mistargetted =end $content\n"; + DEBUG and print STDERR "Ignoring mistargetted =end $content\n"; return 1; } @@ -1075,13 +1163,13 @@ sub _ponder_end { . ". (Stack: " . $self->_dump_curr_open() . ')' ); - DEBUG and print "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n"; + DEBUG and print STDERR "Ignoring mistargetted =end $content at line $para->[1]{'start_line'}\n"; return 1; } # Else it's okay to close... if(grep $_->[1]{'~ignore'}, @$curr_open) { - DEBUG > 1 and print "Not firing any event for this =end $content because in an ignored region\n"; + DEBUG > 1 and print STDERR "Not firing any event for this =end $content because in an ignored region\n"; # And that may be because of this to-be-closed =for region, or some # other one, but it doesn't matter. } else { @@ -1091,7 +1179,7 @@ sub _ponder_end { $self->{'content_seen'} ||= 1; $self->_handle_element_end( my $scratch = 'for', $para->[1]); } - DEBUG > 1 and print "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; + DEBUG > 1 and print STDERR "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; pop @$curr_open; return 1; @@ -1100,10 +1188,10 @@ sub _ponder_end { 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: (", + DEBUG and print STDERR "Stack is nonempty at end-document: (", $self->_dump_curr_open(), ")\n"; - DEBUG > 9 and print "Stack: ", pretty($curr_open), "\n"; + DEBUG > 9 and print STDERR "Stack: ", pretty($curr_open), "\n"; unshift @$paras, $self->_closers_for_all_curr_open; # Make sure there is exactly one ~end in the parastack, at the end: @$paras = grep $_->[0] ne '~end', @$paras; @@ -1114,7 +1202,7 @@ sub _ponder_doc_end { return 1; } else { - DEBUG and print "Okay, stack is empty now.\n"; + DEBUG and print STDERR "Okay, stack is empty now.\n"; } # Try generating errata section, if applicable @@ -1123,13 +1211,13 @@ sub _ponder_doc_end { my @extras = $self->_gen_errata(); if(@extras) { unshift @$paras, @extras; - DEBUG and print "Generated errata... relooping...\n"; + DEBUG and print STDERR "Generated errata... relooping...\n"; return 1; # I.e., loop around again to process these fake-o paragraphs } } splice @$paras; # Well, that's that for this paragraph buffer. - DEBUG and print "Throwing end-document event.\n"; + DEBUG and print STDERR "Throwing end-document event.\n"; $self->_handle_element_end( my $scratch = 'Document' ); return 1; # Hasta la byebye @@ -1207,7 +1295,7 @@ sub _ponder_over { ); $para->[1]{'indent'} = 4; } - DEBUG > 1 and print "=over found of type $list_type\n"; + DEBUG > 1 and print STDERR "=over found of type $list_type\n"; $self->{'content_seen'} ||= 1; $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]); @@ -1228,7 +1316,7 @@ sub _ponder_back { } if(@$curr_open and $curr_open->[-1][0] eq '=over') { - DEBUG > 1 and print "=back happily closes matching =over\n"; + DEBUG > 1 and print STDERR "=back happily closes matching =over\n"; # Expected case: we're closing the most recently opened thing #my $over = pop @$curr_open; $self->{'content_seen'} ||= 1; @@ -1236,7 +1324,7 @@ sub _ponder_back { 'over-' . ( (pop @$curr_open)->[1]{'~type'} ), $para->[1] ); } else { - DEBUG > 1 and print "=back found without a matching =over. Stack: (", + DEBUG > 1 and print STDERR "=back found without a matching =over. Stack: (", join(', ', map $_->[0], @$curr_open), ").\n"; $self->whine( $para->[1]{'start_line'}, @@ -1288,7 +1376,7 @@ sub _ponder_item { } 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"; + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; if($item_type eq 'text') { # Nothing special needs doing for 'text' @@ -1311,7 +1399,7 @@ sub _ponder_item { } 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"; + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; @@ -1338,10 +1426,10 @@ sub _ponder_item { 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"; + DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n"; } else { - DEBUG > 1 and print " Numeric item has ", $para->[1]{'number'}, + DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'}, " instead of the expected value of $expected_value\n"; $self->whine( $para->[1]{'start_line'}, @@ -1354,10 +1442,10 @@ sub _ponder_item { 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"; + DEBUG and print STDERR "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"; + DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n"; push @$para, ''; # Just so it's not contentless } } @@ -1366,13 +1454,13 @@ sub _ponder_item { } 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"; + DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; if($item_type eq 'bullet') { # as expected! if( $para->[1]{'~_freaky_para_hack'} ) { - DEBUG and print "Accomodating '=item * Foo' tolerance hack.\n"; + DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n"; push @$para, delete $para->[1]{'~_freaky_para_hack'}; } @@ -1400,10 +1488,10 @@ sub _ponder_item { 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"; + DEBUG and print STDERR "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"; + DEBUG and print STDERR "Can't assimilate following ", $paras->[0][0], "\n"; push @$para, ''; # Just so it's not contentless } } @@ -1419,7 +1507,7 @@ sub _ponder_item { sub _ponder_Plain { my ($self,$para) = @_; - DEBUG and print " giving plain treatment...\n"; + DEBUG and print STDERR " giving plain treatment...\n"; unless( @$para == 2 or ( @$para == 3 and $para->[2] eq '' ) or $para->[1]{'~cooked'} ) { @@ -1436,7 +1524,7 @@ sub _ponder_Plain { sub _ponder_Verbatim { my ($self,$para) = @_; - DEBUG and print " giving verbatim treatment...\n"; + DEBUG and print STDERR " giving verbatim treatment...\n"; $para->[1]{'xml:space'} = 'preserve'; @@ -1487,7 +1575,7 @@ sub _ponder_Verbatim { sub _ponder_Data { my ($self,$para) = @_; - DEBUG and print " giving data treatment...\n"; + DEBUG and print STDERR " giving data treatment...\n"; $para->[1]{'xml:space'} = 'preserve'; push @$para, join "\n", splice(@$para, 2) if @$para > 3; return; @@ -1548,7 +1636,7 @@ sub _closers_for_all_curr_open { $copy[1]{'fake-closer'} = 1; - DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n"; + DEBUG and print STDERR "Queuing up fake-o event: ", pretty(\@copy), "\n"; unshift @closers, \@copy; } return @closers; @@ -1562,7 +1650,7 @@ sub _verbatim_format { 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"; + DEBUG and print STDERR "_verbatim_format appends a newline to $i: $p->[$i]\n"; $p->[$i] .= "\n"; # Unlike with simple Verbatim blocks, we don't end up just doing # a join("\n", ...) on the contents, so we have to append a @@ -1570,11 +1658,11 @@ sub _verbatim_format { } if( DEBUG > 4 ) { - print "<<\n"; + print STDERR "<<\n"; for(my $i = $#$p; $i >= 2; $i--) { # work backwards over the lines - print "_verbatim_format $i: $p->[$i]"; + print STDERR "_verbatim_format $i: $p->[$i]"; } - print ">>\n"; + print STDERR ">>\n"; } for(my $i = $#$p; $i > 2; $i--) { @@ -1583,19 +1671,19 @@ sub _verbatim_format { #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"; + DEBUG > 5 and print STDERR "Scrutinizing line $i: $$p[$i]\n"; if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) { - DEBUG > 5 and print " It's a formatty line. ", + DEBUG > 5 and print STDERR " It's a formatty line. ", "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n"; if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) { - DEBUG > 5 and print " Previous line is formatty! Skipping this one.\n"; + DEBUG > 5 and print STDERR " Previous line is formatty! Skipping this one.\n"; next; } else { - DEBUG > 5 and print " Previous line is non-formatty! Yay!\n"; + DEBUG > 5 and print STDERR " Previous line is non-formatty! Yay!\n"; } } else { - DEBUG > 5 and print " It's not a formatty line. Ignoring\n"; + DEBUG > 5 and print STDERR " It's not a formatty line. Ignoring\n"; next; } @@ -1606,7 +1694,7 @@ sub _verbatim_format { # #:^^^^^^^^^^^^^^^^^ ///////////// - DEBUG > 4 and print "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n"; + DEBUG > 4 and print STDERR "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n"; $formatting = ' ' . $1; $formatting =~ s/\s+$//s; # nix trailing whitespace @@ -1624,19 +1712,19 @@ sub _verbatim_format { # 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"; + DEBUG > 4 and print STDERR "Formatting <$formatting> on <", $p->[$i-1], ">\n"; my @new_line; while( $formatting =~ m{\G(( +)|(\^+)|(\/+)|(\%+))}g ) { - #print "Format matches $1\n"; + #print STDERR "Format matches $1\n"; if($2) { - #print "SKIPPING <$2>\n"; + #print STDERR "SKIPPING <$2>\n"; push @new_line, substr($p->[$i-1], pos($formatting)-length($1), length($1)); } else { - #print "SNARING $+\n"; + #print STDERR "SNARING $+\n"; push @new_line, [ ( $3 ? 'VerbatimB' : @@ -1645,14 +1733,14 @@ sub _verbatim_format { ), {}, substr($p->[$i-1], pos($formatting)-length($1), length($1)) ]; - #print "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n"; + #print STDERR "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n"; } } my @nixed = splice @$p, $i-1, 2, @new_line; # replace myself and the next line - DEBUG > 10 and print "Nixed count: ", scalar(@nixed), "\n"; + DEBUG > 10 and print STDERR "Nixed count: ", scalar(@nixed), "\n"; - DEBUG > 6 and print "New version of the above line is these tokens (", + DEBUG > 6 and print STDERR "New version of the above line is these tokens (", scalar(@new_line), "):", map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n"; $i--; # So the next line we scrutinize is the line before the one @@ -1664,7 +1752,7 @@ sub _verbatim_format { # 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"; + DEBUG > 5 and print STDERR "_verbatim_format merges {$p->[$i]} and {$p->[$i+1]}\n"; $p->[$i] .= splice @$p, $i+1, 1; # merge --$i; # and back up } @@ -1675,9 +1763,9 @@ sub _verbatim_format { # 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"; + DEBUG > 5 and print STDERR "_verbatim_format killed the terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]}\n"; } else { - DEBUG > 5 and print + DEBUG > 5 and print STDERR "No terminal newline on #$i: {$p->[$i]}, after {$p->[$i-1]} !?\n"; } last; # we only want the next one @@ -1719,7 +1807,7 @@ sub _treelet_from_formatting_codes { # into just 1 ' '. Is this the regex's doing or 'raw's? my $inL = 0; - DEBUG > 4 and print "Paragraph:\n$para\n\n"; + DEBUG > 4 and print STDERR "Paragraph:\n$para\n\n"; # Here begins our frightening tokenizer RE. The following regex matches # text in four main parts: @@ -1777,14 +1865,14 @@ sub _treelet_from_formatting_codes { ) /xgo ) { - DEBUG > 4 and print "\nParagraphic tokenstack = (@stack)\n"; + DEBUG > 4 and print STDERR "\nParagraphic tokenstack = (@stack)\n"; if(defined $1) { if(defined $2) { - DEBUG > 3 and print "Found complex start-text code \"$1\"\n"; + DEBUG > 3 and print STDERR "Found complex start-text code \"$1\"\n"; push @stack, length($2) + 1; # length of the necessary complex end-code string } else { - DEBUG > 3 and print "Found simple start-text code \"$1\"\n"; + DEBUG > 3 and print STDERR "Found simple start-text code \"$1\"\n"; push @stack, 0; # signal that we're looking for simple } push @lineage, [ substr($1,0,1), {}, ]; # new node object @@ -1797,32 +1885,32 @@ sub _treelet_from_formatting_codes { } } elsif(defined $4) { - DEBUG > 3 and print "Found apparent complex end-text code \"$3$4\"\n"; + DEBUG > 3 and print STDERR "Found apparent complex end-text code \"$3$4\"\n"; # This is where it gets messy... if(! @stack) { # We saw " >>>>" but needed nothing. This is ALL just stuff then. - DEBUG > 4 and print " But it's really just stuff.\n"; + DEBUG > 4 and print STDERR " But it's really just stuff.\n"; push @{ $lineage[-1] }, $3, $4; next; } elsif(!$stack[-1]) { # We saw " >>>>" but needed only ">". Back pos up. - DEBUG > 4 and print " And that's more than we needed to close simple.\n"; + DEBUG > 4 and print STDERR " And that's more than we needed to close simple.\n"; push @{ $lineage[-1] }, $3; # That was a for-real space, too. pos($para) = pos($para) - length($4) + 1; } elsif($stack[-1] == length($4)) { # We found " >>>>", and it was exactly what we needed. Commonest case. - DEBUG > 4 and print " And that's exactly what we needed to close complex.\n"; + DEBUG > 4 and print STDERR " And that's exactly what we needed to close complex.\n"; } elsif($stack[-1] < length($4)) { # We saw " >>>>" but needed only " >>". Back pos up. - DEBUG > 4 and print " And that's more than we needed to close complex.\n"; + DEBUG > 4 and print STDERR " And that's more than we needed to close complex.\n"; pos($para) = pos($para) - length($4) + $stack[-1]; } else { # We saw " >>>>" but needed " >>>>>>". So this is all just stuff! - DEBUG > 4 and print " But it's really just stuff, because we needed more.\n"; + DEBUG > 4 and print STDERR " But it's really just stuff, because we needed more.\n"; push @{ $lineage[-1] }, $3, $4; next; } - #print "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n"; + #print STDERR "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n"; push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; # Keep the element from being childless @@ -1839,11 +1927,11 @@ sub _treelet_from_formatting_codes { $raw .= $3.$4 if $inL; } elsif(defined $5) { - DEBUG > 3 and print "Found apparent simple end-text code \"$5\"\n"; + DEBUG > 3 and print STDERR "Found apparent simple end-text code \"$5\"\n"; if(@stack and ! $stack[-1]) { # We're indeed expecting a simple end-code - DEBUG > 4 and print " It's indeed an end-code.\n"; + DEBUG > 4 and print STDERR " It's indeed an end-code.\n"; if(length($5) == 2) { # There was a space there: " >" push @{ $lineage[-1] }, ' '; @@ -1854,7 +1942,7 @@ sub _treelet_from_formatting_codes { pop @stack; pop @lineage; } else { - DEBUG > 4 and print " It's just stuff.\n"; + DEBUG > 4 and print STDERR " It's just stuff.\n"; push @{ $lineage[-1] }, $5; } @@ -1867,7 +1955,7 @@ sub _treelet_from_formatting_codes { $raw .= $5 if $inL; } elsif(defined $6) { - DEBUG > 3 and print "Found stuff \"$6\"\n"; + DEBUG > 3 and print STDERR "Found stuff \"$6\"\n"; push @{ $lineage[-1] }, $6; $raw .= $6 if $inL; # XXX does not capture multiplace whitespaces -- 'raw' ends up with @@ -1875,7 +1963,7 @@ sub _treelet_from_formatting_codes { } else { # should never ever ever ever happen - DEBUG and print "AYYAYAAAAA at line ", __LINE__, "\n"; + DEBUG and print STDERR "AYYAYAAAAA at line ", __LINE__, "\n"; die "SPORK 512512!"; } } @@ -1895,7 +1983,7 @@ sub _treelet_from_formatting_codes { $x = $code . "<$x>"; } } - DEBUG > 1 and print "Unterminated $x sequence\n"; + DEBUG > 1 and print STDERR "Unterminated $x sequence\n"; $self->whine($start_line, "Unterminated $x sequence", ); @@ -2023,7 +2111,7 @@ 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 +line_count pod_para_count in_pod ~tried_gen_errata all_errata errata errors_seen Title)) { delete $self->{$_}; diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm index 3ef64eea650..a32d8b813c2 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm @@ -9,7 +9,7 @@ use Carp (); use Pod::Simple::Methody (); use Pod::Simple (); use vars qw( @ISA $VERSION ); -$VERSION = '3.29'; +$VERSION = '3.32'; @ISA = ('Pod::Simple::Methody'); BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG @@ -91,9 +91,9 @@ sub emit_par { 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; + $self->{'Thispara'} =~ s/$Pod::Simple::shy//g; my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n"); - $out =~ tr{\xA0}{ } if Pod::Simple::ASCII; + $out =~ s/$Pod::Simple::nbsp/ /g; print {$self->{'output_fh'}} $out, #"\n" ; @@ -107,10 +107,8 @@ sub emit_par { sub end_Verbatim { return unless $_[0]{'Errata_seen'}; my $self = shift; - if(Pod::Simple::ASCII) { - $self->{'Thispara'} =~ tr{\xA0}{ }; - $self->{'Thispara'} =~ tr{\xAD}{}d; - } + $self->{'Thispara'} =~ s/$Pod::Simple::nbsp/ /g; + $self->{'Thispara'} =~ s/$Pod::Simple::shy//g; my $i = ' ' x ( 2 * $self->{'Indent'} + 4); @@ -159,8 +157,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm index 2bbd50a6643..603d4a5b2d0 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm @@ -2,7 +2,7 @@ require 5; package Pod::Simple::Debug; use strict; use vars qw($VERSION ); -$VERSION = '3.29'; +$VERSION = '3.32'; sub import { my($value,$variable); @@ -47,10 +47,10 @@ sub import { # make a not-really-constant *Pod::Simple::DEBUG = sub () { $$variable } ; $$variable = $value; - print "# Starting Pod::Simple::DEBUG = non-constant $variable with val $value\n"; + print STDERR "# 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"; + print STDERR "# Starting Pod::Simple::DEBUG = $value\n"; } require Pod::Simple; @@ -140,8 +140,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm index dfde4d66b2c..a2325626f08 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::DumpAsText; -$VERSION = '3.29'; +$VERSION = '3.32'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} @@ -26,7 +26,7 @@ sub _handle_element_start { # ($self, $element_name, $attr_hash_r) my $fh = $_[0]{'output_fh'}; my($key, $value); - DEBUG and print "++ $_[1]\n"; + DEBUG and print STDERR "++ $_[1]\n"; print $fh ' ' x ($_[0]{'indent'} || 0), "++", $_[1], "\n"; $_[0]{'indent'}++; @@ -43,7 +43,7 @@ sub _handle_element_start { } sub _handle_text { - DEBUG and print "== \"$_[1]\"\n"; + DEBUG and print STDERR "== \"$_[1]\"\n"; if(length $_[1]) { my $indent = ' ' x $_[0]{'indent'}; @@ -64,7 +64,7 @@ sub _handle_text { } sub _handle_element_end { - DEBUG and print "-- $_[1]\n"; + DEBUG and print STDERR "-- $_[1]\n"; print {$_[0]{'output_fh'}} ' ' x --$_[0]{'indent'}, "--", $_[1], "\n"; return; @@ -119,8 +119,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm index 4db6a061494..bd3919852c7 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::DumpAsXML; -$VERSION = '3.29'; +$VERSION = '3.32'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} @@ -27,7 +27,7 @@ sub _handle_element_start { # ($self, $element_name, $attr_hash_r) my $fh = $_[0]{'output_fh'}; my($key, $value); - DEBUG and print "++ $_[1]\n"; + DEBUG and print STDERR "++ $_[1]\n"; print $fh ' ' x ($_[0]{'indent'} || 0), "<", $_[1]; @@ -46,7 +46,7 @@ sub _handle_element_start { } sub _handle_text { - DEBUG and print "== \"$_[1]\"\n"; + DEBUG and print STDERR "== \"$_[1]\"\n"; if(length $_[1]) { my $indent = ' ' x $_[0]{'indent'}; my $text = $_[1]; @@ -59,7 +59,7 @@ sub _handle_text { } sub _handle_element_end { - DEBUG and print "-- $_[1]\n"; + DEBUG and print STDERR "-- $_[1]\n"; print {$_[0]{'output_fh'}} ' ' x --$_[0]{'indent'}, "</", $_[1], ">\n"; return; @@ -70,11 +70,13 @@ sub _handle_element_end { sub _xml_escape { foreach my $x (@_) { # Escape things very cautiously: - $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; + if ($] ge 5.007_003) { + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg; + } else { # Is broken for non-ASCII platforms on early perls + $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; } @@ -128,8 +130,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm index 2c6494b9ba2..9d8f978eea1 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm @@ -9,7 +9,7 @@ use vars qw( $Doctype_decl $Content_decl ); @ISA = ('Pod::Simple::PullParser'); -$VERSION = '3.29'; +$VERSION = '3.32'; BEGIN { if(defined &DEBUG) { } # no-op elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } @@ -188,7 +188,7 @@ sub new { $new->accept_targets( 'html', 'HTML' ); $new->accept_codes('VerbatimFormatted'); $new->accept_codes(@_to_accept); - DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n"; + DEBUG > 2 and print STDERR "To accept: ", join(' ',@_to_accept), "\n"; $new->perldoc_url_prefix( $Perldoc_URL_Prefix ); $new->perldoc_url_postfix( $Perldoc_URL_Postfix ); @@ -232,7 +232,7 @@ sub __adjust_html_h_levels { sub batch_mode_page_object_init { my($self, $batchconvobj, $module, $infile, $outfile, $depth) = @_; - DEBUG and print "Initting $self\n for $module\n", + DEBUG and print STDERR "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); @@ -255,12 +255,12 @@ sub do_beginning { if(defined $self->force_title) { $title = $self->force_title; - DEBUG and print "Forcing title to be $title\n"; + DEBUG and print STDERR "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"; + DEBUG and print STDERR "No content seen in search for title.\n"; return; } $self->{'Title'} = $title; @@ -270,7 +270,7 @@ sub do_beginning { } else { $title = $self->default_title; $title = '' unless defined $title; - DEBUG and print "Title defaults to $title\n"; + DEBUG and print STDERR "Title defaults to $title\n"; } } @@ -305,7 +305,7 @@ sub do_beginning { $after, ; - DEBUG and print "Returning from do_beginning...\n"; + DEBUG and print STDERR "Returning from do_beginning...\n"; return 1; } @@ -368,9 +368,9 @@ sub do_middle { 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"; + DEBUG and print STDERR "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"; + DEBUG and print STDERR "Odd, couldn't find where to insert the index in the output!\n"; # I don't think this should ever happen. } return 1; @@ -502,7 +502,7 @@ sub _do_middle_main_loop { if(defined $name) { my $esc = esc( $self->section_name_tidy( $name ) ); print $fh qq[name="$esc"]; - DEBUG and print "Linearized ", scalar(@to_unget), + DEBUG and print STDERR "Linearized ", scalar(@to_unget), " tokens as \"$name\".\n"; push @{ $self->{'PSHTML_index_points'} }, [$tagname, $name] if $ToIndex{ $tagname }; @@ -510,7 +510,7 @@ sub _do_middle_main_loop { # just their content), but ahwell. } else { # ludicrously long, so nevermind - DEBUG and print "Linearized ", scalar(@to_unget), + DEBUG and print STDERR "Linearized ", scalar(@to_unget), " tokens, but it was too long, so nevermind.\n"; } print $fh "\n>"; @@ -523,7 +523,7 @@ sub _do_middle_main_loop { $self->unget_token($next); next; } - DEBUG and print " raw text ", $next->text, "\n"; + DEBUG and print STDERR " raw text ", $next->text, "\n"; # The parser sometimes preserves newlines and sometimes doesn't! (my $text = $next->text) =~ s/\n\z//; print $fh $text, "\n"; @@ -608,7 +608,7 @@ sub do_man_link { $frag = $self->section_escape($frag) if defined $frag and length($frag .= ''); # (stringify) - DEBUG and print "Resolving \"$to/$frag\"\n\n"; + DEBUG and print STDERR "Resolving \"$to/$frag\"\n\n"; return $self->resolve_man_page_link($to, $frag); } @@ -627,18 +627,18 @@ sub do_pod_link { $section = $self->section_escape($section) if defined $section and length($section .= ''); # (stringify) - DEBUG and printf "Resolving \"%s\" \"%s\"...\n", + DEBUG and printf STDERR "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 ", + DEBUG > 1 and print STDERR "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)", + DEBUG > 4 and print STDERR " resolve_pod_link_by_table(T,S)", " didn't return anything interesting.\n"; } } @@ -648,15 +648,15 @@ sub do_pod_link { 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"; + and print STDERR "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"; + DEBUG > 1 and print STDERR "resolve_pod_page_link gives ", $there || "(nil)", "\n"; unless( defined $there and length $there ) { - DEBUG and print "Can't resolve $to\n"; + DEBUG and print STDERR "Can't resolve $to\n"; return undef; } # resolve_pod_page_link returning undef is how it @@ -665,18 +665,18 @@ sub do_pod_link { $to = $there; } - #DEBUG and print "So far [", $to||'nil', "] [", $section||'nil', "]\n"; + #DEBUG and print STDERR "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", + DEBUG and printf STDERR "Oddly, couldn't resolve \"%s\" \"%s\"...\n", $to || "(nil)", $section || "(nil)"; return undef; } - DEBUG and print "Resolved to $out\n"; + DEBUG and print STDERR "Resolved to $out\n"; return $out; } @@ -695,7 +695,11 @@ sub section_name_tidy { $section =~ s/^\s+//; $section =~ s/\s+$//; $section =~ tr/ /_/; - $section =~ tr/\x00-\x1F\x80-\x9F//d if 'A' eq chr(65); # drop crazy characters + if ($] ge 5.006) { + $section =~ s/[[:cntrl:][:^ascii:]]//g; # drop crazy characters + } elsif ('A' eq chr(65)) { # But not on early EBCDIC + $section =~ tr/\x00-\x1F\x80-\x9F//d; + } $section = $self->unicode_escape_url($section); $section = '_' unless length $section; return $section; @@ -714,12 +718,13 @@ sub general_url_escape { # A pretty conservative escaping, behoovey even for query components # of a URL (see RFC 2396) - $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',ord($1))/eg; + if ($] ge 5.007_003) { + $string =~ s/([^-_\.!~*()abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/sprintf('%%%02X',utf8::native_to_unicode(ord($1)))/eg; + } else { # Is broken for non-ASCII platforms on early perls + $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; } @@ -752,16 +757,16 @@ sub resolve_pod_page_link_singleton_mode { sub resolve_pod_page_link_batch_mode { my($self, $to) = @_; - DEBUG > 1 and print " During batch mode, resolving $to ...\n"; + DEBUG > 1 and print STDERR " 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"; + DEBUG and print STDERR "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"; + DEBUG > 1 and print STDERR " => $out\n"; return $out; } @@ -851,21 +856,28 @@ sub esc { # a function. @_ = splice @_; # break aliasing } else { my $x = shift; - $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; + if ($] ge 5.007_003) { + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg; + } else { # Is broken for non-ASCII platforms on early perls + $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; + if (defined $x) { + if ($] ge 5.007_003) { + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg + } else { # Is broken for non-ASCII platforms on early perls + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg + } + } # 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 @_; } @@ -1100,8 +1112,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm index 19e700b825f..5758645073a 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm @@ -5,7 +5,7 @@ use strict; use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA ); -$VERSION = '3.29'; +$VERSION = '3.32'; @ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML! # TODO: nocontents stylesheets. Strike some of the color variations? @@ -270,7 +270,7 @@ sub _do_one_batch_conversion { $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", + DEBUG > 4 and printf STDERR "%s %sb < $infile %s %sb\n", $outfile, -s $outfile, $infile, -s $infile ; @@ -295,7 +295,7 @@ sub note_for_contents_file { [ join("::", @$namelets), $infile, $outfile, $namelets ] # 0 1 2 3 ; - DEBUG > 3 and print "Noting @$c[-1]\n"; + DEBUG > 3 and print STDERR "Noting @$c[-1]\n"; } return; } @@ -446,7 +446,7 @@ sub makepath { die "$dir exists but not as a directory!?" unless -d $dir; next; } - DEBUG > 3 and print " Making $dir\n"; + DEBUG > 3 and print STDERR " Making $dir\n"; mkdir $dir, 0777 or die "Can't mkdir $dir: $!\nAborting" ; @@ -533,7 +533,7 @@ sub modnames2paths { # return a hashref mapping modulenames => paths my $m2p; { my $search = $self->search_class->new; - DEBUG and print "Searching via $search\n"; + DEBUG and print STDERR "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 @@ -545,13 +545,13 @@ sub modnames2paths { # return a hashref mapping modulenames => paths $self->muse("That's odd... no modules found!") unless keys %$m2p; if( DEBUG > 4 ) { - print "Modules found (name => path):\n"; + print STDERR "Modules found (name => path):\n"; foreach my $m (sort {lc($a) cmp lc($b)} keys %$m2p) { - print " $m $$m2p{$m}\n"; + print STDERR " $m $$m2p{$m}\n"; } - print "(total ", scalar(keys %$m2p), ")\n\n"; + print STDERR "(total ", scalar(keys %$m2p), ")\n\n"; } elsif( DEBUG ) { - print "Found ", scalar(keys %$m2p), " modules.\n"; + print STDERR "Found ", scalar(keys %$m2p), " modules.\n"; } $self->muse( "Found ", scalar(keys %$m2p), " modules." ); @@ -566,7 +566,7 @@ sub _wopen { my($self, $outpath) = @_; require Symbol; my $out_fh = Symbol::gensym(); - DEBUG > 5 and print "Write-opening to $outpath\n"; + DEBUG > 5 and print STDERR "Write-opening to $outpath\n"; return $out_fh if open($out_fh, "> $outpath"); require Carp; Carp::croak("Can't write-open $outpath: $!"); @@ -608,9 +608,9 @@ sub _spray_css { 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"; + DEBUG > 5 and print STDERR "Noting $$chunk[0] as a file I'll create.\n"; } else { - DEBUG > 5 and print "OK, noting $$chunk[0] as an external CSS.\n"; + DEBUG > 5 and print STDERR "OK, noting $$chunk[0] as an external CSS.\n"; # Requires no further attention. next; } @@ -620,7 +620,7 @@ sub _spray_css { 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"; + DEBUG > 5 and print STDERR "Wrote $outfile\n"; } return; @@ -771,9 +771,9 @@ sub _spray_javascript { 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"; + DEBUG > 5 and print STDERR "Noting $$script[0] as a file I'll create.\n"; } else { - DEBUG > 5 and print "OK, noting $$script[0] as an external JavaScript.\n"; + DEBUG > 5 and print STDERR "OK, noting $$script[0] as an external JavaScript.\n"; next; } @@ -783,7 +783,7 @@ sub _spray_javascript { 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"; + DEBUG > 5 and print STDERR "Wrote $outfile\n"; } return; @@ -1321,8 +1321,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm index 2139509303e..0d487313b2d 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm @@ -3,12 +3,12 @@ require 5; package Pod::Simple::LinkSection; # Based somewhat dimly on Array::Autojoin use vars qw($VERSION ); -$VERSION = '3.29'; +$VERSION = '3.32'; use strict; use Pod::Simple::BlackBox; use vars qw($VERSION ); -$VERSION = '3.29'; +$VERSION = '3.32'; use overload( # So it'll stringify nice '""' => \&Pod::Simple::BlackBox::stringify_lol, @@ -137,8 +137,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm index d867b1ce932..29ed32090be 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm @@ -4,7 +4,7 @@ package Pod::Simple::Methody; use strict; use Pod::Simple (); use vars qw(@ISA $VERSION); -$VERSION = '3.29'; +$VERSION = '3.32'; @ISA = ('Pod::Simple'); # Yes, we could use named variables, but I want this to be impose @@ -115,8 +115,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm index 3a87b998423..af24049f11f 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::Progress; -$VERSION = '3.29'; +$VERSION = '3.32'; use strict; # Objects of this class are used for noting progress of an diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm index 0e47ec3413b..758f42d6594 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm @@ -1,6 +1,6 @@ require 5; package Pod::Simple::PullParser; -$VERSION = '3.29'; +$VERSION = '3.32'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} @@ -88,7 +88,7 @@ sub new { $self->{'text_token_class'} ||= 'Pod::Simple::PullParserTextToken'; $self->{'end_token_class'} ||= 'Pod::Simple::PullParserEndToken'; - DEBUG > 1 and print "New pullparser object: $self\n"; + DEBUG > 1 and print STDERR "New pullparser object: $self\n"; return $self; } @@ -97,8 +97,8 @@ sub new { 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 (", + DEBUG > 1 and print STDERR "\nget_token starting up on $self.\n"; + DEBUG > 2 and print STDERR " Items in token-buffer (", scalar( @{ $self->{'token_buffer'} } ) , ") :\n", map( " " . $_->dump . "\n", @{ $self->{'token_buffer'} } @@ -108,25 +108,25 @@ sub get_token { ; until( @{ $self->{'token_buffer'} } ) { - DEBUG > 3 and print "I need to get something into my empty token buffer...\n"; + DEBUG > 3 and print STDERR "I need to get something into my empty token buffer...\n"; if($self->{'source_dead'}) { - DEBUG and print "$self 's source is dead.\n"; + DEBUG and print STDERR "$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"; + DEBUG and print STDERR "$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"; + DEBUG > 3 and print STDERR " Fetching a line from source filehandle $fh...\n"; local $/ = $Pod::Simple::NL; push @lines, scalar(<$fh>); # readline - DEBUG > 3 and print " Line is: ", + DEBUG > 3 and print STDERR " 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"; + DEBUG and print STDERR "That's it for that source fh! Killing.\n"; delete $self->{'source_fh'}; # so it can be GC'd last; } @@ -138,31 +138,31 @@ sub get_token { } if(DEBUG > 8) { - print "* I've gotten ", scalar(@lines), " lines:\n"; + print STDERR "* I've gotten ", scalar(@lines), " lines:\n"; foreach my $l (@lines) { if(defined $l) { - print " line {$l}\n"; + print STDERR " line {$l}\n"; } else { - print " line undef\n"; + print STDERR " line undef\n"; } } - print "* end of ", scalar(@lines), " lines\n"; + print STDERR "* 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 ", + DEBUG and print STDERR "$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"; + DEBUG > 3 and print STDERR " 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"; + DEBUG and print STDERR "That's it for that source arrayref! Killing.\n"; $self->SUPER::parse_lines(undef); delete $self->{'source_arrayref'}; # so it can be GC'd } @@ -170,12 +170,12 @@ sub get_token { } elsif(exists $self->{'source_scalar_ref'}) { - DEBUG and print "$self 's source is scalarref $self->{'source_scalar_ref'}, with ", + DEBUG and print STDERR "$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"; + DEBUG > 3 and print STDERR " Fetching a line from source-string...\n"; if( ${ $self->{'source_scalar_ref'} } =~ m/([^\n\r]*)((?:\r?\n)?)/g ) { @@ -189,7 +189,7 @@ sub get_token { } 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"; + DEBUG and print STDERR "That's it for that source scalarref! Killing.\n"; } @@ -197,7 +197,7 @@ sub get_token { die "What source??"; } } - DEBUG and print "get_token about to return ", + DEBUG and print STDERR "get_token about to return ", Pod::Simple::pretty( @{$self->{'token_buffer'}} ? $self->{'token_buffer'}[-1] : undef ), "\n"; @@ -206,7 +206,7 @@ sub get_token { sub unget_token { my $self = shift; - DEBUG and print "Ungetting ", scalar(@_), " tokens: ", + DEBUG and print STDERR "Ungetting ", scalar(@_), " tokens: ", @_ ? "@_\n" : "().\n"; foreach my $t (@_) { Carp::croak "Can't unget that, because it's not a token -- it's undef!" @@ -218,7 +218,7 @@ sub unget_token { } unshift @{$self->{'token_buffer'}}, @_; - DEBUG > 1 and print "Token buffer now has ", + DEBUG > 1 and print STDERR "Token buffer now has ", scalar(@{$self->{'token_buffer'}}), " items in it.\n"; return; } @@ -237,36 +237,36 @@ sub set_source { 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"; + DEBUG and print STDERR "$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"; + DEBUG and print STDERR "$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"; + DEBUG and print STDERR "$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"; + DEBUG and print STDERR "$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"; + DEBUG and print STDERR "$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"; + DEBUG and print STDERR " Its name is $_[0].\n"; # TODO: file-discipline things here! } $self->{'source_fh'} = $handle; - DEBUG and print " Its handle is $handle\n"; + DEBUG and print STDERR " Its handle is $handle\n"; return 1; } @@ -356,7 +356,7 @@ sub _get_titled_section { if ($state == 0) { # seeking =head1 if( $token->is_start and $token->tagname eq 'head1' ) { - DEBUG and print " Found head1. Seeking content...\n"; + DEBUG and print STDERR " Found head1. Seeking content...\n"; ++$state; $head1_text_content = ''; } @@ -365,21 +365,21 @@ sub _get_titled_section { elsif($state == 1) { # accumulating text until end of head1 if( $token->is_text ) { unless ($skipX) { - DEBUG and print " Adding \"", $token->text, "\" to head1-content.\n"; + DEBUG and print STDERR " Adding \"", $token->text, "\" to head1-content.\n"; $head1_text_content .= $token->text; } } elsif( $token->is_tagname('X') ) { # We're going to want to ignore X<> stuff. $skipX = $token->is_start; - DEBUG and print +($skipX ? 'Start' : 'End'), 'ing ignoring of X<> tag'; + DEBUG and print STDERR +($skipX ? 'Start' : 'End'), 'ing ignoring of X<> tag'; } elsif( $token->is_end and $token->tagname eq 'head1' ) { - DEBUG and print " Found end of head1. Considering content...\n"; + DEBUG and print STDERR " 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"; + DEBUG and print STDERR " Yup, it was $titlename. Seeking next para-content...\n"; ++$state; } elsif( $desperate_for_title @@ -400,11 +400,11 @@ sub _get_titled_section { ) { # Looks good; trim it ($title = $head1_text_content) =~ s/\s+$//; - DEBUG and print " It looks titular: \"$title\".\n\n Using that.\n"; + DEBUG and print STDERR " It looks titular: \"$title\".\n\n Using that.\n"; last; } else { --$state; - DEBUG and print " Didn't look titular ($head1_text_content).\n", + DEBUG and print STDERR " Didn't look titular ($head1_text_content).\n", "\n Dropping back to seeking-head1-content mode...\n"; } } @@ -413,7 +413,7 @@ sub _get_titled_section { 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"; + DEBUG and print STDERR " Found start of Para. Accumulating content...\n"; $para_text_content = ''; ++$state; } else { @@ -426,12 +426,12 @@ sub _get_titled_section { elsif($state == 3) { # accumulating text until end of Para if( $token->is_text ) { - DEBUG and print " Adding \"", $token->text, "\" to para-content.\n"; + DEBUG and print STDERR " 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: ", + DEBUG and print STDERR " Found end of Para. Considering content: ", $para_text_content, "\n"; if( $para_text_content =~ m/\S/ @@ -440,11 +440,11 @@ sub _get_titled_section { : 1) ) { # Some minimal sanity constraints, I think. - DEBUG and print " It looks contentworthy, I guess. Using it.\n"; + DEBUG and print STDERR " 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"; + DEBUG and print STDERR " Doesn't look at all contentworthy!\n Giving up.\n"; undef $title; last; } @@ -461,8 +461,8 @@ sub _get_titled_section { $self->unget_token(@to_unget); if(DEBUG) { - if(defined $title) { print " Returning title <$title>\n" } - else { print "Returning title <>\n" } + if(defined $title) { print STDERR " Returning title <$title>\n" } + else { print STDERR "Returning title <>\n" } } return '' unless defined $title; @@ -476,7 +476,7 @@ sub _get_titled_section { sub _handle_element_start { my $self = shift; # leaving ($element_name, $attr_hash_r) - DEBUG > 2 and print "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n"; + DEBUG > 2 and print STDERR "++ $_[0] (", map("<$_> ", %{$_[1]}), ")\n"; push @{ $self->{'token_buffer'} }, $self->{'start_token_class'}->new(@_); @@ -485,7 +485,7 @@ sub _handle_element_start { sub _handle_text { my $self = shift; # leaving ($text) - DEBUG > 2 and print "== $_[0]\n"; + DEBUG > 2 and print STDERR "== $_[0]\n"; push @{ $self->{'token_buffer'} }, $self->{'text_token_class'}->new(@_); return; @@ -493,7 +493,7 @@ sub _handle_text { sub _handle_element_end { my $self = shift; # leaving ($element_name); - DEBUG > 2 and print "-- $_[0]\n"; + DEBUG > 2 and print STDERR "-- $_[0]\n"; push @{ $self->{'token_buffer'} }, $self->{'end_token_class'}->new(@_); return; @@ -742,8 +742,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. @@ -792,9 +792,9 @@ sub _old_get_title { # some witchery in here last; } - DEBUG and print "-Got token ", $to_unget[-1]->dump, "\n"; + DEBUG and print STDERR "-Got token ", $to_unget[-1]->dump, "\n"; - (DEBUG and print "Too much in the buffer.\n"), + (DEBUG and print STDERR "Too much in the buffer.\n"), last if @to_unget > 25; # sanity my $pattern = ''; @@ -811,7 +811,7 @@ sub _old_get_title { # some witchery in here )) =~ m{<head1>NAME</head1><Para>(X|</?[BCIFLS]>)+</Para>$}s ) { # Whee, it fits the pattern - DEBUG and print "Seems to match =head1 NAME pattern.\n"; + DEBUG and print STDERR "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'; @@ -824,7 +824,7 @@ sub _old_get_title { # some witchery in here and !( $1 eq '1' and $2 eq 'NAME' ) ) { # Well, it fits a fallback pattern - DEBUG and print "Seems to match NAMEless pattern.\n"; + DEBUG and print STDERR "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; @@ -834,7 +834,7 @@ sub _old_get_title { # some witchery in here last; } else { - DEBUG and $pattern and print "Leading pattern: $pattern\n"; + DEBUG and $pattern and print STDERR "Leading pattern: $pattern\n"; } } @@ -842,8 +842,8 @@ sub _old_get_title { # some witchery in here $self->unget_token(@to_unget); if(DEBUG) { - if(defined $title) { print " Returning title <$title>\n" } - else { print "Returning title <>\n" } + if(defined $title) { print STDERR " Returning title <$title>\n" } + else { print STDERR "Returning title <>\n" } } return '' unless defined $title; diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm index bb5ac7adbfe..0d68841d095 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.29'; +$VERSION = '3.32'; sub new { # Class->new(tagname); my $class = shift; @@ -83,8 +83,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm index dbb0b2c859f..f09c10915e1 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.29'; +$VERSION = '3.32'; sub new { # Class->new(tagname, optional_attrhash); my $class = shift; @@ -124,8 +124,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm index 9db7f1ee8fc..17d065535cd 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.29'; +$VERSION = '3.32'; sub new { # Class->new(text); my $class = shift; @@ -70,6 +70,12 @@ Or, if you want to alter the value, you can even do things like this: } ...or however you want to alter the value... + (Note that starting with Perl v5.8, you can use, e.g., + + my $nbsp = chr utf8::unicode_to_native(0xA0); + s/$nbsp/ /g; + + to handle the above regardless if it's an ASCII world or not) } =back @@ -91,8 +97,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm index 46ab1fd4d3a..7f493b964d7 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm @@ -3,7 +3,7 @@ require 5; package Pod::Simple::PullParserToken; # Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token @ISA = (); -$VERSION = '3.29'; +$VERSION = '3.32'; use strict; sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway @@ -50,7 +50,7 @@ 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"; + $DEBUG and print STDERR "Token: ", $token->dump, "\n"; if($token->is_start) { ...access $token->tagname, $token->attr, etc... @@ -104,7 +104,7 @@ 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"; + $DEBUG and print STDERR "Token: ", $token->dump, "\n"; ... } @@ -126,8 +126,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm index 617190418b6..9aea743a7e0 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm @@ -8,7 +8,7 @@ package Pod::Simple::RTF; use strict; use vars qw($VERSION @ISA %Escape $WRAP %Tagmap); -$VERSION = '3.29'; +$VERSION = '3.32'; use Pod::Simple::PullParser (); BEGIN {@ISA = ('Pod::Simple::PullParser')} @@ -17,6 +17,16 @@ BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } $WRAP = 1 unless defined $WRAP; +# These are broken for early Perls on EBCDIC; they could be fixed to work +# better there, but not worth it. These are part of a larger [...] class, so +# are just the strings to substitute into it, as opposed to compiled patterns. +my $cntrl = '[:cntrl:]'; +$cntrl = '\x00-\x1F\x7F' unless eval "qr/[$cntrl]/"; + +my $not_ascii = '[:^ascii:]'; +$not_ascii = '\x80-\xFF' unless eval "qr/[$not_ascii]/"; + + #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub _openclose { @@ -101,7 +111,7 @@ sub new { $new->accept_codes(@_to_accept); $new->accept_codes('VerbatimFormatted'); - DEBUG > 2 and print "To accept: ", join(' ',@_to_accept), "\n"; + DEBUG > 2 and print STDERR "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) @@ -161,13 +171,13 @@ sub do_middle { # the main work if( ($type = $token->type) eq 'text' ) { if( $self->{'rtfverbatim'} ) { - DEBUG > 1 and print " $type " , $token->text, " in verbatim!\n"; + DEBUG > 1 and print STDERR " $type " , $token->text, " in verbatim!\n"; rtf_esc_codely($scratch = $token->text); print $fh $scratch; next; } - DEBUG > 1 and print " $type " , $token->text, "\n"; + DEBUG > 1 and print STDERR " $type " , $token->text, "\n"; $scratch = $token->text; $scratch =~ tr/\t\cb\cc/ /d; @@ -176,7 +186,7 @@ sub do_middle { # the main work s/(?: ^ | - (?<=[\cm\cj\t "\[\<\(]) + (?<=[\r\n\t "\[\<\(]) ) # start on whitespace, sequence-start, or quote ( # something looking like a Perl token: (?: @@ -185,7 +195,7 @@ sub do_middle { # the main work | # or starting alpha, but containing anything strange: (?: - [a-zA-Z'\x80-\xFF]+[\$\@\:_<>\(\\\*]\S+ + [a-zA-Z'${not_ascii}]+[\$\@\:_<>\(\\\*]\S+ ) ) /\cb$1\cc/xsg @@ -194,10 +204,10 @@ sub do_middle { # the main work 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 + [^\r\n]{65} # Snare 65 characters from a line + [^\r\n ]{0,50} # and finish any current word ) - (\x20{1,10})(?![\cm\cj\n]) # capture some spaces not at line-end + (\ {1,10})(?![\r\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. @@ -205,7 +215,7 @@ sub do_middle { # the main work print $fh $scratch; } elsif( $type eq 'start' ) { - DEBUG > 1 and print " +$type ",$token->tagname, + DEBUG > 1 and print STDERR " +$type ",$token->tagname, " (", map("<$_> ", %{$token->attr_hash}), ")\n"; if( ($tagname = $token->tagname) eq 'Verbatim' @@ -220,7 +230,7 @@ sub do_middle { # the main work while( $$t =~ m/$/mg ) { last if ++$line_count > 15; # no point in counting further } - DEBUG > 3 and print " verbatim line count: $line_count\n"; + DEBUG > 3 and print STDERR " verbatim line count: $line_count\n"; } $self->unget_token($next); $self->{'rtfkeep'} = ($line_count > 15) ? '' : '\keepn' ; @@ -242,7 +252,7 @@ sub do_middle { # the main work 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"; + DEBUG > 1 and print STDERR " item-* is too long to be keepn'd.\n"; last; } } elsif (@to_unget > 1 and @@ -254,13 +264,13 @@ sub do_middle { # the main work $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", + DEBUG > 1 and printf STDERR " 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 (", + DEBUG > 1 and print STDERR " item-* now has too many tokens (", scalar(@to_unget), (DEBUG > 4) ? (q<: >, map($_->dump, @to_unget)) : (), ") to be keepn'd.\n"; @@ -275,7 +285,7 @@ sub do_middle { # the main work 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"; + DEBUG and print STDERR "Indenting over $indent_stack[-1] twips.\n"; $self->{'rtfindent'} += $indent_stack[-1]; } elsif ($tagname eq 'L') { @@ -288,7 +298,7 @@ sub do_middle { # the main work $self->unget_token($next); next; } - DEBUG and print " raw text ", $next->text, "\n"; + DEBUG and print STDERR " raw text ", $next->text, "\n"; printf $fh "\n" . $next->text . "\n"; next; } @@ -300,14 +310,14 @@ sub do_middle { # the main work if ($tagname eq 'item-number') { print $fh $token->attr('number'), ". \n"; } elsif ($tagname eq 'item-bullet') { - print $fh "\\'95 \n"; + print $fh "\\'", ord("_"), "\n"; #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}"); } } elsif( $type eq 'end' ) { - DEBUG > 1 and print " -$type ",$token->tagname,"\n"; + DEBUG > 1 and print STDERR " -$type ",$token->tagname,"\n"; if( ($tagname = $token->tagname) =~ m/^over-/s ) { - DEBUG and print "Indenting back $indent_stack[-1] twips.\n"; + DEBUG and print STDERR "Indenting back $indent_stack[-1] twips.\n"; $self->{'rtfindent'} -= pop @indent_stack; pop @stack; } elsif( $tagname eq 'Verbatim' or $tagname eq 'VerbatimFormatted') { @@ -441,7 +451,7 @@ END sub doc_start { my $self = $_[0]; my $title = $self->get_short_title(); - DEBUG and print "Short Title: <$title>\n"; + DEBUG and print STDERR "Short Title: <$title>\n"; $title .= ' ' if length $title; $title =~ s/ *$/ /s; @@ -454,9 +464,9 @@ sub doc_start { if $title =~ m/^\S+$/s and $title =~ m/::/s; # catches the most common case, at least - DEBUG and print "Title0: <$title>\n"; + DEBUG and print STDERR "Title0: <$title>\n"; $title = rtf_esc($title); - DEBUG and print "Title1: <$title>\n"; + DEBUG and print STDERR "Title1: <$title>\n"; $title = '\lang1024\noproof ' . $title if $is_obviously_module_name; @@ -483,19 +493,19 @@ 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/([F${cntrl}\-\\\{\}${not_ascii}])/$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 + s/([F${cntrl}\-\\\{\}${not_ascii}])/$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 + ) =~ s/([F${cntrl}\-\\\{\}${not_ascii}])/$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; @@ -512,19 +522,19 @@ sub rtf_esc_codely { my $x; # scratch if(!defined wantarray) { # void context: alter in-place! for(@_) { - s/([F\x00-\x1F\\\{\}\x7F-\xFF])/$Escape{$1}/g; # ESCAPER + s/([F${cntrl}\\\{\}${not_ascii}])/$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 + s/([F${cntrl}\\\{\}${not_ascii}])/$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 + ) =~ s/([F${cntrl}\\\{\}${not_ascii}])/$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; @@ -532,25 +542,30 @@ sub rtf_esc_codely { } %Escape = ( - map( (chr($_),chr($_)), # things not apparently needing escaping + (($] lt 5.007_003) # Broken for non-ASCII on early Perls + ? (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)) + : (map( (chr(utf8::unicode_to_native($_)),chr(utf8::unicode_to_native($_))), 0x20 .. 0x7E ), - map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things - 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46), + map( (chr($_),sprintf("\\'%02x", utf8::unicode_to_native($_))), + 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", + "\r" => "\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 + $Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space + $Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen # CRAZY HACKS: "\n" => "\\line\n", @@ -662,8 +677,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm index 49df34d3543..d5a4a020811 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm @@ -3,7 +3,7 @@ package Pod::Simple::Search; use strict; use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY); -$VERSION = '3.29'; ## Current version of this package +$VERSION = '3.32'; ## Current version of this package BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level use Carp (); @@ -12,12 +12,13 @@ $SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; # flag to occasionally sleep for $SLEEPY - 1 seconds. $MAX_VERSION_WITHIN ||= 60; +my $IS_CASE_INSENSITIVE = -e uc __FILE__ && -e lc __FILE__; ############################################################################# #use diagnostics; use File::Spec (); -use File::Basename qw( basename ); +use File::Basename qw( basename dirname ); use Config (); use Cwd qw( cwd ); @@ -25,6 +26,7 @@ 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', 'recurse', + 'ciseen' ); #========================================================================== @@ -51,11 +53,11 @@ sub survey { $self->_expand_inc( \@search_dirs ); - $self->{'_scan_count'} = 0; $self->{'_dirs_visited'} = {}; $self->path2name( {} ); $self->name2path( {} ); + $self->ciseen( {} ); $self->limit_re( $self->_limit_glob_to_limit_re ) if $self->{'limit_glob'}; my $cwd = cwd(); my $verbose = $self->verbose; @@ -115,23 +117,33 @@ sub survey { } $self->progress and $self->progress->done( "Noted $$self{'_scan_count'} Pod files total"); + $self->ciseen( {} ); 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, $recurse) = + $path2name, $name2path, $recurse, $ciseen) = map scalar($self->$_()), qw(laborious verbose shadows limit_re callback progress - path2name name2path recurse); + path2name name2path recurse ciseen); + my ($seen, $remember, $files_for); + if ($IS_CASE_INSENSITIVE) { + $seen = sub { $ciseen->{ lc $_[0] } }; + $remember = sub { $name2path->{ $_[0] } = $ciseen->{ lc $_[0] } = $_[1]; }; + $files_for = sub { my $n = lc $_[0]; grep { lc $path2name->{$_} eq $n } %{ $path2name } }; + } else { + $seen = sub { $name2path->{ $_[0] } }; + $remember = sub { $name2path->{ $_[0] } = $_[1] }; + $files_for = sub { my $n = $_[0]; grep { $path2name->{$_} eq $n } %{ $path2name } }; + } my($file, $shortname, $isdir, $modname_bits); return sub { @@ -171,7 +183,6 @@ sub _make_search_callback { return; # (not pruning); } - # Make sure it's a file even worth even considering if($laborious) { unless( @@ -197,31 +208,26 @@ sub _make_search_callback { return; } - if( !$shadows and $name2path->{$name} ) { + if( !$shadows and $seen->($name) ) { $verbose and print "Not worth considering $file ", "-- already saw $name as ", - join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n"; + join(' ', $files_for->($name)), "\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 ); - } + $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} ) { + if ( my $prev = $seen->($name) ) { $verbose and print "Duplicate POD found (shadowing?): $name ($file)\n", - " Already seen in ", - join(' ', grep($path2name->{$_} eq $name, keys %$path2name)), "\n"; + " Already seen in ", join(' ', $files_for->($name)), "\n"; } else { - $name2path->{$name} = $file; # Noting just the first occurrence + $remember->($name, $file); # Noting just the first occurrence } $verbose and print " Noting $name = $file\n"; if( $callback ) { @@ -326,7 +332,14 @@ sub _recurse_dir { closedir(INDIR); return } - my @items = sort readdir(INDIR); + + # Load all items; put no extension before .pod before .pm before .plx?. + my @items = map { $_->[0] } + sort { $a->[1] cmp $b->[1] || $b->[2] cmp $a->[2] } + map { + (my $t = $_) =~ s/[.]p(m|lx?|od)\z//; + [$_, $t, lc($1 || 'z') ] + } readdir(INDIR); closedir(INDIR); push @$modname_bits, $dir_bare unless $dir_bare eq ''; @@ -469,13 +482,15 @@ sub _expand_inc { my($self, $search_dirs) = @_; return unless $self->{'inc'}; + my %seen = map { File::Spec->rel2abs($_) => 1 } @{ $search_dirs }; if ($^O eq 'MacOS') { push @$search_dirs, - grep $_ ne File::Spec->curdir, $self->_mac_whammy(@INC); + grep { !$seen{ File::Spec->rel2abs($_) }++ } $self->_mac_whammy(@INC); # Any other OSs need custom handling here? } else { - push @$search_dirs, grep $_ ne File::Spec->curdir, @INC; + push @$search_dirs, + grep { !$seen{ File::Spec->rel2abs($_) }++ } @INC; } $self->{'laborious'} = 0; # Since inc said to use INC @@ -528,6 +543,14 @@ sub _limit_glob_to_limit_re { # contribution mostly from Tim Jenness <t.jenness@jach.hawaii.edu> +sub _actual_filenames { + my $dir = shift; + my $fn = lc shift; + opendir my $dh, $dir or return; + return map { File::Spec->catdir($dir, $_) } + grep { lc $_ eq $fn } readdir $dh; +} + sub find { my($self, $pod, @search_dirs) = @_; $self = $self->new unless ref $self; # tolerate being a class method @@ -544,34 +567,17 @@ sub find { #@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 - } + $self->_expand_inc(\@search_dirs); + # Add location of binaries such as pod2text: + push @search_dirs, $Config::Config{'scriptdir'} if $self->inc; my %seen_dir; - Dir: - foreach my $dir ( @search_dirs ) { + while (my $dir = shift @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; @@ -580,16 +586,36 @@ sub find { foreach my $ext ('', '.pod', '.pm', '.pl') { # possible extensions my $fullext = $fullname . $ext; - if( -f $fullext and $self->contains_pod( $fullext ) ){ + if ( -f $fullext and $self->contains_pod($fullext) ) { print "FOUND: $fullext\n" if $verbose; + if (@parts > 1 && lc $parts[0] eq 'pod' && $IS_CASE_INSENSITIVE && $ext eq '.pod') { + # Well, this file could be for a program (perldoc) but we actually + # want a module (Pod::Perldoc). So see if there is a .pm with the + # proper casing. + my $subdir = dirname $fullext; + unless (grep { $fullext eq $_ } _actual_filenames $subdir, "$parts[-1].pod") { + print "# Looking for alternate spelling in $subdir\n" if $verbose; + # Try the .pm file. + my $pm = $fullname . '.pm'; + if ( -f $pm and $self->contains_pod($pm) ) { + # Prefer the .pm if its case matches. + if (grep { $pm eq $_ } _actual_filenames $subdir, "$parts[-1].pm") { + print "FOUND: $fullext\n" if $verbose; + return $pm; + } + } + } + } 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; + + # Case-insensitively Look for ./pod directories and slip them in. + for my $subdir ( _actual_filenames($dir, 'pod') ) { + if (-d $subdir) { + $verbose and print "Noticing $subdir and looking there...\n"; + unshift @search_dirs, $subdir; + } } } @@ -1005,6 +1031,7 @@ with default attribute values is used. 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 @@ -1012,8 +1039,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm index 201e37aac95..436cd25e462 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm @@ -5,7 +5,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); -$VERSION = '3.29'; +$VERSION = '3.32'; BEGIN { @ISA = ('Pod::Simple'); *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; @@ -18,31 +18,31 @@ __PACKAGE__->_accessorize( #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ sub _handle_element_start { # self, tagname, attrhash - DEBUG > 2 and print "Handling $_[1] start-event\n"; + DEBUG > 2 and print STDERR "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"; + DEBUG and print STDERR " 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: ", + DEBUG > 3 and print STDERR "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"; + DEBUG > 2 and print STDERR "Handling $_[1] end-event\n"; shift @{$_[0]{'_currpos'}}; - DEBUG > 3 and print "Stack is now: ", + DEBUG > 3 and print STDERR "Stack is now: ", join(">", map $_->[0], @{$_[0]{'_currpos'}}), "\n"; return; } sub _handle_text { # self, text - DEBUG > 2 and print "Handling $_[1] text-event\n"; + DEBUG > 2 and print STDERR "Handling $_[1] text-event\n"; push @{ $_[0]{'_currpos'}[0] }, $_[1]; return; } @@ -50,7 +50,7 @@ sub _handle_text { # self, text # 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"; + DEBUG > 2 and print STDERR "Handling $_[1] paragraph event\n"; my $self = shift; push @{ $self->{'_currpos'}[0] }, [@_]; return; @@ -142,8 +142,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod index e3f09a34e1b..88f85e86de2 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod @@ -46,7 +46,7 @@ anyone has a formatter for that format -- maybe someone cobbled one together but just hasn't released it. B<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 +which contains 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. @@ -78,7 +78,7 @@ like L<HTML::TokeParser>'s interface. L<Pod::Simple::SimpleTree> provides a simple tree interface, rather like L<XML::Parser>'s "Tree" interface. Users familiar with XML handling will -be comfortable with this interface. Users interested in outputting XML, +be comfortable with this interface. Users interested in outputting XML, should look into the modules 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. @@ -87,8 +87,8 @@ of such a class to whatever XML parsing system you are most at home with. B<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 +constructs in the output format. Also be sure to consider how to escape +text nodes containing arbitrary text, and what to do with text nodes that represent preformatted text (from verbatim sections). @@ -272,7 +272,7 @@ produces this event structure: crontab(5) </L> -In the rare cases where a man page link has a specified, that text appears +In the rare cases where a man page link has a section specified, that text appears in a I<section> attribute. For example, this Pod source: L<crontab(5)/"ENVIRONMENT"> @@ -461,7 +461,7 @@ will produce this event structure: et al. </head1> -"=head2" thru "=head4" directives are the same, except for the element +"=head2" through "=head4" directives are the same, except for the element names in the event structure. =item events with an element_name of encoding @@ -922,8 +922,8 @@ 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 +This notes a problem in the Pod, which will be reported in the "Pod +Errors" section of the document and/or sent to STDERR, depending on the values of the attributes C<no_whining>, C<no_errata_section>, and C<complain_stderr>. @@ -1021,7 +1021,7 @@ 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 +L<Pod::Escapes> -- the module that Pod::Simple uses for evaluating EE<lt>...E<gt> content L<Pod::Simple::Text> -- a simple plaintext formatter for Pod @@ -1044,8 +1044,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm index b3292f8c498..e1c2d0b21f0 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm @@ -6,7 +6,7 @@ use Carp (); use Pod::Simple::Methody (); use Pod::Simple (); use vars qw( @ISA $VERSION $FREAKYMODE); -$VERSION = '3.29'; +$VERSION = '3.32'; @ISA = ('Pod::Simple::Methody'); BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG @@ -81,9 +81,9 @@ sub emit_par { 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; + $self->{'Thispara'} =~ s/$Pod::Simple::shy//g; my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n"); - $out =~ tr{\xA0}{ } if Pod::Simple::ASCII; + $out =~ s/$Pod::Simple::nbsp/ /g; print {$self->{'output_fh'}} $out, "\n"; $self->{'Thispara'} = ''; @@ -94,10 +94,8 @@ sub emit_par { sub end_Verbatim { my $self = shift; - if(Pod::Simple::ASCII) { - $self->{'Thispara'} =~ tr{\xA0}{ }; - $self->{'Thispara'} =~ tr{\xAD}{}d; - } + $self->{'Thispara'} =~ s/$Pod::Simple::nbsp/ /g; + $self->{'Thispara'} =~ s/$Pod::Simple::shy//g; my $i = ' ' x ( 2 * $self->{'Indent'} + 4); #my $i = ' ' x (4 + $self->{'Indent'}); @@ -149,8 +147,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm index 516f28cb223..e0db26defb4 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm @@ -6,7 +6,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( @ISA $VERSION ); -$VERSION = '3.29'; +$VERSION = '3.32'; @ISA = ('Pod::Simple'); sub new { @@ -25,10 +25,8 @@ sub _handle_element_start { } sub _handle_text { - if( chr(65) eq 'A' ) { # in ASCIIworld - $_[1] =~ tr/\xAD//d; - $_[1] =~ tr/\xA0/ /; - } + $_[1] =~ s/$Pod::Simple::shy//g; + $_[1] =~ s/$Pod::Simple::nbsp/ /g; print {$_[0]{'output_fh'}} $_[1]; return; } @@ -75,8 +73,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm index dbf5210388e..6abba4defab 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm @@ -4,7 +4,7 @@ package Pod::Simple::TiedOutFH; use Symbol ('gensym'); use Carp (); use vars qw($VERSION ); -$VERSION = '3.29'; +$VERSION = '3.32'; #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -20,7 +20,7 @@ sub handle_on { # some horrible frightening things are encapsulated in here ; $$x = '' unless defined $$x; - #Pod::Simple::DEBUG and print "New $class handle on $x = \"$$x\"\n"; + #Pod::Simple::DEBUG and print STDERR "New $class handle on $x = \"$$x\"\n"; my $new = gensym(); tie *$new, $class, $x; @@ -39,7 +39,7 @@ sub PRINT { my $it = shift; foreach my $x (@_) { $$$it .= $x } - #Pod::Simple::DEBUG > 10 and print " appended to $$it = \"$$$it\"\n"; + #Pod::Simple::DEBUG > 10 and print STDERR " appended to $$it = \"$$$it\"\n"; return 1; } diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm index 9c60f05d021..ae9298ef311 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm @@ -1,8 +1,9 @@ require 5; package Pod::Simple::Transcode; -use vars qw($VERSION ); -$VERSION = '3.29'; +use strict; +use vars qw($VERSION @ISA); +$VERSION = '3.32'; BEGIN { if(defined &DEBUG) {;} # Okay @@ -16,12 +17,12 @@ foreach my $class ( '', ) { $class or die "Couldn't load any encoding classes"; - DEBUG and print "About to try loading $class...\n"; + DEBUG and print STDERR "About to try loading $class...\n"; eval "require $class;"; if($@) { - DEBUG and print "Couldn't load $class: $@\n"; + DEBUG and print STDERR "Couldn't load $class: $@\n"; } else { - DEBUG and print "OK, loaded $class.\n"; + DEBUG and print STDERR "OK, loaded $class.\n"; @ISA = ($class); last; } diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm index badb9a0d439..80b828a753f 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm @@ -5,7 +5,7 @@ require 5; package Pod::Simple::TranscodeDumb; use strict; use vars qw($VERSION %Supported); -$VERSION = '3.29'; +$VERSION = '3.32'; # This module basically pretends it knows how to transcode, except # only for null-transcodings! We use this when Encode isn't # available. @@ -14,6 +14,7 @@ $VERSION = '3.29'; 'ascii' => 1, 'ascii-ctrl' => 1, 'iso-8859-1' => 1, + 'cp1252' => 1, 'null' => 1, 'latin1' => 1, 'latin-1' => 1, @@ -36,24 +37,46 @@ sub encmodver { } 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; + my ($e) = $_[1]; + die "WHAT ENCODING!?!?" unless $e; + # No-op for all but CP1252. + return sub {;} if $e !~ /^cp-?1252$/i; + + # Replace CP1252 nerbles with their ASCII equivalents. + return sub { + # Copied from Encode::ZapCP1252. + my %ascii_for = ( + # http://en.wikipedia.org/wiki/Windows-1252 + "\x80" => 'e', # EURO SIGN + "\x82" => ',', # SINGLE LOW-9 QUOTATION MARK + "\x83" => 'f', # LATIN SMALL LETTER F WITH HOOK + "\x84" => ',,', # DOUBLE LOW-9 QUOTATION MARK + "\x85" => '...', # HORIZONTAL ELLIPSIS + "\x86" => '+', # DAGGER + "\x87" => '++', # DOUBLE DAGGER + "\x88" => '^', # MODIFIER LETTER CIRCUMFLEX ACCENT + "\x89" => '%', # PER MILLE SIGN + "\x8a" => 'S', # LATIN CAPITAL LETTER S WITH CARON + "\x8b" => '<', # SINGLE LEFT-POINTING ANGLE QUOTATION MARK + "\x8c" => 'OE', # LATIN CAPITAL LIGATURE OE + "\x8e" => 'Z', # LATIN CAPITAL LETTER Z WITH CARON + "\x91" => "'", # LEFT SINGLE QUOTATION MARK + "\x92" => "'", # RIGHT SINGLE QUOTATION MARK + "\x93" => '"', # LEFT DOUBLE QUOTATION MARK + "\x94" => '"', # RIGHT DOUBLE QUOTATION MARK + "\x95" => '*', # BULLET + "\x96" => '-', # EN DASH + "\x97" => '--', # EM DASH + "\x98" => '~', # SMALL TILDE + "\x99" => '(tm)', # TRADE MARK SIGN + "\x9a" => 's', # LATIN SMALL LETTER S WITH CARON + "\x9b" => '>', # SINGLE RIGHT-POINTING ANGLE QUOTATION MARK + "\x9c" => 'oe', # LATIN SMALL LIGATURE OE + "\x9e" => 'z', # LATIN SMALL LETTER Z WITH CARON + "\x9f" => 'Y', # LATIN CAPITAL LETTER Y WITH DIAERESIS + ); + + s{([\x80-\x9f])}{$ascii_for{$1} || $1}emxsg for @_; }; } diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm index 6735b9979b3..335654998ec 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm @@ -9,7 +9,7 @@ use strict; use Pod::Simple; require Encode; use vars qw($VERSION ); -$VERSION = '3.29'; +$VERSION = '3.32'; sub is_dumb {0} sub is_smart {1} diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm index 3a2d2094c68..67b259cb98f 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm @@ -38,14 +38,14 @@ you can prevent high-bit characters from being encoded as HTML entities and declare the output character set as UTF-8 before parsing, like so: $psx->html_charset('UTF-8'); - $psx->html_encode_chars('&<>">'); + $psx->html_encode_chars(q{&<>'"}); =cut package Pod::Simple::XHTML; use strict; use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES ); -$VERSION = '3.29'; +$VERSION = '3.32'; use Pod::Simple::Methody (); @ISA = ('Pod::Simple::Methody'); @@ -832,8 +832,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm index a0f50a20fb2..03f2930e967 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm @@ -5,7 +5,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); -$VERSION = '3.29'; +$VERSION = '3.32'; BEGIN { @ISA = ('Pod::Simple'); *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; @@ -31,7 +31,7 @@ sub _handle_element_start { # ($self, $element_name, $attr_hash_r) my $fh = $_[0]{'output_fh'}; my($key, $value); - DEBUG and print "++ $_[1]\n"; + DEBUG and print STDERR "++ $_[1]\n"; print $fh "<", $_[1]; if($SORT_ATTRS) { foreach my $key (sort keys %{$_[2]}) { @@ -55,7 +55,7 @@ sub _handle_element_start { } sub _handle_text { - DEBUG and print "== \"$_[1]\"\n"; + DEBUG and print STDERR "== \"$_[1]\"\n"; if(length $_[1]) { my $text = $_[1]; _xml_escape($text); @@ -65,7 +65,7 @@ sub _handle_text { } sub _handle_element_end { - DEBUG and print "-- $_[1]\n"; + DEBUG and print STDERR "-- $_[1]\n"; print {$_[0]{'output_fh'}} "</", $_[1], ">"; return; } @@ -76,11 +76,13 @@ sub _handle_element_end { sub _xml_escape { foreach my $x (@_) { # Escape things very cautiously: - $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(ord($1)).';'/eg; + if ($] ge 5.007_003) { + $x =~ s/([^-\n\t !\#\$\%\(\)\*\+,\.\~\/\:\;=\?\@\[\\\]\^_\`\{\|\}abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789])/'&#'.(utf8::native_to_unicode(ord($1))).';'/eg; + } else { # Is broken for non-ASCII platforms on early perls + $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; } @@ -136,8 +138,8 @@ pod-people@perl.org mail list. Send an empty email to pod-people-subscribe@perl.org to subscribe. This module is managed in an open GitHub repository, -L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or -to clone L<git://github.com/theory/pod-simple.git> and send patches! +L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! Patches against Pod::Simple are welcome. Please send bug reports to <bug-pod-simple@rt.cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/Text.pm b/Master/tlpkg/tlperl/lib/Pod/Text.pm index 87f9e816d00..e141da2fd6d 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Text.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Text.pm @@ -1,4 +1,4 @@ -# Pod::Text -- Convert POD data to formatted ASCII text. +# Pod::Text -- Convert POD data to formatted text. # # This module converts POD to formatted text. It replaces the old Pod::Text # module that came with versions of Perl prior to 5.6.0 and attempts to match @@ -11,8 +11,8 @@ # me any patches at the address above in addition to sending them to the # standard Perl mailing lists. # -# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009, 2012, 2013 -# Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009, 2012, 2013, 2014, +# 2015 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -23,9 +23,10 @@ package Pod::Text; -require 5.004; - +use 5.006; use strict; +use warnings; + use vars qw(@ISA @EXPORT %ESCAPES $VERSION); use Carp qw(carp croak); @@ -38,7 +39,7 @@ use Pod::Simple (); # We have to export pod2text for backward compatibility. @EXPORT = qw(pod2text); -$VERSION = '3.18'; +$VERSION = '4.07'; ############################################################################## # Initialization @@ -126,10 +127,10 @@ sub new { $$self{LQUOTE} = $$self{RQUOTE} = ''; } elsif (length ($$self{opt_quotes}) == 1) { $$self{LQUOTE} = $$self{RQUOTE} = $$self{opt_quotes}; - } elsif ($$self{opt_quotes} =~ /^(.)(.)$/ - || $$self{opt_quotes} =~ /^(..)(..)$/) { - $$self{LQUOTE} = $1; - $$self{RQUOTE} = $2; + } elsif (length ($$self{opt_quotes}) % 2 == 0) { + my $length = length ($$self{opt_quotes}) / 2; + $$self{LQUOTE} = substr ($$self{opt_quotes}, 0, $length); + $$self{RQUOTE} = substr ($$self{opt_quotes}, $length); } else { croak qq(Invalid quote specification "$$self{opt_quotes}"); } @@ -273,12 +274,12 @@ sub output { my ($self, @text) = @_; my $text = join ('', @text); $text =~ tr/\240\255/ /d; - unless ($$self{opt_utf8} || $$self{CHECKED_ENCODING}) { + unless ($$self{opt_utf8}) { my $encoding = $$self{encoding} || ''; - if ($encoding) { + if ($encoding && $encoding ne $$self{ENCODING}) { + $$self{ENCODING} = $encoding; eval { binmode ($$self{output_fh}, ":encoding($encoding)") }; } - $$self{CHECKED_ENCODING} = 1; } if ($$self{ENCODE}) { print { $$self{output_fh} } encode ('UTF-8', $text); @@ -312,7 +313,7 @@ sub start_document { $$self{PENDING} = [[]]; # Pending output. # We have to redo encoding handling for each document. - delete $$self{CHECKED_ENCODING}; + $$self{ENCODING} = ''; # When UTF-8 output is set, check whether our output file handle already # has a PerlIO encoding layer set. If it does not, we'll need to encode @@ -326,6 +327,7 @@ sub start_document { my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1]; if ($flag & PerlIO::F_UTF8 ()) { $$self{ENCODE} = 0; + $$self{ENCODING} = 'UTF-8'; } }; } @@ -759,7 +761,7 @@ parsers =head1 NAME -Pod::Text - Convert POD data to formatted ASCII text +Pod::Text - Convert POD data to formatted text =head1 SYNOPSIS @@ -774,10 +776,10 @@ Pod::Text - Convert POD data to formatted ASCII text =head1 DESCRIPTION -Pod::Text is a module that can convert documentation in the POD format (the -preferred language for documenting Perl) into formatted ASCII. It uses no -special formatting controls or codes whatsoever, and its output is therefore -suitable for nearly any device. +Pod::Text is a module that can convert documentation in the POD format +(the preferred language for documenting Perl) into formatted text. It +uses no special formatting controls or codes whatsoever, and its output is +therefore suitable for nearly any device. As a derived class from Pod::Simple, Pod::Text supports the same methods and interfaces. See L<Pod::Simple> for all the details; briefly, one creates a @@ -850,10 +852,9 @@ important. =item quotes Sets the quote marks used to surround CE<lt>> text. If the value is a -single character, it is used as both the left and right quote; if it is two -characters, the first character is used as the left quote and the second as -the right quoted; and if it is four characters, the first two are used as -the left quote and the second two as the right quote. +single character, it is used as both the left and right quote. Otherwise, +it is split in half, and the first half of the string is used as the left +quote and the second is used as the right quote. This may also be set to the special value C<none>, in which case no quote marks are added around CE<lt>> text. @@ -880,10 +881,10 @@ doesn't encode its output). If this option is given, the output encoding is forced to UTF-8. Be aware that, when using this option, the input encoding of your POD -source must be properly declared unless it is US-ASCII or Latin-1. POD -input without an C<=encoding> command will be assumed to be in Latin-1, -and if it's actually in UTF-8, the output will be double-encoded. See -L<perlpod(1)> for more information on the C<=encoding> command. +source should be properly declared unless it's US-ASCII. Pod::Simple will +attempt to guess the encoding and may be successful if it's Latin-1 or +UTF-8, but it will produce warnings. Use the C<=encoding> command to +declare the encoding. See L<perlpod(1)> for more information. =item width @@ -933,8 +934,8 @@ and the input file it was given could not be opened. =item Invalid quote specification "%s" (F) The quote specification given (the C<quotes> option to the -constructor) was invalid. A quote specification must be one, two, or four -characters long. +constructor) was invalid. A quote specification must be either one +character long or an even number (greater than one) characters long. =item POD document had syntax errors @@ -989,7 +990,7 @@ Perl core distribution as of 5.6.0. =head1 AUTHOR -Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original +Russ Allbery <rra@cpan.org>, based I<very> heavily on the original Pod::Text by Tom Christiansen <tchrist@mox.perl.com> and its conversion to Pod::Parser by Brad Appleton <bradapp@enteract.com>. Sean Burke's initial conversion of Pod::Man to use Pod::Simple provided much-needed guidance on @@ -997,8 +998,8 @@ how to use Pod::Simple. =head1 COPYRIGHT AND LICENSE -Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009, 2012, 2013 Russ -Allbery <rra@stanford.edu>. +Copyright 1999, 2000, 2001, 2002, 2004, 2006, 2008, 2009, 2012, 2013, 2014, +2015 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm index a114ed937f0..b67742e32c3 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm @@ -4,7 +4,8 @@ # better use of color, take options changing what colors are used for what # text, and the like. # -# Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2001, 2004, 2006, 2008, 2009, 2014 +# Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -15,17 +16,18 @@ package Pod::Text::Color; -require 5.004; +use 5.006; +use strict; +use warnings; use Pod::Text (); use Term::ANSIColor qw(colored); -use strict; use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); -$VERSION = '2.07'; +$VERSION = '4.07'; ############################################################################## # Overrides @@ -143,11 +145,11 @@ Perl core distribution as of 5.6.0. =head1 AUTHOR -Russ Allbery <rra@stanford.edu>. +Russ Allbery <rra@cpan.org>. =head1 COPYRIGHT AND LICENSE -Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@stanford.edu>. +Copyright 1999, 2001, 2004, 2006, 2008, 2009 Russ Allbery <rra@cpan.org>. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm index f5dce0230f8..1592026e9f7 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm @@ -12,9 +12,9 @@ # independent. # # Created by Joe Smith <Joe.Smith@inwap.com> 30-Nov-2000 -# (based on Pod::Text::Color by Russ Allbery <rra@stanford.edu>) +# (based on Pod::Text::Color by Russ Allbery <rra@cpan.org>) # Copyright 2000 Joe Smith <Joe.Smith@inwap.com>. -# Copyright 2001, 2004, 2008 Russ Allbery <rra@stanford.edu>. +# Copyright 2001, 2004, 2008, 2014 Russ Allbery <rra@cpan.org>. # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -25,16 +25,17 @@ package Pod::Text::Overstrike; -require 5.004; - -use Pod::Text (); - +use 5.006; use strict; +use warnings; + use vars qw(@ISA $VERSION); +use Pod::Text (); + @ISA = qw(Pod::Text); -$VERSION = '2.05'; +$VERSION = '4.07'; ############################################################################## # Overrides @@ -195,12 +196,12 @@ Perl core distribution as of 5.6.0. =head1 AUTHOR Joe Smith <Joe.Smith@inwap.com>, using the framework created by Russ Allbery -<rra@stanford.edu>. +<rra@cpan.org>. =head1 COPYRIGHT AND LICENSE Copyright 2000 by Joe Smith <Joe.Smith@inwap.com>. -Copyright 2001, 2004, 2008 by Russ Allbery <rra@stanford.edu>. +Copyright 2001, 2004, 2008 by Russ Allbery <rra@cpan.org>. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm index 18ba7b20ff5..d533e76ddde 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm @@ -4,8 +4,8 @@ # output the right termcap escape sequences for formatted text on the current # terminal type. # -# Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009 -# Russ Allbery <rra@stanford.edu> +# Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009, 2014, 2015 +# Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. @@ -16,18 +16,19 @@ package Pod::Text::Termcap; -require 5.004; +use 5.006; +use strict; +use warnings; use Pod::Text (); use POSIX (); use Term::Cap; -use strict; use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); -$VERSION = '2.08'; +$VERSION = '4.07'; ############################################################################## # Overrides @@ -42,9 +43,11 @@ sub new { # $ENV{HOME} is usually not set on Windows. The default Term::Cap path # may not work on Solaris. - my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : ''; - $ENV{TERMPATH} = $home . '/etc/termcap:/usr/share/misc/termcap' - . ':/usr/share/lib/termcap'; + unless (exists $ENV{TERMPATH}) { + my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : ''; + $ENV{TERMPATH} = + "${home}/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap"; + } # Fall back on a hard-coded terminal speed if POSIX::Termios isn't # available (such as on VMS). @@ -144,7 +147,7 @@ __END__ Pod::Text::Termcap - Convert POD data to ASCII text with format escapes =for stopwords -ECMA-48 VT100 Allbery +ECMA-48 VT100 Allbery Solaris TERMPATH =head1 SYNOPSIS @@ -164,6 +167,18 @@ text using the correct termcap escape sequences for the current terminal. Apart from the format codes, it in all ways functions like Pod::Text. See L<Pod::Text> for details and available options. +=head1 ENVIRONMENT + +This module sets the TERMPATH environment variable globally to: + + $HOME/.termcap:/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap + +if it isn't already set. (The first entry is omitted if the HOME +environment variable isn't set.) This is a (very old) workaround for +problems finding termcap information on older versions of Solaris, and is +not good module behavior. Please do not rely on this behavior; it may be +dropped in a future release. + =head1 NOTES This module uses Term::Cap to retrieve the formatting escape sequences for @@ -182,12 +197,12 @@ Perl core distribution as of 5.6.0. =head1 AUTHOR -Russ Allbery <rra@stanford.edu>. +Russ Allbery <rra@cpan.org>. =head1 COPYRIGHT AND LICENSE -Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009 Russ Allbery -<rra@stanford.edu>. +Copyright 1999, 2001, 2002, 2004, 2006, 2008, 2009, 2014, 2015 Russ Allbery +<rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/Pod/Usage.pm b/Master/tlpkg/tlperl/lib/Pod/Usage.pm index bb8e60f05b0..cc4f2e1e4fd 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Usage.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Usage.pm @@ -1,8 +1,9 @@ ############################################################################# # Pod/Usage.pm -- print usage messages for the running script. # -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; +# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved. +# Copyright (c) 2001-2016 by Marek Rouchal. +# This file is part of "Pod-Usage". Pod-Usage is free software; # you can redistribute it and/or modify it under the same terms # as Perl itself. ############################################################################# @@ -11,7 +12,7 @@ package Pod::Usage; use strict; use vars qw($VERSION @ISA @EXPORT); -$VERSION = '1.64'; ## Current version of this package +$VERSION = '1.68'; ## Current version of this package require 5.006; ## requires this Perl version or later #use diagnostics; @@ -128,7 +129,8 @@ sub pod2usage { } ## Check for perldoc - my $progpath = File::Spec->catfile($Config{scriptdirexp} + my $progpath = $opts{'-perldoc'} ? $opts{'-perldoc'} : + File::Spec->catfile($Config{scriptdirexp} || $Config{scriptdir}, 'perldoc'); my $version = sprintf("%vd",$^V); @@ -148,7 +150,15 @@ sub pod2usage { if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) { # the perldocs back to 5.005 should all have -F # without -F there are warnings in -T scripts - system($progpath, '-F', $1); + my $f = $1; + my @perldoc_cmd = ($progpath); + if ($opts{'-perldocopt'}) { + $opts{'-perldocopt'} =~ s/^\s+|\s+$//g; + push @perldoc_cmd, split(/\s+/, $opts{'-perldocopt'}); + } + push @perldoc_cmd, ('-F', $f); + unshift @perldoc_cmd, $opts{'-perlcmd'} if $opts{'-perlcmd'}; + system(@perldoc_cmd); if($?) { # RT16091: fall back to more if perldoc failed system(($Config{pager} || $ENV{PAGER} || '/bin/more'), $1); @@ -263,10 +273,13 @@ sub select { # Override Pod::Text->seq_i to return just "arg", not "*arg*". sub seq_i { return $_[1] } +# Override Pod::Text->cmd_i to return just "arg", not "*arg*". +# newer version based on Pod::Simple +sub cmd_i { return $_[2] } # This overrides the Pod::Text method to do something very akin to what # Pod::Select did as well as the work done below by preprocess_paragraph. -# Note that the below is very, very specific to Pod::Text. +# Note that the below is very, very specific to Pod::Text and Pod::Simple. sub _handle_element_end { my ($self, $element) = @_; if ($element eq 'head1') { @@ -278,6 +291,8 @@ sub _handle_element_end { my $idx = $1 - 1; $self->{USAGE_HEADINGS} = [] unless($self->{USAGE_HEADINGS}); $self->{USAGE_HEADINGS}->[$idx] = $$self{PENDING}[-1][1]; + # we have to get rid of the lower headings + splice(@{$self->{USAGE_HEADINGS}},$idx+1); } if ($element =~ /^head\d+$/) { $$self{USAGE_SKIPPING} = 1; @@ -312,7 +327,7 @@ sub _handle_element_end { $$self{PENDING}[-1][1] = $_; } } - if ($$self{USAGE_SKIPPING} && $element !~ m/^over-/) { + if ($$self{USAGE_SKIPPING} && $element !~ m/^over-|^[BCFILSZ]$/) { pop @{ $$self{PENDING} }; } else { $self->SUPER::_handle_element_end($element); @@ -383,10 +398,15 @@ Pod::Usage - print a usage message from embedded pod documentation pod2usage( -msg => $message_text , -exitval => $exit_status , -verbose => $verbose_level, - -output => $filehandle ); + -output => $filehandle ); pod2usage( -verbose => 2, - -noperldoc => 1 ) + -noperldoc => 1 ); + + pod2usage( -verbose => 2, + -perlcmd => $path_to_perl, + -perldoc => $path_to_perldoc, + -perldocopt => $perldoc_options ); =head1 ARGUMENTS @@ -418,49 +438,73 @@ keys: =over 4 -=item C<-message> +=item C<-message> I<string> -=item C<-msg> +=item C<-msg> I<string> The text of a message to print immediately prior to printing the program's usage message. -=item C<-exitval> +=item C<-exitval> I<value> The desired exit status to pass to the B<exit()> function. This should be an integer, or else the string "NOEXIT" to indicate that control should simply be returned without terminating the invoking process. -=item C<-verbose> +=item C<-verbose> I<value> -The desired level of "verboseness" to use when printing the usage -message. If the corresponding value is 0, then only the "SYNOPSIS" -section of the pod documentation is printed. If the corresponding value -is 1, then the "SYNOPSIS" section, along with any section entitled -"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the -corresponding value is 2 or more then the entire manpage is printed. +The desired level of "verboseness" to use when printing the usage message. +If the value is 0, then only the "SYNOPSIS" section of the pod documentation +is printed. If the value is 1, then the "SYNOPSIS" section, along with any +section entitled "OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is +printed. If the corresponding value is 2 or more then the entire manpage is +printed, using L<perldoc> if available; otherwise L<Pod::Text> is used for +the formatting. For better readability, the all-capital headings are +downcased, e.g. C<SYNOPSIS> =E<gt> C<Synopsis>. The special verbosity level 99 requires to also specify the -sections parameter; then these sections are extracted and printed. -=item C<-sections> +=item C<-sections> I<spec> + +There are two ways to specify the selection. Either a string (scalar) +representing a selection regexp for sections to be printed when -verbose +is set to 99, e.g. + + "NAME|SYNOPSIS|DESCRIPTION|VERSION" + +With the above regexp all content following (and including) any of the +given C<=head1> headings will be shown. It is possible to restrict the +output to particular subsections only, e.g.: -A string representing a selection list for sections to be printed -when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">. + "DESCRIPTION/Algorithm" + +This will output only the C<=head2 Algorithm> heading and content within +the C<=head1 DESCRIPTION> section. The regexp binding is stronger than the +section separator, such that e.g.: + + "DESCRIPTION|OPTIONS|ENVIORNMENT/Caveats" + +will print any C<=head2 Caveats> section (only) within any of the three +C<=head1> sections. Alternatively, an array reference of section specifications can be used: - pod2usage(-verbose => 99, - -sections => [ qw(fred fred/subsection) ] ); + pod2usage(-verbose => 99, -sections => [ + qw(DESCRIPTION DESCRIPTION/Introduction) ] ); + +This will print only the content of C<=head1 DESCRIPTION> and the +C<=head2 Introduction> sections, but no other C<=head2>, and no other +C<=head1> either. -=item C<-output> +=item C<-output> I<handle> A reference to a filehandle, or the pathname of a file to which the usage message should be written. The default is C<\*STDERR> unless the exit value is less than 2 (in which case the default is C<\*STDOUT>). -=item C<-input> +=item C<-input> I<handle> A reference to a filehandle, or the pathname of a file from which the invoking script's pod documentation should be read. It defaults to the @@ -472,7 +516,7 @@ that module's POD, you can use this: use Pod::Find qw(pod_where); pod2usage( -input => pod_where({-inc => 1}, __PACKAGE__) ); -=item C<-pathlist> +=item C<-pathlist> I<string> A list of directory paths. If the input file does not exist, then it will be searched for in the given directory list (in the order the @@ -490,17 +534,43 @@ with L<PAR>. The -noperldoc option suppresses the external call to L<perldoc> and uses the simple text formatter (L<Pod::Text>) to output the POD. +=item C<-perlcmd> + +By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is +specified. In case of special or unusual Perl installations, +the -perlcmd option may be used to supply the path to a L<perl> executable +which should run L<perldoc>. + +=item C<-perldoc> I<path-to-perldoc> + +By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is +specified. In case L<perldoc> is not installed where the L<perl> interpreter +thinks it is (see L<Config>), the -perldoc option may be used to supply +the correct path to L<perldoc>. + +=item C<-perldocopt> I<string> + +By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is specified. +The -perldocopt option may be used to supply options to L<perldoc>. The +string may contain several, space-separated options. + =back =head2 Formatting base class -The default text formatter is L<Pod::Text>. The base class for Pod::Usage can +The default text formatter is L<Pod::Text>. The base class for Pod::Usage can be defined by pre-setting C<$Pod::Usage::Formatter> I<before> loading Pod::Usage, e.g.: BEGIN { $Pod::Usage::Formatter = 'Pod::Text::Termcap'; } use Pod::Usage qw(pod2usage); +Pod::Usage uses L<Pod::Simple>'s _handle_element_end() method to implement +the section selection, and in case of verbosity < 2 it down-cases the +all-caps headings to first capital letter and rest lowercase, and adds +a colon/newline at the end of the headings, for better readability. Same for +verbosity = 99. + =head2 Pass-through options The following options are passed through to the underlying text formatter. |