summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Pod
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2012-11-20 18:08:54 +0000
committerKarl Berry <karl@freefriends.org>2012-11-20 18:08:54 +0000
commitc5add2ea5067382269ae6f19e345fda0b9a7bd21 (patch)
tree02f512fda46d93079c9dc59c0d76f0e398150f83 /Master/tlpkg/tlperl/lib/Pod
parent6c35e87bdc5a3f64833dbbc42e7d42e683db9d5b (diff)
perl 5.16.2, compiled without optimization for Windows (from siep)
git-svn-id: svn://tug.org/texlive/trunk@28315 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod')
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Checker.pm65
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Find.pm28
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Functions.pm213
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Html.pm2244
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/InputObjects.pm12
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/LaTeX.pm18
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Parser.pm15
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc.pm1100
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm79
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm63
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToANSI.pm96
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm11
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm595
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm18
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm31
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm25
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTerm.pm90
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm17
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm64
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm17
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/PlainText.pm14
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Select.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple.pm34
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple.pod127
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm89
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm9
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm6
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm16
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod157
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm68
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/Pod/Usage.pm23
53 files changed, 2534 insertions, 2868 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Checker.pm b/Master/tlpkg/tlperl/lib/Pod/Checker.pm
index a2305423b23..25dab197b04 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Checker.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Checker.pm
@@ -11,7 +11,7 @@ package Pod::Checker;
use strict;
use vars qw($VERSION @ISA @EXPORT %VALID_COMMANDS %VALID_SEQUENCES);
-$VERSION = '1.45'; ## Current version of this package
+$VERSION = '1.51'; ## Current version of this package
require 5.005; ## requires this Perl version or later
use Pod::ParseUtils; ## for hyperlinks and lists
@@ -140,6 +140,14 @@ a time.
There is no specification of the formatter after the C<=for> command.
+=item * Apparent command =foo not preceded by blank line
+
+A command which has ended up in the middle of a paragraph or other command,
+such as
+
+ =item one
+ =item two <-- bad
+
=item * unresolved internal link I<NAME>
The given link to I<NAME> does not have a matching node in the current
@@ -189,6 +197,14 @@ The index entry specified contains nothing but whitespace.
The commands C<=pod> and C<=cut> do not take any arguments.
+=item * Spurious =cut command
+
+A C<=cut> command was found without a preceding POD paragraph.
+
+=item * Spurious =pod command
+
+A C<=pod> command was found after a preceding POD paragraph.
+
=item * Spurious character(s) after =back
The C<=back> command does not take any arguments.
@@ -813,6 +829,8 @@ sub command {
else { # found a valid command
$self->{_commands}++; # delete this line if below is enabled again
+ $self->_commands_in_paragraphs($paragraph, $pod_para);
+
##### following check disabled due to strong request
#if(!$self->{_commands}++ && $cmd !~ /^head/) {
# $self->poderror({ -line => $line, -file => $file,
@@ -1022,6 +1040,16 @@ sub command {
-severity => 'ERROR',
-msg => "Spurious text after =$cmd"});
}
+ if($cmd eq 'cut' && (!$self->{_PREVIOUS} || $self->{_PREVIOUS} eq 'cut')) {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => "Spurious =cut command"});
+ }
+ if($cmd eq 'pod' && $self->{_PREVIOUS} && $self->{_PREVIOUS} ne 'cut') {
+ $self->poderror({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => "Spurious =pod command"});
+ }
}
$self->{_commands_in_head}++;
## Check the interior sequences in the command-text
@@ -1099,7 +1127,7 @@ sub _check_ptree {
$text .= $self->_check_ptree($contents, $line, $file, "$nestlist$cmd");
next;
}
- if($nestlist =~ /$cmd/) {
+ if(index($nestlist, $cmd) != -1) {
$self->poderror({ -line => $line, -file => $file,
-severity => 'WARNING',
-msg => "nested commands $cmd<...$cmd<...>...>"});
@@ -1209,6 +1237,7 @@ sub verbatim {
my ($self, $paragraph, $line_num, $pod_para) = @_;
$self->_preproc_par($paragraph);
+ $self->_commands_in_paragraphs($paragraph, $pod_para);
if($self->{_current_head1} eq 'NAME') {
my ($file, $line) = $pod_para->file_line;
@@ -1224,6 +1253,7 @@ sub textblock {
my ($file, $line) = $pod_para->file_line;
$self->_preproc_par($paragraph);
+ $self->_commands_in_paragraphs($paragraph, $pod_para);
# skip this paragraph if in a =begin block
unless($self->{_have_begin}) {
@@ -1250,6 +1280,35 @@ sub _preproc_par
}
}
+# look for =foo commands at the start of a line within a paragraph, as for
+# instance the following which prints as "* one =item two".
+#
+# =item one
+# =item two
+#
+# Examples of =foo written in docs are expected to be indented in a verbatim
+# or marked up C<=foo> so won't be caught. A double-angle C<< =foo >> could
+# have the =foo at the start of a line, but that should be unlikely and is
+# easily enough dealt with by not putting a newline after the C<<.
+#
+sub _commands_in_paragraphs {
+ my ($self, $str, $pod_para) = @_;
+ while ($str =~ /[^\n]\n=([a-z][a-z0-9]+)/sg) {
+ my $cmd = $1;
+ my $pos = pos($str);
+ if ($VALID_COMMANDS{$cmd}) {
+ my ($file, $line) = $pod_para->file_line;
+ my $part = substr($str, 0, $pos);
+ $line += ($part =~ tr/\n//); # count of newlines
+
+ $self->poderror
+ ({ -line => $line, -file => $file,
+ -severity => 'ERROR',
+ -msg => "Apparent command =$cmd not preceded by blank line"});
+ }
+ }
+}
+
1;
__END__
@@ -1264,5 +1323,7 @@ Marek Rouchal E<lt>marekr@cpan.orgE<gt>
Based on code for B<Pod::Text::pod2text()> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+B<Pod::Checker> is part of the L<Pod::Parser> distribution.
+
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Find.pm b/Master/tlpkg/tlperl/lib/Pod/Find.pm
index 8d1103b6a1f..028a405c79e 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Find.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Find.pm
@@ -14,7 +14,7 @@ package Pod::Find;
use strict;
use vars qw($VERSION);
-$VERSION = '1.35'; ## Current version of this package
+$VERSION = '1.51'; ## Current version of this package
require 5.005; ## requires this Perl version or later
use Carp;
@@ -60,7 +60,7 @@ files/directories like RCS, CVS, SCCS, .svn are ignored.
use Exporter;
use File::Spec;
use File::Find;
-use Cwd;
+use Cwd qw(abs_path cwd);
use vars qw(@ISA @EXPORT_OK $VERSION);
@ISA = qw(Exporter);
@@ -158,7 +158,13 @@ sub pod_find
}
push(@search, grep($_ ne File::Spec->curdir, @new_INC));
} else {
- push(@search, grep($_ ne File::Spec->curdir, @INC));
+ my %seen;
+ my $curdir = File::Spec->curdir;
+ foreach(@INC) {
+ next if $_ eq $curdir;
+ my $path = abs_path($_);
+ push(@search, $path) unless $seen{$path}++;
+ }
}
$opts{-perl} = 1;
@@ -198,8 +204,12 @@ sub pod_find
# simplify path
# on VMS canonpath will vmsify:[the.path], but File::Find::find
# wants /unixy/paths
- $try = File::Spec->canonpath($try) if ($^O ne 'VMS');
- $try = VMS::Filespec::unixify($try) if ($^O eq 'VMS');
+ if ($^O eq 'VMS') {
+ $try = VMS::Filespec::unixify($try);
+ }
+ else {
+ $try = File::Spec->canonpath($try);
+ }
my $name;
if(-f $try) {
if($name = _check_and_extract_name($try, $opts{-verbose})) {
@@ -208,6 +218,7 @@ sub pod_find
next;
}
my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!;
+ $root_rx=~ s|//$|/|; # remove trailing double slash
File::Find::find( sub {
my $item = $File::Find::name;
if(-d) {
@@ -268,8 +279,8 @@ sub _check_and_extract_name {
# TODO what happens on e.g. Win32?
my $name = $file;
if(defined $root_rx) {
- $name =~ s/$root_rx//s;
- $name =~ s/$SIMPLIFY_RX//s if(defined $SIMPLIFY_RX);
+ $name =~ s/$root_rx//is;
+ $name =~ s/$SIMPLIFY_RX//is if(defined $SIMPLIFY_RX);
}
else {
if ($^O eq 'MacOS') {
@@ -443,6 +454,7 @@ sub pod_where {
# Now concatenate this directory with the pod we are searching for
my $fullname = File::Spec->catfile($dir, @parts);
+ $fullname = VMS::Filespec::unixify($fullname) if $^O eq 'VMS';
warn "Filename is now $fullname\n"
if $options{'-verbose'};
@@ -525,6 +537,8 @@ heavily borrowing code from Nick Ing-Simmons' PodToHtml.
Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided
C<pod_where> and C<contains_pod>.
+B<Pod::Find> is part of the L<Pod::Parser> distribution.
+
=head1 SEE ALSO
L<Pod::Parser>, L<Pod::Checker>, L<perldoc>
diff --git a/Master/tlpkg/tlperl/lib/Pod/Functions.pm b/Master/tlpkg/tlperl/lib/Pod/Functions.pm
index 5181c3990bf..47b2bafc357 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Functions.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Functions.pm
@@ -52,84 +52,51 @@ L<perlfunc/"Perl Functions by Category"> section.
=back
-=head1 CHANGES
-
-1.02 20020813 <abe@ztreet.demon.nl>
- de-typo in the SYNOPSIS section (thanks Mike Castle for noticing)
-
-1.01 20011229 <abe@ztreet.demon.nl>
- fixed some bugs that slipped in after 5.6.1
- added the pod
- finished making it strict safe
-
-1.00 ??
- first numbered version
-
=cut
-our $VERSION = '1.04';
+our $VERSION = '1.05';
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
-our(%Kinds, %Type, %Flavor);
-
-our %Type_Description = (
- 'ARRAY' => 'Functions for real @ARRAYs',
- 'Binary' => 'Functions for fixed length data or records',
- 'File' => 'Functions for filehandles, files, or directories',
- 'Flow' => 'Keywords related to control flow of your perl program',
- 'HASH' => 'Functions for real %HASHes',
- 'I/O' => 'Input and output functions',
- 'LIST' => 'Functions for list data',
- 'Math' => 'Numeric functions',
- 'Misc' => 'Miscellaneous functions',
- 'Modules' => 'Keywords related to perl modules',
- 'Network' => 'Fetching network info',
- 'Objects' => 'Keywords related to classes and object-orientedness',
- 'Process' => 'Functions for processes and process groups',
- 'Regexp' => 'Regular expressions and pattern matching',
- 'Socket' => 'Low-level socket functions',
- 'String' => 'Functions for SCALARs or strings',
- 'SysV' => 'System V interprocess communication functions',
- 'Time' => 'Time-related functions',
- 'User' => 'Fetching user and group info',
- 'Namespace' => 'Keywords altering or affecting scoping of identifiers',
-);
-
-our @Type_Order = qw{
- String
- Regexp
- Math
- ARRAY
- LIST
- HASH
- I/O
- Binary
- File
- Flow
- Namespace
- Misc
- Process
- Modules
- Objects
- Socket
- SysV
- User
- Network
- Time
+our(%Kinds, %Type, %Flavor, %Type_Description, @Type_Order);
+
+foreach (
+ [String => 'Functions for SCALARs or strings'],
+ [Regexp => 'Regular expressions and pattern matching'],
+ [Math => 'Numeric functions'],
+ [ARRAY => 'Functions for real @ARRAYs'],
+ [LIST => 'Functions for list data'],
+ [HASH => 'Functions for real %HASHes'],
+ ['I/O' => 'Input and output functions'],
+ [Binary => 'Functions for fixed-length data or records'],
+ [File => 'Functions for filehandles, files, or directories'],
+ [Flow => 'Keywords related to the control flow of your Perl program'],
+ [Namespace => 'Keywords related to scoping'],
+ [Misc => 'Miscellaneous functions'],
+ [Process => 'Functions for processes and process groups'],
+ [Modules => 'Keywords related to Perl modules'],
+ [Objects => 'Keywords related to classes and object-orientation'],
+ [Socket => 'Low-level socket functions'],
+ [SysV => 'System V interprocess communication functions'],
+ [User => 'Fetching user and group info'],
+ [Network => 'Fetching network info'],
+ [Time => 'Time-related functions'],
+ ) {
+ push @Type_Order, $_->[0];
+ $Type_Description{$_->[0]} = $_->[1];
};
while (<DATA>) {
chomp;
- s/#.*//;
+ s/^#.*//;
next unless $_;
- my($name, $type, $text) = split " ", $_, 3;
- $Type{$name} = $type;
- $Flavor{$name} = $text;
- for my $t ( split /[,\s]+/, $type ) {
+ my($name, @data) = split "\t", $_;
+ $Flavor{$name} = pop @data;
+ $Type{$name} = join ',', @data;
+ for my $t (@data) {
push @{$Kinds{$t}}, $name;
}
}
@@ -161,33 +128,34 @@ __DATA__
-X File a file test (-r, -x, etc)
abs Math absolute value function
accept Socket accept an incoming socket connect
-alarm Process schedule a SIGALRM
+alarm Process schedule a SIGALRM
atan2 Math arctangent of Y/X in the range -PI to PI
bind Socket binds an address to a socket
binmode I/O prepare binary files for I/O
-bless Objects create an object
-caller Flow,Namespace get context of the current subroutine call
+bless Objects create an object
+break Flow break out of a C<given> block
+caller Flow Namespace get context of the current subroutine call
chdir File change your current working directory
chmod File changes the permissions on a list of files
-chomp String remove a trailing record separator from a string
-chop String remove the last character from a string
+chomp String remove a trailing record separator from a string
+chop String remove the last character from a string
chown File change the ownership on a list of files
-chr String get character this number represents
+chr String get character this number represents
chroot File make directory new root for path lookups
close I/O close file (or pipe or socket) handle
closedir I/O close directory handle
connect Socket connect to a remote socket
-continue Flow optional trailing block in a while or foreach
+continue Flow optional trailing block in a while or foreach
cos Math cosine function
crypt String one-way passwd-style encryption
-dbmclose Objects,I/O breaks binding on a tied dbm file
-dbmopen Objects,I/O create binding on a tied dbm file
+dbmclose Objects I/O breaks binding on a tied dbm file
+dbmopen Objects I/O create binding on a tied dbm file
defined Misc test whether a value, variable, or function is defined
delete HASH deletes a value from a hash
-die I/O,Flow raise an exception or bail out
-do Flow,Modules turn a BLOCK into a TERM
-dump Misc,Flow create an immediate core dump
-each HASH retrieve the next key/value pair from a hash
+die Flow I/O raise an exception or bail out
+do Modules Flow turn a BLOCK into a TERM
+dump Flow create an immediate core dump
+each HASH ARRAY retrieve the next key/value pair from a hash
endgrent User be done using group file
endhostent User be done using hosts file
endnetent User be done using networks file
@@ -195,28 +163,31 @@ endprotoent Network be done using protocols file
endpwent User be done using passwd file
endservent Network be done using services file
eof I/O test a filehandle for its end
-eval Flow,Misc catch exceptions or compile and run code
+eval Flow catch exceptions or compile and run code
+evalbytes Flow similar to string eval, but intend to parse a bytestream
exec Process abandon this program to run another
exists HASH test whether a hash key is present
exit Flow terminate this program
exp Math raise I<e> to a power
+fc String return casefolded version of a string
fcntl File file control system call
+__FILE__ Flow the name of the current source file
fileno I/O return file descriptor from filehandle
flock I/O lock an entire file with an advisory lock
fork Process create a new process just like this one
format I/O declare a picture format with use by the write() function
formline Misc internal function used for formats
-getc I/O get the next character from the filehandle
-getgrent User get next group record
+getc I/O get the next character from the filehandle
+getgrent User get next group record
getgrgid User get group record given group user ID
getgrnam User get group record given group name
gethostbyaddr Network get host record given its address
gethostbyname Network get host record given name
-gethostent Network get next hosts record
+gethostent Network get next hosts record
getlogin User return who logged in at this tty
getnetbyaddr Network get network record given its address
getnetbyname Network get networks record given name
-getnetent Network get next networks record
+getnetent Network get next networks record
getpeername Socket find the other end of a socket connection
getpgrp Process get process group
getppid Process get parent process ID
@@ -229,30 +200,31 @@ getpwnam User get passwd record given user login name
getpwuid User get passwd record given user ID
getservbyname Network get services record given its name
getservbyport Network get services record given numeric port
-getservent Network get next services record
+getservent Network get next services record
getsockname Socket retrieve the sockaddr for a given socket
getsockopt Socket get socket options on a given socket
-glob File expand filenames using wildcards
+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
-import Modules,Namespace patch a module's namespace into your own
+hex String Math convert a string to a hexadecimal 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
ioctl File system-dependent device control system call
join LIST join a list into a string using a separator
-keys HASH retrieve list of indices from a hash
+keys HASH ARRAY retrieve list of indices from a hash
kill Process send a signal to a process or process group
last Flow exit a block prematurely
lc String return lower-case version of a string
lcfirst String return a string with just the next letter in lower case
length String return the number of bytes in a string
+__LINE__ Flow the current source line number
link File create a hard link in the filesystem
-listen Socket register your socket as a server
-local Misc,Namespace create a temporary value for a global variable (dynamic scoping)
+listen Socket register your socket as a server
+local Namespace create a temporary value for a global variable (dynamic scoping)
localtime Time convert UNIX time into record or string using local time
-lock Threads get a thread lock on a variable, subroutine, or method
+lock Misc get a thread lock on a variable, subroutine, or method
log Math retrieve the natural logarithm for a number
lstat File stat a symbolic link
m// Regexp match a string with a regular expression pattern
@@ -262,31 +234,32 @@ msgctl SysV SysV IPC message control operations
msgget SysV get SysV IPC message queue
msgrcv SysV receive a SysV IPC message from a message queue
msgsnd SysV send a SysV IPC message to a message queue
-my Misc,Namespace declare and assign a local variable (lexical scoping)
+my Namespace declare and assign a local variable (lexical scoping)
next Flow iterate a block prematurely
no Modules unimport some module symbols or semantics at compile time
-package Modules,Objects,Namespace declare a separate global namespace
-prototype Flow,Misc get the prototype (if any) of a subroutine
-oct String,Math convert a string to an octal number
+oct String Math convert a string to an octal number
open File open a file, pipe, or descriptor
opendir File open a directory
ord String find a character's numeric representation
-our Misc,Namespace declare and assign a package variable (lexical scoping)
-pack Binary,String convert a list into a binary representation
+our Namespace declare and assign a package variable (lexical scoping)
+pack String Binary convert a list into a binary representation
+package Modules Objects Namespace declare a separate global namespace
+__PACKAGE__ Flow the current package
pipe Process open a pair of connected filehandles
pop ARRAY remove the last element from an array and return it
pos Regexp find or set the offset for the last/next m//g search
print I/O output a list to a filehandle
-printf I/O output a formatted list to a filehandle
+printf I/O output a formatted list to a filehandle
+prototype Misc get the prototype (if any) of a subroutine
push ARRAY append one or more elements to an array
q/STRING/ String singly quote a string
qq/STRING/ String doubly quote a string
+qr/STRING/ Regexp compile pattern
quotemeta Regexp quote regular expression magic characters
qw/STRING/ LIST quote a list of words
qx/STRING/ Process backquote quote a string
-qr/STRING/ Regexp Compile pattern
-rand Math retrieve the next pseudorandom number
-read I/O,Binary fixed-length buffered input from a filehandle
+rand Math retrieve the next pseudorandom number
+read Binary I/O fixed-length buffered input from a filehandle
readdir I/O get a directory from a directory handle
readline I/O fetch a record from a file
readlink File determine where a symbolic link is pointing
@@ -298,14 +271,15 @@ rename File change a filename
require Modules load in external functions from a library at runtime
reset Misc clear all variables of a given name
return Flow get out of a function early
-reverse String,LIST flip a string or a list
+reverse String LIST flip a string or a list
rewinddir I/O reset directory handle
rindex String right-to-left substring search
rmdir File remove a directory
s/// Regexp replace a pattern with a string
+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
+seekdir I/O reposition directory pointer
select I/O reset default output or do I/O multiplexing
semctl SysV SysV semaphore control operations
semget SysV get set of SysV semaphores
@@ -323,36 +297,38 @@ setsockopt Socket set some socket options
shift ARRAY remove the first element of an array, and return it
shmctl SysV SysV shared memory operations
shmget SysV get SysV shared memory segment identifier
-shmread SysV read SysV shared memory
-shmwrite SysV write SysV shared memory
+shmread SysV read SysV shared memory
+shmwrite SysV write SysV shared memory
shutdown Socket close down just half of a socket connection
sin Math return the sine of a number
sleep Process block for some number of seconds
socket Socket create a socket
socketpair Socket create a pair of sockets
-sort LIST sort a list of values
+sort LIST sort a list of values
splice ARRAY add or remove elements anywhere in an array
split Regexp split up a string using a regexp delimiter
-sprintf String formatted print into a string
+sprintf String formatted print into a string
sqrt Math square root function
srand Math seed the random number generator
stat File get a file's status information
+state Namespace declare and assign a persistent lexical variable
study Regexp optimize input data for repeated searches
sub Flow declare a subroutine, possibly anonymously
+__SUB__ Flow the current subroutine, or C<undef> if not in a subroutine
substr String get or alter a portion of a string
symlink File create a symbolic link to a file
-syscall I/O,Binary execute an arbitrary system call
+syscall Binary I/O execute an arbitrary system call
sysopen File open a file, pipe, or descriptor
-sysread I/O,Binary fixed-length unbuffered input from a filehandle
-sysseek I/O,Binary position I/O pointer on handle used with sysread and syswrite
-system Process run a separate program
-syswrite I/O,Binary fixed-length unbuffered output to a filehandle
+sysread Binary I/O fixed-length unbuffered input from a filehandle
+sysseek Binary I/O position I/O pointer on handle used with sysread and syswrite
+system Process run a separate program
+syswrite Binary I/O fixed-length unbuffered output to a filehandle
tell I/O get current seekpointer on a filehandle
telldir I/O get current seekpointer on a directory handle
-tie Objects bind a variable to an object class
+tie Objects bind a variable to an object class
tied Objects get a reference to the object underlying a tied variable
time Time return number of seconds since 1970
-times Process,Time return elapsed time for self and child processes
+times Time Process return elapsed time for self and child processes
tr/// String transliterate a string
truncate I/O shorten a file
uc String return upper-case version of a string
@@ -360,17 +336,16 @@ ucfirst String return a string with just the next letter in upper case
umask File set file creation mode mask
undef Misc remove a variable or function definition
unlink File remove one link to a file
-unpack Binary,LIST convert binary structure into normal perl variables
+unpack Binary LIST convert binary structure into normal perl variables
unshift ARRAY prepend more elements to the beginning of a list
untie Objects break a tie binding to a variable
-use Modules,Namespace load a module and import its namespace
-use Objects load in a module at compile time
+use Modules Objects Namespace load in a module at compile time and import its namespace
utime File set a file's last access and modify times
-values HASH return a list of the values in a hash
+values HASH ARRAY return a list of the values in a hash
vec Binary test or set particular bits in a string
wait Process wait for any child process to die
waitpid Process wait for a particular child process to die
-wantarray Misc,Flow get void vs scalar vs list context of current subroutine call
+wantarray Flow get void vs scalar vs list context of current subroutine call
warn I/O print debugging info
write I/O print a picture record
y/// String transliterate a string
diff --git a/Master/tlpkg/tlperl/lib/Pod/Html.pm b/Master/tlpkg/tlperl/lib/Pod/Html.pm
index 2c5c4414cf2..47b937abbb5 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.11;
+$VERSION = 1.15_02;
@ISA = qw(Exporter);
@EXPORT = qw(pod2html htmlify);
@EXPORT_OK = qw(anchorify);
@@ -11,11 +11,13 @@ $VERSION = 1.11;
use Carp;
use Config;
use Cwd;
+use File::Basename;
use File::Spec;
use File::Spec::Unix;
use Getopt::Long;
+use Pod::Simple::Search;
-use locale; # make \w work right in non-ASCII lands
+use locale; # make \w work right in non-ASCII lands
=head1 NAME
@@ -40,7 +42,6 @@ a cache of things it knows how to cross-reference.
"--podpath=lib:ext:pod:vms",
"--podroot=/usr/src/perl",
"--htmlroot=/perl/nmanual",
- "--libpods=perlfunc:perlguts:perlvar:perlrun:perlop",
"--recurse",
"--infile=foo.pod",
"--outfile=/perl/nmanual/foo.html");
@@ -51,16 +52,16 @@ pod2html takes the following arguments:
=item backlink
- --backlink="Back to Top"
+ --backlink
-Adds "Back to Top" links in front of every C<head1> heading (except for
-the first). By default, no backlinks are generated.
+Turns every C<head1> heading into a link back to the top of the page.
+By default, no backlinks are generated.
=item cachedir
--cachedir=name
-Creates the item and directory caches in the given directory.
+Creates the directory cache in the given directory.
=item css
@@ -73,7 +74,7 @@ C<style> attributes that are output by default (to avoid conflicts).
--flush
-Flushes the item and directory caches.
+Flushes the directory cache.
=item header
@@ -89,28 +90,17 @@ section. By default, no headers are generated.
Displays the usage message.
-=item hiddendirs
-
- --hiddendirs
- --nohiddendirs
-
-Include hidden directories in the search for POD's in podpath if recurse
-is set.
-The default is not to traverse any directory whose name begins with C<.>.
-See L</"podpath"> and L</"recurse">.
-
-[This option is for backward compatibility only.
-It's hard to imagine that one would usefully create a module with a
-name component beginning with C<.>.]
-
=item htmldir
--htmldir=name
-Sets the directory in which the resulting HTML file is placed. This
-is used to generate relative links to other files. Not passing this
-causes all links to be absolute, since this is the value that tells
-Pod::Html the root of the documentation tree.
+Sets the directory to which all cross references in the resulting
+html file will be relative. Not passing this causes all links to be
+absolute since this is the value that tells Pod::Html the root of the
+documentation tree.
+
+Do not use this and --htmlroot in the same call to pod2html; they are
+mutually exclusive.
=item htmlroot
@@ -119,6 +109,11 @@ Pod::Html the root of the documentation tree.
Sets the base URL for the HTML files. When cross-references are made,
the HTML root is prepended to the URL.
+Do not use this if relative links are desired: use --htmldir instead.
+
+Do not pass both this and --htmldir to pod2html; they are mutually
+exclusive.
+
=item index
--index
@@ -134,19 +129,6 @@ behaviour.
Specify the pod file to convert. Input is taken from STDIN if no
infile is specified.
-=item libpods
-
- --libpods=name:...:name
-
-List of page names (eg, "perlfunc") which contain linkable C<=item>s.
-
-=item netscape
-
- --netscape
- --nonetscape
-
-B<Deprecated>, has no effect. For backwards compatibility only.
-
=item outfile
--outfile=name
@@ -154,6 +136,14 @@ B<Deprecated>, has no effect. For backwards compatibility only.
Specify the HTML file to create. Output goes to STDOUT if no outfile
is specified.
+=item poderrors
+
+ --poderrors
+ --nopoderrors
+
+Include a "POD ERRORS" section in the outfile if there were any POD
+errors in the infile. This section is included by default.
+
=item podpath
--podpath=name:...:name
@@ -165,7 +155,8 @@ HTML converted forms can be linked to in cross references.
--podroot=name
-Specify the base directory for finding library pods.
+Specify the base directory for finding library pods. Default is the
+current working directory.
=item quiet
@@ -203,7 +194,7 @@ Display progress messages. By default, they won't be displayed.
htmlify($heading);
Converts a pod section specification to a suitable section specification
-for HTML. Note that we keep spaces and special characters except
+for HTML. Note that we keep spaces and special characters except
C<", ?> (Netscape problem) and the hyphen (writer's problem...).
=head2 anchorify
@@ -219,7 +210,9 @@ Uses C<$Config{pod2html}> to setup default options.
=head1 AUTHOR
-Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
+Marc Green, E<lt>marcgreen@cpan.orgE<gt>.
+
+Original version by Tom Christiansen, E<lt>tchrist@perl.comE<gt>.
=head1 SEE ALSO
@@ -231,258 +224,170 @@ This program is distributed under the Artistic License.
=cut
-my($Cachedir);
-my($Dircache, $Itemcache);
-my @Begin_Stack;
-my @Libpods;
+my $Cachedir;
+my $Dircache;
my($Htmlroot, $Htmldir, $Htmlfile, $Htmlfileurl);
my($Podfile, @Podpath, $Podroot);
+my $Poderrors;
my $Css;
my $Recurse;
my $Quiet;
-my $HiddenDirs;
my $Verbose;
my $Doindex;
my $Backlink;
-my($Listlevel, @Listtype);
-my $ListNewTerm;
-use vars qw($Ignore); # need to localize it later.
-my(%Items_Named, @Items_Seen);
my($Title, $Header);
-my $Top;
-my $Paragraph;
-
-my %Sections;
-
-# Caches
-my %Pages = (); # associative array used to find the location
- # of pages referenced by L<> links.
-my %Items = (); # associative array used to find the location
- # of =item directives referenced by C<> links
-
-my %Local_Items;
-my $Is83;
+my %Pages = (); # associative array used to find the location
+ # of pages referenced by L<> links.
my $Curdir = File::Spec->curdir;
init_globals();
sub init_globals {
- $Cachedir = "."; # The directory to which item and directory
- # caches will be written.
+ $Cachedir = "."; # The directory to which directory caches
+ # will be written.
$Dircache = "pod2htmd.tmp";
- $Itemcache = "pod2htmi.tmp";
-
- @Begin_Stack = (); # begin/end stack
-
- @Libpods = (); # files to search for links from C<> directives
- $Htmlroot = "/"; # http-server base directory from which all
- # relative paths in $podpath stem.
- $Htmldir = ""; # The directory to which the html pages
- # will (eventually) be written.
- $Htmlfile = ""; # write to stdout by default
- $Htmlfileurl = ""; # The url that other files would use to
- # refer to this file. This is only used
- # to make relative urls that point to
- # other files.
-
- $Podfile = ""; # read from stdin by default
- @Podpath = (); # list of directories containing library pods.
- $Podroot = $Curdir; # filesystem base directory from which all
- # relative paths in $podpath stem.
- $Css = ''; # Cascading style sheet
- $Recurse = 1; # recurse on subdirectories in $podpath.
- $Quiet = 0; # not quiet by default
- $Verbose = 0; # not verbose by default
- $Doindex = 1; # non-zero if we should generate an index
- $Backlink = ''; # text for "back to top" links
- $Listlevel = 0; # current list depth
- @Listtype = (); # list types for open lists
- $ListNewTerm = 0; # indicates new term in definition list; used
- # to correctly open/close <dd> tags
- $Ignore = 1; # whether or not to format text. we don't
- # format text until we hit our first pod
- # directive.
-
- @Items_Seen = (); # for multiples of the same item in perlfunc
- %Items_Named = ();
- $Header = 0; # produce block header/footer
- $Title = ''; # title to give the pod(s)
- $Top = 1; # true if we are at the top of the doc. used
- # to prevent the first <hr /> directive.
- $Paragraph = ''; # which paragraph we're processing (used
- # for error messages)
- %Sections = (); # sections within this page
-
- %Local_Items = ();
- $Is83 = $^O eq 'dos'; # Is it an 8.3 filesystem?
-}
-#
-# clean_data: global clean-up of pod data
-#
-sub clean_data($){
- my( $dataref ) = @_;
- for my $i ( 0..$#{$dataref} ) {
- ${$dataref}[$i] =~ s/\s+\Z//;
-
- # have a look for all-space lines
- if( ${$dataref}[$i] =~ /^\s+$/m and $dataref->[$i] !~ /^\s/ ){
- my @chunks = split( /^\s+$/m, ${$dataref}[$i] );
- splice( @$dataref, $i, 1, @chunks );
- }
- }
+ $Htmlroot = "/"; # http-server base directory from which all
+ # relative paths in $podpath stem.
+ $Htmldir = ""; # The directory to which the html pages
+ # will (eventually) be written.
+ $Htmlfile = ""; # write to stdout by default
+ $Htmlfileurl = ""; # The url that other files would use to
+ # refer to this file. This is only used
+ # to make relative urls that point to
+ # other files.
+
+ $Poderrors = 1;
+ $Podfile = ""; # read from stdin by default
+ @Podpath = (); # list of directories containing library pods.
+ $Podroot = $Curdir; # filesystem base directory from which all
+ # relative paths in $podpath stem.
+ $Css = ''; # Cascading style sheet
+ $Recurse = 1; # recurse on subdirectories in $podpath.
+ $Quiet = 0; # not quiet by default
+ $Verbose = 0; # not verbose by default
+ $Doindex = 1; # non-zero if we should generate an index
+ $Backlink = 0; # no backlinks added by default
+ $Header = 0; # produce block header/footer
+ $Title = ''; # title to give the pod(s)
}
-
sub pod2html {
local(@ARGV) = @_;
- local($/);
local $_;
init_globals();
-
- $Is83 = 0 if (defined (&Dos::UseLFN) && Dos::UseLFN());
-
- # cache of %Pages and %Items from last time we ran pod2html
-
- #undef $opt_help if defined $opt_help;
-
- # parse the command-line parameters
parse_command_line();
- # escape the backlink argument (same goes for title but is done later...)
- $Backlink = html_escape($Backlink) if defined $Backlink;
+ # prevent '//' in urls
+ $Htmlroot = "" if $Htmlroot eq "/";
+ $Htmldir =~ s#/\z##;
- # set some variables to their default values if necessary
- my $pod;
- unless (@ARGV && $ARGV[0]) {
- if ($Podfile and $Podfile ne '-') {
- open $pod, '<', $Podfile
- or die "$0: cannot open $Podfile file for input: $!\n";
- } else {
- open $pod, '-';
- }
- } else {
- $Podfile = $ARGV[0]; # XXX: might be more filenames
- $pod = *ARGV;
- }
- $Htmlfile = "-" unless $Htmlfile; # stdout
- $Htmlroot = "" if $Htmlroot eq "/"; # so we don't get a //
- $Htmldir =~ s#/\z## ; # so we don't get a //
if ( $Htmlroot eq ''
&& defined( $Htmldir )
&& $Htmldir ne ''
&& substr( $Htmlfile, 0, length( $Htmldir ) ) eq $Htmldir
- )
- {
- # Set the 'base' url for this file, so that we can use it
- # as the location from which to calculate relative links
- # to other files. If this is '', then absolute links will
- # be used throughout.
- $Htmlfileurl= "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
- }
-
- # read the pod a paragraph at a time
- warn "Scanning for sections in input file(s)\n" if $Verbose;
- $/ = "";
- my @poddata = <$pod>;
- close $pod;
-
- # be eol agnostic
- for (@poddata) {
- if (/\r/) {
- if (/\r\n/) {
- @poddata = map { s/\r\n/\n/g;
- /\n\n/ ?
- map { "$_\n\n" } split /\n\n/ :
- $_ } @poddata;
- } else {
- @poddata = map { s/\r/\n/g;
- /\n\n/ ?
- map { "$_\n\n" } split /\n\n/ :
- $_ } @poddata;
- }
- last;
- }
- }
-
- clean_data( \@poddata );
-
- # scan the pod for =head[1-6] directives and build an index
- my $index = scan_headings(\%Sections, @poddata);
-
- unless($index) {
- warn "No headings in $Podfile\n" if $Verbose;
- }
-
- # open the output file
- my $html;
- if($Htmlfile and $Htmlfile ne '-') {
- open $html, ">", $Htmlfile
- or die "$0: cannot open $Htmlfile file for output: $!\n";
- } else {
- open $html, ">-";
- }
+ ) {
+ # Set the 'base' url for this file, so that we can use it
+ # as the location from which to calculate relative links
+ # to other files. If this is '', then absolute links will
+ # be used throughout.
+ #$Htmlfileurl = "$Htmldir/" . substr( $Htmlfile, length( $Htmldir ) + 1);
+ # Is the above not just "$Htmlfileurl = $Htmlfile"?
+ $Htmlfileurl = Pod::Html::_unixify($Htmlfile);
+
+ }
+
+ # load or generate/cache %Pages
+ unless (get_cache($Dircache, \@Podpath, $Podroot, $Recurse)) {
+ # generate %Pages
+ my $pwd = getcwd();
+ chdir($Podroot) ||
+ die "$0: error changing to directory $Podroot: $!\n";
+
+ # find all pod modules/pages in podpath, store in %Pages
+ # - callback used to remove Podroot and extension from each file
+ # - laborious to allow '.' in dirnames (e.g., /usr/share/perl/5.14.1)
+ Pod::Simple::Search->new->inc(0)->verbose($Verbose)->laborious(1)
+ ->callback(\&_save_page)->recurse($Recurse)->survey(@Podpath);
+
+ chdir($pwd) || die "$0: error changing to directory $pwd: $!\n";
+
+ # cache the directory list for later use
+ warn "caching directories for later use\n" if $Verbose;
+ open my $cache, '>', $Dircache
+ or die "$0: error open $Dircache for writing: $!\n";
+
+ print $cache join(":", @Podpath) . "\n$Podroot\n";
+ my $_updirs_only = ($Podroot =~ /\.\./) && !($Podroot =~ /[^\.\\\/]/);
+ foreach my $key (keys %Pages) {
+ if($_updirs_only) {
+ my $_dirlevel = $Podroot;
+ while($_dirlevel =~ /\.\./) {
+ $_dirlevel =~ s/\.\.//;
+ # Assume $Pages{$key} has '/' separators (html dir separators).
+ $Pages{$key} =~ s/^[\w\s\-\.]+\///;
+ }
+ }
+ print $cache "$key $Pages{$key}\n";
+ }
- # put a title in the HTML file if one wasn't specified
- if ($Title eq '') {
- TITLE_SEARCH: {
- for (my $i = 0; $i < @poddata; $i++) {
- if ($poddata[$i] =~ /^=head1\s*NAME\b/m) {
- for my $para ( @poddata[$i, $i+1] ) {
- last TITLE_SEARCH
- if ($Title) = $para =~ /(\S+\s+-+.*\S)/s;
- }
- }
-
- }
- }
- }
- if (!$Title and $Podfile =~ /\.pod\z/) {
- # probably a split pod so take first =head[12] as title
- for (my $i = 0; $i < @poddata; $i++) {
- last if ($Title) = $poddata[$i] =~ /^=head[12]\s*(.*)/;
- }
- warn "adopted '$Title' as title for $Podfile\n"
- if $Verbose and $Title;
- }
- if ($Title) {
- $Title =~ s/\s*\(.*\)//;
- } else {
- warn "$0: no title for $Podfile.\n" unless $Quiet;
- $Podfile =~ /^(.*)(\.[^.\/]+)?\z/s;
- $Title = ($Podfile eq "-" ? 'No Title' : $1);
- warn "using $Title" if $Verbose;
- }
+ close $cache or die "error closing $Dircache: $!";
+ }
+
+ # set options for the parser
+ my $parser = Pod::Simple::XHTML::LocalPodLinks->new();
+ $parser->codes_in_verbatim(0);
+ $parser->anchor_items(1); # the old Pod::Html always did
+ $parser->backlink($Backlink); # linkify =head1 directives
+ $parser->htmldir($Htmldir);
+ $parser->htmlfileurl($Htmlfileurl);
+ $parser->htmlroot($Htmlroot);
+ $parser->index($Doindex);
+ $parser->no_errata_section(!$Poderrors); # note the inverse
+ $parser->output_string(\my $output); # written to file later
+ $parser->pages(\%Pages);
+ $parser->quiet($Quiet);
+ $parser->verbose($Verbose);
+
+ # XXX: implement default title generator in pod::simple::xhtml
+ # copy the way the old Pod::Html did it
$Title = html_escape($Title);
+ # We need to add this ourselves because we use our own header, not
+ # ::XHTML's header. We need to set $parser->backlink to linkify
+ # the =head1 directives
+ my $bodyid = $Backlink ? ' id="_podtop_"' : '';
+
my $csslink = '';
my $bodystyle = ' style="background-color: white"';
my $tdstyle = ' style="background-color: #cccccc"';
if ($Css) {
- $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />);
- $csslink =~ s,\\,/,g;
- $csslink =~ s,(/.):,$1|,;
- $bodystyle = '';
- $tdstyle = '';
+ $csslink = qq(\n<link rel="stylesheet" href="$Css" type="text/css" />);
+ $csslink =~ s,\\,/,g;
+ $csslink =~ s,(/.):,$1|,;
+ $bodystyle = '';
+ $tdstyle= '';
}
- my $block = $Header ? <<END_OF_BLOCK : '';
+ # header/footer block
+ my $block = $Header ? <<END_OF_BLOCK : '';
<table border="0" width="100%" cellspacing="0" cellpadding="3">
-<tr><td class="block"$tdstyle valign="middle">
-<big><strong><span class="block">&nbsp;$Title</span></strong></big>
+<tr><td class="_podblock_"$tdstyle valign="middle">
+<big><strong><span class="_podblock_">&nbsp;$Title</span></strong></big>
</td></tr>
</table>
END_OF_BLOCK
- print $html <<END_OF_HEAD;
+ # create own header/footer because of --header
+ $parser->html_header(<<"HTMLHEAD");
<?xml version="1.0" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
@@ -492,147 +397,44 @@ END_OF_BLOCK
<link rev="made" href="mailto:$Config{perladmin}" />
</head>
-<body$bodystyle>
+<body$bodyid$bodystyle>
$block
-END_OF_HEAD
-
- # load/reload/validate/cache %Pages and %Items
- get_cache($Dircache, $Itemcache, \@Podpath, $Podroot, $Recurse);
-
- # scan the pod for =item directives
- scan_items( \%Local_Items, "", @poddata);
+HTMLHEAD
- # put an index at the top of the file. note, if $Doindex is 0 we
- # still generate an index, but surround it with an html comment.
- # that way some other program can extract it if desired.
- $index =~ s/--+/-/g;
-
- my $hr = ($Doindex and $index) ? qq(<hr name="index" />) : "";
-
- unless ($Doindex)
- {
- $index = qq(<!--\n$index\n-->\n);
- }
-
- print $html <<"END_OF_INDEX";
-
-<!-- INDEX BEGIN -->
-<div name="index">
-<p><a name=\"__index__\"></a></p>
-$index
-$hr
-</div>
-<!-- INDEX END -->
-
-END_OF_INDEX
-
- # now convert this file
- my $after_item; # set to true after an =item
- warn "Converting input file $Podfile\n" if $Verbose;
- foreach my $i (0..$#poddata){
- $_ = $poddata[$i];
- $Paragraph = $i+1;
- if (/^(=.*)/s) { # is it a pod directive?
- $Ignore = 0;
- $after_item = 0;
- $_ = $1;
- if (/^=begin\s+(\S+)\s*(.*)/si) {# =begin
- process_begin($html, $1, $2);
- } elsif (/^=end\s+(\S+)\s*(.*)/si) {# =end
- process_end($1, $2);
- } elsif (/^=cut/) { # =cut
- process_cut();
- } elsif (/^=pod/) { # =pod
- process_pod();
- } else {
- next if @Begin_Stack && $Begin_Stack[-1] ne 'html';
-
- if (/^=(head[1-6])\s+(.*\S)/s) { # =head[1-6] heading
- process_head( $html, $1, $2, $Doindex && $index );
- } elsif (/^=item\s*(.*\S)?/sm) { # =item text
- process_item( $html, $1 );
- $after_item = 1;
- } elsif (/^=over\s*(.*)/) { # =over N
- process_over();
- } elsif (/^=back/) { # =back
- process_back( $html );
- } elsif (/^=for\s+(\S+)\s*(.*)/si) {# =for
- process_for( $html, $1, $2 );
- } else {
- /^=(\S*)\s*/;
- warn "$0: $Podfile: unknown pod directive '$1' in "
- . "paragraph $Paragraph. ignoring.\n" unless $Quiet;
- }
- }
- $Top = 0;
- }
- else {
- next if $Ignore;
- if (@Begin_Stack) {
- print $html $_ if $Begin_Stack[-1] eq 'html';
- next;
- }
- my $text = $_;
-
- # Open tag for definition list as we have something to put in it
- if( $ListNewTerm ){
- print $html "<dd>\n";
- $ListNewTerm = 0;
- }
-
- if( $text =~ /\A\s+/ ){
- process_pre( \$text );
- print $html "<pre>\n$text</pre>\n";
-
- } else {
- process_text( \$text );
-
- # experimental: check for a paragraph where all lines
- # have some ...\t...\t...\n pattern
- if( $text =~ /\t/ ){
- my @lines = split( "\n", $text );
- if( @lines > 1 ){
- my $all = 2;
- foreach my $line ( @lines ){
- if( $line =~ /\S/ && $line !~ /\t/ ){
- $all--;
- last if $all == 0;
- }
- }
- if( $all > 0 ){
- $text =~ s/\t+/<td>/g;
- $text =~ s/^/<tr><td>/gm;
- $text = '<table cellspacing="0" cellpadding="0">' .
- $text . '</table>';
- }
- }
- }
- ## end of experimental
-
- print $html "<p>$text</p>\n";
- }
- $after_item = 0;
- }
- }
-
- # finish off any pending directives
- finish_list( $html );
-
- # link to page index
- print $html "<p><a href=\"#__index__\"><small>$Backlink</small></a></p>\n"
- if $Doindex and $index and $Backlink;
-
- print $html <<END_OF_TAIL;
+ $parser->html_footer(<<"HTMLFOOT");
$block
</body>
</html>
-END_OF_TAIL
+HTMLFOOT
+
+ my $input;
+ unless (@ARGV && $ARGV[0]) {
+ if ($Podfile and $Podfile ne '-') {
+ $input = $Podfile;
+ } else {
+ $input = '-'; # XXX: make a test case for this
+ }
+ } else {
+ $Podfile = $ARGV[0];
+ $input = *ARGV;
+ }
- # close the html file
- close $html or die "Failed to close $Htmlfile: $!";
+ warn "Converting input file $Podfile\n" if $Verbose;
+ $parser->parse_file($input);
- warn "Finished\n" if $Verbose;
+ # Write output to file
+ $Htmlfile = "-" unless $Htmlfile; # stdout
+ my $fhout;
+ if($Htmlfile and $Htmlfile ne '-') {
+ open $fhout, ">", $Htmlfile
+ or die "$0: cannot open $Htmlfile file for output: $!\n";
+ } else {
+ open $fhout, ">-";
+ }
+ print $fhout $output;
+ close $fhout or die "Failed to close $Htmlfile: $!";
+ chmod 0644, $Htmlfile unless $Htmlfile eq '-';
}
##############################################################################
@@ -642,112 +444,105 @@ sub usage {
warn "$0: $podfile: @_\n" if @_;
die <<END_OF_USAGE;
Usage: $0 --help --htmlroot=<name> --infile=<name> --outfile=<name>
- --podpath=<name>:...:<name> --podroot=<name>
- --libpods=<name>:...:<name> --recurse --verbose --index
- --netscape --norecurse --noindex --cachedir=<name>
-
- --backlink - set text for "back to top" links (default: none).
- --cachedir - directory for the item and directory cache files.
- --css - stylesheet URL
- --flush - flushes the item and directory caches.
- --[no]header - produce block header/footer (default is no headers).
- --help - prints this message.
- --hiddendirs - search hidden directories in podpath
- --htmldir - directory for resulting HTML files.
- --htmlroot - http-server base directory from which all relative paths
- in podpath stem (default is /).
- --[no]index - generate an index at the top of the resulting html
- (default behaviour).
- --infile - filename for the pod to convert (input taken from stdin
- by default).
- --libpods - colon-separated list of pages to search for =item pod
- directives in as targets of C<> and implicit links (empty
- by default). note, these are not filenames, but rather
- page names like those that appear in L<> links.
- --outfile - filename for the resulting html file (output sent to
- stdout by default).
- --podpath - colon-separated list of directories containing library
- pods (empty by default).
- --podroot - filesystem base directory from which all relative paths
- in podpath stem (default is .).
- --[no]quiet - suppress some benign warning messages (default is off).
- --[no]recurse - recurse on those subdirectories listed in podpath
- (default behaviour).
- --title - title that will appear in resulting html file.
- --[no]verbose - self-explanatory (off by default).
- --[no]netscape - deprecated, has no effect. for backwards compatibility only.
+ --podpath=<name>:...:<name> --podroot=<name> --cachedir=<name>
+ --recurse --verbose --index --norecurse --noindex
+
+ --[no]backlink - turn =head1 directives into links pointing to the top of
+ the page (off by default).
+ --cachedir - directory for the directory cache files.
+ --css - stylesheet URL
+ --flush - flushes the directory cache.
+ --[no]header - produce block header/footer (default is no headers).
+ --help - prints this message.
+ --htmldir - directory for resulting HTML files.
+ --htmlroot - http-server base directory from which all relative paths
+ in podpath stem (default is /).
+ --[no]index - generate an index at the top of the resulting html
+ (default behaviour).
+ --infile - filename for the pod to convert (input taken from stdin
+ by default).
+ --outfile - filename for the resulting html file (output sent to
+ stdout by default).
+ --[no]poderrors - include a POD ERRORS section in the output if there were
+ any POD errors in the input (default behavior).
+ --podpath - colon-separated list of directories containing library
+ pods (empty by default).
+ --podroot - filesystem base directory from which all relative paths
+ in podpath stem (default is .).
+ --[no]quiet - suppress some benign warning messages (default is off).
+ --[no]recurse - recurse on those subdirectories listed in podpath
+ (default behaviour).
+ --title - title that will appear in resulting html file.
+ --[no]verbose - self-explanatory (off by default).
END_OF_USAGE
}
sub parse_command_line {
- my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,$opt_help,
- $opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,$opt_libpods,
- $opt_netscape,$opt_outfile,$opt_podpath,$opt_podroot,$opt_quiet,
- $opt_recurse,$opt_title,$opt_verbose,$opt_hiddendirs);
+ my ($opt_backlink,$opt_cachedir,$opt_css,$opt_flush,$opt_header,
+ $opt_help,$opt_htmldir,$opt_htmlroot,$opt_index,$opt_infile,
+ $opt_outfile,$opt_poderrors,$opt_podpath,$opt_podroot,
+ $opt_quiet,$opt_recurse,$opt_title,$opt_verbose,$opt_libpods);
unshift @ARGV, split ' ', $Config{pod2html} if $Config{pod2html};
my $result = GetOptions(
- 'backlink=s' => \$opt_backlink,
- 'cachedir=s' => \$opt_cachedir,
- 'css=s' => \$opt_css,
- 'flush' => \$opt_flush,
- 'header!' => \$opt_header,
- 'help' => \$opt_help,
- 'hiddendirs!'=> \$opt_hiddendirs,
- 'htmldir=s' => \$opt_htmldir,
- 'htmlroot=s' => \$opt_htmlroot,
- 'index!' => \$opt_index,
- 'infile=s' => \$opt_infile,
- 'libpods=s' => \$opt_libpods,
- 'netscape!' => \$opt_netscape,
- 'outfile=s' => \$opt_outfile,
- 'podpath=s' => \$opt_podpath,
- 'podroot=s' => \$opt_podroot,
- 'quiet!' => \$opt_quiet,
- 'recurse!' => \$opt_recurse,
- 'title=s' => \$opt_title,
- 'verbose!' => \$opt_verbose,
- );
+ 'backlink!' => \$opt_backlink,
+ 'cachedir=s' => \$opt_cachedir,
+ 'css=s' => \$opt_css,
+ 'flush' => \$opt_flush,
+ 'help' => \$opt_help,
+ 'header!' => \$opt_header,
+ 'htmldir=s' => \$opt_htmldir,
+ 'htmlroot=s' => \$opt_htmlroot,
+ 'index!' => \$opt_index,
+ 'infile=s' => \$opt_infile,
+ 'libpods=s' => \$opt_libpods, # deprecated
+ 'outfile=s' => \$opt_outfile,
+ 'poderrors!' => \$opt_poderrors,
+ 'podpath=s' => \$opt_podpath,
+ 'podroot=s' => \$opt_podroot,
+ 'quiet!' => \$opt_quiet,
+ 'recurse!' => \$opt_recurse,
+ 'title=s' => \$opt_title,
+ 'verbose!' => \$opt_verbose,
+ );
usage("-", "invalid parameters") if not $result;
- usage("-") if defined $opt_help; # see if the user asked for help
- $opt_help = ""; # just to make -w shut-up.
+ usage("-") if defined $opt_help; # see if the user asked for help
+ $opt_help = ""; # just to make -w shut-up.
@Podpath = split(":", $opt_podpath) if defined $opt_podpath;
- @Libpods = split(":", $opt_libpods) if defined $opt_libpods;
-
- $Backlink = $opt_backlink if defined $opt_backlink;
- $Cachedir = $opt_cachedir if defined $opt_cachedir;
- $Css = $opt_css if defined $opt_css;
- $Header = $opt_header if defined $opt_header;
- $Htmldir = $opt_htmldir if defined $opt_htmldir;
- $Htmlroot = $opt_htmlroot if defined $opt_htmlroot;
- $Doindex = $opt_index if defined $opt_index;
- $Podfile = $opt_infile if defined $opt_infile;
- $HiddenDirs = $opt_hiddendirs if defined $opt_hiddendirs;
- $Htmlfile = $opt_outfile if defined $opt_outfile;
- $Podroot = $opt_podroot if defined $opt_podroot;
- $Quiet = $opt_quiet if defined $opt_quiet;
- $Recurse = $opt_recurse if defined $opt_recurse;
- $Title = $opt_title if defined $opt_title;
- $Verbose = $opt_verbose if defined $opt_verbose;
-
- warn "Flushing item and directory caches\n"
- if $opt_verbose && defined $opt_flush;
+ warn "--libpods is no longer supported" if defined $opt_libpods;
+
+ $Backlink = $opt_backlink if defined $opt_backlink;
+ $Cachedir = _unixify($opt_cachedir) if defined $opt_cachedir;
+ $Css = $opt_css if defined $opt_css;
+ $Header = $opt_header if defined $opt_header;
+ $Htmldir = _unixify($opt_htmldir) if defined $opt_htmldir;
+ $Htmlroot = _unixify($opt_htmlroot) if defined $opt_htmlroot;
+ $Doindex = $opt_index if defined $opt_index;
+ $Podfile = _unixify($opt_infile) if defined $opt_infile;
+ $Htmlfile = _unixify($opt_outfile) if defined $opt_outfile;
+ $Poderrors = $opt_poderrors if defined $opt_poderrors;
+ $Podroot = _unixify($opt_podroot) if defined $opt_podroot;
+ $Quiet = $opt_quiet if defined $opt_quiet;
+ $Recurse = $opt_recurse if defined $opt_recurse;
+ $Title = $opt_title if defined $opt_title;
+ $Verbose = $opt_verbose if defined $opt_verbose;
+
+ warn "Flushing directory caches\n"
+ if $opt_verbose && defined $opt_flush;
$Dircache = "$Cachedir/pod2htmd.tmp";
- $Itemcache = "$Cachedir/pod2htmi.tmp";
if (defined $opt_flush) {
- 1 while unlink($Dircache, $Itemcache);
+ 1 while unlink($Dircache);
}
}
-
my $Saved_Cache_Key;
sub get_cache {
- my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
+ my($dircache, $podpath, $podroot, $recurse) = @_;
my @cache_key_args = @_;
# A first-level cache:
@@ -755,1056 +550,65 @@ sub get_cache {
# and haven't changed since we last read them.
my $this_cache_key = cache_key(@cache_key_args);
+ return 1 if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
+ $Saved_Cache_Key = $this_cache_key;
- return if $Saved_Cache_Key and $this_cache_key eq $Saved_Cache_Key;
-
- # load the cache of %Pages and %Items if possible. $tests will be
+ # load the cache of %Pages if possible. $tests will be
# non-zero if successful.
my $tests = 0;
- if (-f $dircache && -f $itemcache) {
- warn "scanning for item cache\n" if $Verbose;
- $tests = load_cache($dircache, $itemcache, $podpath, $podroot);
+ if (-f $dircache) {
+ warn "scanning for directory cache\n" if $Verbose;
+ $tests = load_cache($dircache, $podpath, $podroot);
}
- # if we didn't succeed in loading the cache then we must (re)build
- # %Pages and %Items.
- if (!$tests) {
- warn "scanning directories in pod-path\n" if $Verbose;
- scan_podpath($podroot, $recurse, 0);
- }
- $Saved_Cache_Key = cache_key(@cache_key_args);
+ return $tests;
}
sub cache_key {
- my($dircache, $itemcache, $podpath, $podroot, $recurse) = @_;
- return join('!', $dircache, $itemcache, $recurse,
- @$podpath, $podroot, stat($dircache), stat($itemcache));
+ my($dircache, $podpath, $podroot, $recurse) = @_;
+ return join('!',$dircache,$recurse,@$podpath,$podroot,stat($dircache));
}
#
-# load_cache - tries to find if the caches stored in $dircache and $itemcache
-# are valid caches of %Pages and %Items. if they are valid then it loads
-# them and returns a non-zero value.
+# load_cache - tries to find if the cache stored in $dircache is a valid
+# cache of %Pages. if so, it loads them and returns a non-zero value.
#
sub load_cache {
- my($dircache, $itemcache, $podpath, $podroot) = @_;
- my($tests);
+ my($dircache, $podpath, $podroot) = @_;
+ my $tests = 0;
local $_;
- $tests = 0;
-
- open(CACHE, "<$itemcache") ||
- die "$0: error opening $itemcache for reading: $!\n";
- $/ = "\n";
-
- # is it the same podpath?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if (join(":", @$podpath) eq $_);
-
- # is it the same podroot?
- $_ = <CACHE>;
- chomp($_);
- $tests++ if ($podroot eq $_);
-
- # load the cache if its good
- if ($tests != 2) {
- close(CACHE);
- return 0;
- }
-
- warn "loading item cache\n" if $Verbose;
- while (<CACHE>) {
- /(.*?) (.*)$/;
- $Items{$1} = $2;
- }
- close(CACHE);
-
warn "scanning for directory cache\n" if $Verbose;
- open(CACHE, "<$dircache") ||
- die "$0: error opening $dircache for reading: $!\n";
+ open(my $cachefh, '<', $dircache) ||
+ die "$0: error opening $dircache for reading: $!\n";
$/ = "\n";
- $tests = 0;
# is it the same podpath?
- $_ = <CACHE>;
+ $_ = <$cachefh>;
chomp($_);
$tests++ if (join(":", @$podpath) eq $_);
# is it the same podroot?
- $_ = <CACHE>;
+ $_ = <$cachefh>;
chomp($_);
$tests++ if ($podroot eq $_);
# load the cache if its good
if ($tests != 2) {
- close(CACHE);
- return 0;
+ close($cachefh);
+ return 0;
}
warn "loading directory cache\n" if $Verbose;
- while (<CACHE>) {
- /(.*?) (.*)$/;
- $Pages{$1} = $2;
+ while (<$cachefh>) {
+ /(.*?) (.*)$/;
+ $Pages{$1} = $2;
}
- close(CACHE);
-
+ close($cachefh);
return 1;
}
-#
-# scan_podpath - scans the directories specified in @podpath for directories,
-# .pod files, and .pm files. it also scans the pod files specified in
-# @Libpods for =item directives.
-#
-sub scan_podpath {
- my($podroot, $recurse, $append) = @_;
- my($pwd, $dir);
- my($libpod, $dirname, $pod, @files, @poddata);
-
- unless($append) {
- %Items = ();
- %Pages = ();
- }
-
- # scan each directory listed in @Podpath
- $pwd = getcwd();
- chdir($podroot)
- || die "$0: error changing to directory $podroot: $!\n";
- foreach $dir (@Podpath) {
- scan_dir($dir, $recurse);
- }
-
- # scan the pods listed in @Libpods for =item directives
- foreach $libpod (@Libpods) {
- # if the page isn't defined then we won't know where to find it
- # on the system.
- next unless defined $Pages{$libpod} && $Pages{$libpod};
-
- # if there is a directory then use the .pod and .pm files within it.
- # NOTE: Only finds the first so-named directory in the tree.
-# if ($Pages{$libpod} =~ /([^:]*[^(\.pod|\.pm)]):/) {
- if ($Pages{$libpod} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
- # find all the .pod and .pm files within the directory
- $dirname = $1;
- opendir(DIR, $dirname) ||
- die "$0: error opening directory $dirname: $!\n";
- @files = grep(/(\.pod|\.pm)\z/ && ! -d $_, readdir(DIR));
- closedir(DIR);
-
- # scan each .pod and .pm file for =item directives
- foreach $pod (@files) {
- open my $fh, '<', "$dirname/$pod"
- or die "$0: error opening $dirname/$pod for input: $!\n";
- @poddata = <$fh>;
- close $fh;
- clean_data( \@poddata );
-
- scan_items( \%Items, "$dirname/$pod", @poddata);
- }
-
- # use the names of files as =item directives too.
-### Don't think this should be done this way - confuses issues.(WL)
-### foreach $pod (@files) {
-### $pod =~ /^(.*)(\.pod|\.pm)$/;
-### $Items{$1} = "$dirname/$1.html" if $1;
-### }
- } elsif ($Pages{$libpod} =~ /([^:]*\.pod):/ ||
- $Pages{$libpod} =~ /([^:]*\.pm):/) {
- # scan the .pod or .pm file for =item directives
- $pod = $1;
- open my $fh, '<', $pod
- or die "$0: error opening $pod for input: $!\n";
- @poddata = <$fh>;
- close $fh;
- clean_data( \@poddata );
-
- scan_items( \%Items, "$pod", @poddata);
- } else {
- warn "$0: shouldn't be here (line ".__LINE__."\n" unless $Quiet;
- }
- }
- @poddata = (); # clean-up a bit
-
- chdir($pwd)
- || die "$0: error changing to directory $pwd: $!\n";
-
- # cache the item list for later use
- warn "caching items for later use\n" if $Verbose;
- open my $cache, '>', $Itemcache
- or die "$0: error open $Itemcache for writing: $!\n";
-
- print $cache join(":", @Podpath) . "\n$podroot\n";
- foreach my $key (keys %Items) {
- print $cache "$key $Items{$key}\n";
- }
-
- close $cache or die "error closing $Itemcache: $!";
-
- # cache the directory list for later use
- warn "caching directories for later use\n" if $Verbose;
- open $cache, '>', $Dircache
- or die "$0: error open $Dircache for writing: $!\n";
-
- print $cache join(":", @Podpath) . "\n$podroot\n";
- foreach my $key (keys %Pages) {
- print $cache "$key $Pages{$key}\n";
- }
-
- close $cache or die "error closing $Dircache: $!";
-}
-
-#
-# scan_dir - scans the directory specified in $dir for subdirectories, .pod
-# files, and .pm files. notes those that it finds. this information will
-# be used later in order to figure out where the pages specified in L<>
-# links are on the filesystem.
-#
-sub scan_dir {
- my($dir, $recurse) = @_;
- my($t, @subdirs, @pods, $pod, $dirname, @dirs);
- local $_;
-
- @subdirs = ();
- @pods = ();
-
- opendir(DIR, $dir) ||
- die "$0: error opening directory $dir: $!\n";
- while (defined($_ = readdir(DIR))) {
- if (-d "$dir/$_" && $_ ne "." && $_ ne ".."
- && ($HiddenDirs || !/^\./)
- ) { # directory
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_:";
- push(@subdirs, $_);
- } elsif (/\.pod\z/) { # .pod
- s/\.pod\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- push(@pods, "$dir/$_.pod");
- } elsif (/\.html\z/) { # .html
- s/\.html\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- } elsif (/\.pm\z/) { # .pm
- s/\.pm\z//;
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pm:";
- push(@pods, "$dir/$_.pm");
- } elsif (-T "$dir/$_") { # script(?)
- local *F;
- if (open(F, "$dir/$_")) {
- my $line;
- while (defined($line = <F>)) {
- if ($line =~ /^=(?:pod|head1)/) {
- $Pages{$_} = "" unless defined $Pages{$_};
- $Pages{$_} .= "$dir/$_.pod:";
- last;
- }
- }
- close(F);
- }
- }
- }
- closedir(DIR);
-
- # recurse on the subdirectories if necessary
- if ($recurse) {
- foreach my $subdir (@subdirs) {
- scan_dir("$dir/$subdir", $recurse);
- }
- }
-}
-
-#
-# scan_headings - scan a pod file for head[1-6] tags, note the tags, and
-# build an index.
-#
-sub scan_headings {
- my($sections, @data) = @_;
- my($tag, $which_head, $otitle, $listdepth, $index);
-
- local $Ignore = 0;
-
- $listdepth = 0;
- $index = "";
-
- # scan for =head directives, note their name, and build an index
- # pointing to each of them.
- foreach my $line (@data) {
- if ($line =~ /^=(head)([1-6])\s+(.*)/) {
- ($tag, $which_head, $otitle) = ($1,$2,$3);
-
- my $title = depod( $otitle );
- my $name = anchorify( $title );
- $$sections{$name} = 1;
- $title = process_text( \$otitle );
-
- while ($which_head != $listdepth) {
- if ($which_head > $listdepth) {
- $index .= "\n" . ("\t" x $listdepth) . "<ul>\n";
- $listdepth++;
- } elsif ($which_head < $listdepth) {
- $listdepth--;
- $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
- }
- }
-
- $index .= "\n" . ("\t" x $listdepth) . "<li>" .
- "<a href=\"#" . $name . "\">" .
- $title . "</a></li>";
- }
- }
-
- # finish off the lists
- while ($listdepth--) {
- $index .= "\n" . ("\t" x $listdepth) . "</ul>\n";
- }
-
- # get rid of bogus lists
- $index =~ s,\t*<ul>\s*</ul>\n,,g;
-
- return $index;
-}
-
-#
-# scan_items - scans the pod specified by $pod for =item directives. we
-# will use this information later on in resolving C<> links.
-#
-sub scan_items {
- my( $itemref, $pod, @poddata ) = @_;
- my($i, $item);
- local $_;
-
- $pod =~ s/\.pod\z//;
- $pod .= ".html" if $pod;
-
- foreach $i (0..$#poddata) {
- my $txt = depod( $poddata[$i] );
-
- # figure out what kind of item it is.
- # Build string for referencing this item.
- if ( $txt =~ /\A=item\s+\*\s*(.*)\Z/s ) { # bulleted list
- next unless $1;
- $item = $1;
- } elsif( $txt =~ /\A=item\s+(?>\d+\.?)\s*(.*)\Z/s ) { # numbered list
- $item = $1;
- } elsif( $txt =~ /\A=item\s+(.*)\Z/s ) { # definition list
- $item = $1;
- } else {
- next;
- }
- my $fid = fragment_id( $item );
- $$itemref{$fid} = "$pod" if $fid;
- }
-}
-
-#
-# process_head - convert a pod head[1-6] tag and convert it to HTML format.
-#
-sub process_head {
- my($fh, $tag, $heading, $hasindex) = @_;
-
- # figure out the level of the =head
- $tag =~ /head([1-6])/;
- my $level = $1;
-
- finish_list( $fh );
-
- print $fh "<p>\n";
- if( $level == 1 && ! $Top ){
- print $fh "<a href=\"#__index__\"><small>$Backlink</small></a>\n"
- if $hasindex and $Backlink;
- print $fh "</p>\n<hr />\n"
- } else {
- print $fh "</p>\n";
- }
-
- my $name = anchorify( depod( $heading ) );
- my $convert = process_text( \$heading );
- print $fh "<h$level><a name=\"$name\">$convert</a></h$level>\n";
-}
-
-
-#
-# emit_item_tag - print an =item's text
-# Note: The global $EmittedItem is used for inhibiting self-references.
-#
-my $EmittedItem;
-
-sub emit_item_tag {
- my( $fh, $otext, $text, $compact ) = @_;
- my $item = fragment_id( depod($text) , -generate);
- Carp::confess("Undefined fragment '$text' (".depod($text).") from fragment_id() in emit_item_tag() in $Podfile")
- if !defined $item;
- $EmittedItem = $item;
- ### print STDERR "emit_item_tag=$item ($text)\n";
-
- print $fh '<strong>';
- if ($Items_Named{$item}++) {
- print $fh process_text( \$otext );
- } else {
- my $name = $item;
- $name = anchorify($name);
- print $fh qq{<a name="$name" class="item">}, process_text( \$otext ), '</a>';
- }
- print $fh "</strong>";
- undef( $EmittedItem );
-}
-
-sub new_listitem {
- my ($fh, $tag) = @_;
- # Open tag for definition list as we have something to put in it
- if( ($tag ne 'dl') && ($ListNewTerm) ){
- print $fh "<dd>\n";
- $ListNewTerm = 0;
- }
-
- if( $Items_Seen[$Listlevel]++ == 0 ){
- # start of new list
- push( @Listtype, "$tag" );
- print $fh "<$tag>\n";
- } else {
- # if this is not the first item, close the previous one
- if ( $tag eq 'dl' ){
- print $fh "</dd>\n" unless $ListNewTerm;
- } else {
- print $fh "</li>\n";
- }
- }
- my $opentag = $tag eq 'dl' ? 'dt' : 'li';
- print $fh "<$opentag>";
-}
-
-#
-# process_item - convert a pod item tag and convert it to HTML format.
-#
-sub process_item {
- my ($fh, $otext) = @_;
-
- # lots of documents start a list without doing an =over. this is
- # bad! but, the proper thing to do seems to be to just assume
- # they did do an =over. so warn them once and then continue.
- if( $Listlevel == 0 ){
- warn "$0: $Podfile: unexpected =item directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- process_over();
- }
-
- # remove formatting instructions from the text
- my $text = depod( $otext );
-
- # all the list variants:
- if( $text =~ /\A\*/ ){ # bullet
- new_listitem( $fh, 'ul' );
- if ($text =~ /\A\*\s+(\S.*)\Z/s ) { # with additional text
- my $tag = $1;
- $otext =~ s/\A\*\s+//;
- emit_item_tag( $fh, $otext, $tag, 1 );
- print $fh "\n";
- }
-
- } elsif( $text =~ /\A\d+/ ){ # numbered list
- new_listitem( $fh, 'ol' );
- if ($text =~ /\A(?>\d+\.?)\s*(\S.*)\Z/s ) { # with additional text
- my $tag = $1;
- $otext =~ s/\A\d+\.?\s*//;
- emit_item_tag( $fh, $otext, $tag, 1 );
- print $fh "\n";
- }
-
- } else { # definition list
- # new_listitem takes care of opening the <dt> tag
- new_listitem( $fh, 'dl' );
- if ($text =~ /\A(.+)\Z/s ){ # should have text
- emit_item_tag( $fh, $otext, $text, 1 );
- # write the definition term and close <dt> tag
- print $fh "</dt>\n";
- }
- # trigger opening a <dd> tag for the actual definition; will not
- # happen if next paragraph is also a definition term (=item)
- $ListNewTerm = 1;
- }
- print $fh "\n";
-}
-
-#
-# process_over - process a pod over tag and start a corresponding HTML list.
-#
-sub process_over {
- # start a new list
- $Listlevel++;
- push( @Items_Seen, 0 );
-}
-
-#
-# process_back - process a pod back tag and convert it to HTML format.
-#
-sub process_back {
- my $fh = shift;
- if( $Listlevel == 0 ){
- warn "$0: $Podfile: unexpected =back directive in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- return;
- }
-
- # close off the list. note, I check to see if $Listtype[$Listlevel] is
- # defined because an =item directive may have never appeared and thus
- # $Listtype[$Listlevel] may have never been initialized.
- $Listlevel--;
- if( defined $Listtype[$Listlevel] ){
- if ( $Listtype[$Listlevel] eq 'dl' ){
- print $fh "</dd>\n" unless $ListNewTerm;
- } else {
- print $fh "</li>\n";
- }
- print $fh "</$Listtype[$Listlevel]>\n";
- pop( @Listtype );
- $ListNewTerm = 0;
- }
-
- # clean up item count
- pop( @Items_Seen );
-}
-
-#
-# process_cut - process a pod cut tag, thus start ignoring pod directives.
-#
-sub process_cut {
- $Ignore = 1;
-}
-
-#
-# process_pod - process a pod tag, thus stop ignoring pod directives
-# until we see a corresponding cut.
-#
-sub process_pod {
- # no need to set $Ignore to 0 cause the main loop did it
-}
-
-#
-# process_for - process a =for pod tag. if it's for html, spit
-# it out verbatim, if illustration, center it, otherwise ignore it.
-#
-sub process_for {
- my ($fh, $whom, $text) = @_;
- if ( $whom =~ /^(pod2)?html$/i) {
- print $fh $text;
- } elsif ($whom =~ /^illustration$/i) {
- 1 while chomp $text;
- for my $ext (qw[.png .gif .jpeg .jpg .tga .pcl .bmp]) {
- $text .= $ext, last if -r "$text$ext";
- }
- print $fh qq{<p align="center"><img src="$text" alt="$text illustration" /></p>};
- }
-}
-
-#
-# process_begin - process a =begin pod tag. this pushes
-# whom we're beginning on the begin stack. if there's a
-# begin stack, we only print if it us.
-#
-sub process_begin {
- my ($fh, $whom, $text) = @_;
- $whom = lc($whom);
- push (@Begin_Stack, $whom);
- if ( $whom =~ /^(pod2)?html$/) {
- print $fh $text if $text;
- }
-}
-
-#
-# process_end - process a =end pod tag. pop the
-# begin stack. die if we're mismatched.
-#
-sub process_end {
- my($whom, $text) = @_;
- $whom = lc($whom);
- if (!defined $Begin_Stack[-1] or $Begin_Stack[-1] ne $whom ) {
- Carp::confess("Unmatched begin/end at chunk $Paragraph in pod $Podfile\n")
- }
- pop( @Begin_Stack );
-}
-
-#
-# process_pre - indented paragraph, made into <pre></pre>
-#
-sub process_pre {
- my( $text ) = @_;
- my( $rest );
- return if $Ignore;
-
- $rest = $$text;
-
- # insert spaces in place of tabs
- $rest =~ s#(.+)#
- my $line = $1;
- 1 while $line =~ s/(\t+)/' ' x ((length($1) * 8) - $-[0] % 8)/e;
- $line;
- #eg;
-
- # convert some special chars to HTML escapes
- $rest = html_escape($rest);
-
- # try and create links for all occurrences of perl.* within
- # the preformatted text.
- $rest =~ s{
- (\s*)(perl\w+)
- }{
- if ( defined $Pages{$2} ){ # is a link
- qq($1<a href="$Htmlroot/$Pages{$2}">$2</a>);
- } elsif (defined $Pages{dosify($2)}) { # is a link
- qq($1<a href="$Htmlroot/$Pages{dosify($2)}">$2</a>);
- } else {
- "$1$2";
- }
- }xeg;
- $rest =~ s{
- (<a\ href="?) ([^>:]*:)? ([^>:]*) \.pod: ([^>:]*:)?
- }{
- my $url ;
- if ( $Htmlfileurl ne '' ){
- # Here, we take advantage of the knowledge
- # that $Htmlfileurl ne '' implies $Htmlroot eq ''.
- # Since $Htmlroot eq '', we need to prepend $Htmldir
- # on the fron of the link to get the absolute path
- # of the link's target. We check for a leading '/'
- # to avoid corrupting links that are #, file:, etc.
- my $old_url = $3 ;
- $old_url = "$Htmldir$old_url" if $old_url =~ m{^\/};
- $url = relativize_url( "$old_url.html", $Htmlfileurl );
- } else {
- $url = "$3.html" ;
- }
- "$1$url" ;
- }xeg;
-
- # Look for embedded URLs and make them into links. We don't
- # relativize them since they are best left as the author intended.
-
- my $urls = '(' . join ('|', qw{
- http
- telnet
- mailto
- news
- gopher
- file
- wais
- ftp
- } )
- . ')';
-
- my $ltrs = '\w';
- my $gunk = '/#~:.?+=&%@!\-';
- my $punc = '.:!?\-;';
- my $any = "${ltrs}${gunk}${punc}";
-
- $rest =~ s{
- \b # start at word boundary
- ( # begin $1 {
- $urls : # need resource and a colon
- (?!:) # Ignore File::, among others.
- [$any] +? # followed by one or more of any valid
- # character, but be conservative and
- # take only what you need to....
- ) # end $1 }
- (?=
- &quot; &gt; # maybe pre-quoted '<a href="...">'
- | # or:
- [$punc]* # 0 or more punctuation
- (?: # followed
- [^$any] # by a non-url char
- | # or
- $ # end of the string
- ) #
- | # or else
- $ # then end of the string
- )
- }{<a href="$1">$1</a>}igox;
-
- # text should be as it is (verbatim)
- $$text = $rest;
-}
-
-
-#
-# pure text processing
-#
-# pure_text/inIS_text: differ with respect to automatic C<> recognition.
-# we don't want this to happen within IS
-#
-sub pure_text($){
- my $text = shift();
- process_puretext( $text, 1 );
-}
-
-sub inIS_text($){
- my $text = shift();
- process_puretext( $text, 0 );
-}
-
-#
-# process_puretext - process pure text (without pod-escapes) converting
-# double-quotes and handling implicit C<> links.
-#
-sub process_puretext {
- my($text, $notinIS) = @_;
-
- ## Guessing at func() or [\$\@%&]*var references in plain text is destined
- ## to produce some strange looking ref's. uncomment to disable:
- ## $notinIS = 0;
-
- my(@words, $lead, $trail);
-
- # keep track of leading and trailing white-space
- $lead = ($text =~ s/\A(\s+)//s ? $1 : "");
- $trail = ($text =~ s/(\s+)\Z//s ? $1 : "");
-
- # split at space/non-space boundaries
- @words = split( /(?<=\s)(?=\S)|(?<=\S)(?=\s)/, $text );
-
- # process each word individually
- foreach my $word (@words) {
- # skip space runs
- next if $word =~ /^\s*$/;
- # see if we can infer a link or a function call
- #
- # NOTE: This is a word based search, it won't automatically
- # mark "substr($var, 1, 2)" because the 1st word would be "substr($var"
- # User has to enclose those with proper C<>
-
- if( $notinIS && $word =~
- m/
- ^([a-z_]{2,}) # The function name
- \(
- ([0-9][a-z]* # Manual page(1) or page(1M)
- |[^)]*[\$\@\%][^)]+ # ($foo), (1, @foo), (%hash)
- | # ()
- )
- \)
- ([.,;]?)$ # a possible punctuation follows
- /xi
- ) {
- # has parenthesis so should have been a C<> ref
- ## try for a pagename (perlXXX(1))?
- my( $func, $args, $rest ) = ( $1, $2, $3 || '' );
- if( $args =~ /^\d+$/ ){
- my $url = page_sect( $word, '' );
- if( defined $url ){
- $word = qq(<a href="$url" class="man">the $word manpage</a>$rest);
- next;
- }
- }
- ## try function name for a link, append tt'ed argument list
- $word = emit_C( $func, '', "($args)") . $rest;
-
-#### disabled. either all (including $\W, $\w+{.*} etc.) or nothing.
-## } elsif( $notinIS && $word =~ /^[\$\@%&*]+\w+$/) {
-## # perl variables, should be a C<> ref
-## $word = emit_C( $word );
-
- } elsif ($word =~ m,^\w+://\w,) {
- # looks like a URL
- # Don't relativize it: leave it as the author intended
- $word = qq(<a href="$word">$word</a>);
- } elsif ($word =~ /[\w.-]+\@[\w-]+\.\w/) {
- # looks like an e-mail address
- my ($w1, $w2, $w3) = ("", $word, "");
- ($w1, $w2, $w3) = ("(", $1, ")$2") if $word =~ /^\((.*?)\)(,?)/;
- ($w1, $w2, $w3) = ("&lt;", $1, "&gt;$2") if $word =~ /^<(.*?)>(,?)/;
- $word = qq($w1<a href="mailto:$w2">$w2</a>$w3);
- } else {
- $word = html_escape($word) if $word =~ /["&<>]/;
- }
- }
-
- # put everything back together
- return $lead . join( '', @words ) . $trail;
-}
-
-
-#
-# process_text - handles plaintext that appears in the input pod file.
-# there may be pod commands embedded within the text so those must be
-# converted to html commands.
-#
-
-sub process_text1($$;$$);
-sub pattern ($) { $_[0] ? '\s+'.('>' x ($_[0] + 1)) : '>' }
-sub closing ($) { local($_) = shift; (defined && s/\s+\z//) ? length : 0 }
-
-sub process_text {
- return if $Ignore;
- my( $tref ) = @_;
- my $res = process_text1( 0, $tref );
- $res =~ s/\s+$//s;
- $$tref = $res;
-}
-
-sub process_text_rfc_links {
- my $text = shift;
-
- # For every "RFCnnnn" or "RFC nnn", link it to the authoritative
- # ource. Do not use the /i modifier here. Require "RFC" to be written in
- # in capital letters.
-
- $text =~ s{
- (?<=[^<>[:alpha:]]) # Make sure this is not an URL already
- (RFC\s*([0-9]{1,5}))(?![0-9]) # max 5 digits
- }
- {<a href="http://www.ietf.org/rfc/rfc$2.txt" class="rfc">$1</a>}gx;
-
- $text;
-}
-
-sub process_text1($$;$$){
- my( $lev, $rstr, $func, $closing ) = @_;
- my $res = '';
-
- unless (defined $func) {
- $func = '';
- $lev++;
- }
-
- if( $func eq 'B' ){
- # B<text> - boldface
- $res = '<strong>' . process_text1( $lev, $rstr ) . '</strong>';
-
- } elsif( $func eq 'C' ){
- # C<code> - can be a ref or <code></code>
- # need to extract text
- my $par = go_ahead( $rstr, 'C', $closing );
-
- ## clean-up of the link target
- my $text = depod( $par );
-
- ### my $x = $par =~ /[BI]</ ? 'yes' : 'no' ;
- ### print STDERR "-->call emit_C($par) lev=$lev, par with BI=$x\n";
-
- $res = emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
-
- } elsif( $func eq 'E' ){
- # E<x> - convert to character
- $$rstr =~ s/^([^>]*)>//;
- my $escape = $1;
- $escape =~ s/^0?x([\dA-F]+)$/#x$1/i
- or $escape =~ s/^0([0-7]+)$/'#'.oct($1)/ei
- or $escape =~ s/^(\d+)$/#$1/;
- $res = "&$escape;";
-
- } elsif( $func eq 'F' ){
- # F<filename> - italicize
- $res = '<em class="file">' . process_text1( $lev, $rstr ) . '</em>';
-
- } elsif( $func eq 'I' ){
- # I<text> - italicize
- $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
-
- } elsif( $func eq 'L' ){
- # L<link> - link
- ## L<text|cross-ref> => produce text, use cross-ref for linking
- ## L<cross-ref> => make text from cross-ref
- ## need to extract text
- my $par = go_ahead( $rstr, 'L', $closing );
-
- # some L<>'s that shouldn't be:
- # a) full-blown URL's are emitted as-is
- if( $par =~ m{^\w+://}s ){
- return make_URL_href( $par );
- }
- # b) C<...> is stripped and treated as C<>
- if( $par =~ /^C<(.*)>$/ ){
- my $text = depod( $1 );
- return emit_C( $text, $lev > 1 || ($par =~ /[BI]</) );
- }
-
- # analyze the contents
- $par =~ s/\n/ /g; # undo word-wrapped tags
- my $opar = $par;
- my $linktext;
- if( $par =~ s{^([^|]+)\|}{} ){
- $linktext = $1;
- }
-
- # make sure sections start with a /
- $par =~ s{^"}{/"};
-
- my( $page, $section, $ident );
-
- # check for link patterns
- if( $par =~ m{^([^/]+?)/(?!")(.*?)$} ){ # name/ident
- # we've got a name/ident (no quotes)
- if (length $2) {
- ( $page, $ident ) = ( $1, $2 );
- } else {
- ( $page, $section ) = ( $1, $2 );
- }
- ### print STDERR "--> L<$par> to page $page, ident $ident\n";
-
- } elsif( $par =~ m{^(.*?)/"?(.*?)"?$} ){ # [name]/"section"
- # even though this should be a "section", we go for ident first
- ( $page, $ident ) = ( $1, $2 );
- ### print STDERR "--> L<$par> to page $page, section $section\n";
-
- } elsif( $par =~ /\s/ ){ # this must be a section with missing quotes
- ( $page, $section ) = ( '', $par );
- ### print STDERR "--> L<$par> to void page, section $section\n";
-
- } else {
- ( $page, $section ) = ( $par, '' );
- ### print STDERR "--> L<$par> to page $par, void section\n";
- }
-
- # now, either $section or $ident is defined. the convoluted logic
- # below tries to resolve L<> according to what the user specified.
- # failing this, we try to find the next best thing...
- my( $url, $ltext, $fid );
-
- RESOLVE: {
- if( defined $ident ){
- ## try to resolve $ident as an item
- ( $url, $fid ) = coderef( $page, $ident );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $ident;
- $linktext .= " in " if $ident && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got coderef url=$url\n";
- last RESOLVE;
- }
- ## no luck: go for a section (auto-quoting!)
- $section = $ident;
- }
- ## now go for a section
- my $htmlsection = htmlify( $section );
- $url = page_sect( $page, $htmlsection );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $section;
- $linktext .= " in " if $section && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got page/section url=$url\n";
- last RESOLVE;
- }
- ## no luck: go for an ident
- if( $section ){
- $ident = $section;
- } else {
- $ident = $page;
- $page = undef();
- }
- ( $url, $fid ) = coderef( $page, $ident );
- if( $url ){
- if( ! defined( $linktext ) ){
- $linktext = $ident;
- $linktext .= " in " if $ident && $page;
- $linktext .= "the $page manpage" if $page;
- }
- ### print STDERR "got section=>coderef url=$url\n";
- last RESOLVE;
- }
-
- # warning; show some text.
- $linktext = $opar unless defined $linktext;
- warn "$0: $Podfile: cannot resolve L<$opar> in paragraph $Paragraph.\n" unless $Quiet;
- }
-
- # now we have a URL or just plain code
- $$rstr = $linktext . '>' . $$rstr;
- if( defined( $url ) ){
- $res = "<a href=\"$url\">" . process_text1( $lev, $rstr ) . '</a>';
- } else {
- $res = '<em>' . process_text1( $lev, $rstr ) . '</em>';
- }
-
- } elsif( $func eq 'S' ){
- # S<text> - non-breaking spaces
- $res = process_text1( $lev, $rstr );
- $res =~ s/ /&nbsp;/g;
-
- } elsif( $func eq 'X' ){
- # X<> - ignore
- warn "$0: $Podfile: invalid X<> in paragraph $Paragraph.\n"
- unless $$rstr =~ s/^[^>]*>// or $Quiet;
- } elsif( $func eq 'Z' ){
- # Z<> - empty
- warn "$0: $Podfile: invalid Z<> in paragraph $Paragraph.\n"
- unless $$rstr =~ s/^>// or $Quiet;
-
- } else {
- my $term = pattern $closing;
- while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
- # all others: either recurse into new function or
- # terminate at closing angle bracket(s)
- my $pt = $1;
- $pt .= $2 if !$3 && $lev == 1;
- $res .= $lev == 1 ? pure_text( $pt ) : inIS_text( $pt );
- return $res if !$3 && $lev > 1;
- if( $3 ){
- $res .= process_text1( $lev, $rstr, $3, closing $4 );
- }
- }
- if( $lev == 1 ){
- $res .= pure_text( $$rstr );
- } elsif( ! $Quiet ) {
- my $snippet = substr($$rstr,0,60);
- warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph: '$snippet'.\n"
-
- }
- $res = process_text_rfc_links($res);
- }
- return $res;
-}
-
-#
-# go_ahead: extract text of an IS (can be nested)
-#
-sub go_ahead($$$){
- my( $rstr, $func, $closing ) = @_;
- my $res = '';
- my @closing = ($closing);
- while( $$rstr =~
- s/\A(.*?)(([BCEFILSXZ])<(<+\s+)?|@{[pattern $closing[0]]})//s ){
- $res .= $1;
- unless( $3 ){
- shift @closing;
- return $res unless @closing;
- } else {
- unshift @closing, closing $4;
- }
- $res .= $2;
- }
- unless ($Quiet) {
- my $snippet = substr($$rstr,0,60);
- warn "$0: $Podfile: undelimited $func<> in paragraph $Paragraph (go_ahead): '$snippet'.\n"
- }
- return $res;
-}
-
-#
-# emit_C - output result of C<text>
-# $text is the depod-ed text
-#
-sub emit_C($;$$){
- my( $text, $nocode, $args ) = @_;
- $args = '' unless defined $args;
- my $res;
- my( $url, $fid ) = coderef( undef(), $text );
-
- # need HTML-safe text
- my $linktext = html_escape( "$text$args" );
-
- if( defined( $url ) &&
- (!defined( $EmittedItem ) || $EmittedItem ne $fid ) ){
- $res = "<a href=\"$url\"><code>$linktext</code></a>";
- } elsif( 0 && $nocode ){
- $res = $linktext;
- } else {
- $res = "<code>$linktext</code>";
- }
- return $res;
-}
#
# html_escape: make text safe for HTML
@@ -1820,240 +624,6 @@ sub html_escape {
return $rest;
}
-
-#
-# dosify - convert filenames to 8.3
-#
-sub dosify {
- my($str) = @_;
- return lc($str) if $^O eq 'VMS'; # VMS just needs casing
- if ($Is83) {
- $str = lc $str;
- $str =~ s/(\.\w+)/substr ($1,0,4)/ge;
- $str =~ s/(\w+)/substr ($1,0,8)/ge;
- }
- return $str;
-}
-
-#
-# page_sect - make a URL from the text of a L<>
-#
-sub page_sect($$) {
- my( $page, $section ) = @_;
- my( $linktext, $page83, $link); # work strings
-
- # check if we know that this is a section in this page
- if (!defined $Pages{$page} && defined $Sections{$page}) {
- $section = $page;
- $page = "";
- ### print STDERR "reset page='', section=$section\n";
- }
-
- $page83=dosify($page);
- $page=$page83 if (defined $Pages{$page83});
- if ($page eq "") {
- $link = "#" . anchorify( $section );
- } elsif ( $page =~ /::/ ) {
- $page =~ s,::,/,g;
- # Search page cache for an entry keyed under the html page name,
- # then look to see what directory that page might be in. NOTE:
- # this will only find one page. A better solution might be to produce
- # an intermediate page that is an index to all such pages.
- my $page_name = $page ;
- $page_name =~ s,^.*/,,s ;
- if ( defined( $Pages{ $page_name } ) &&
- $Pages{ $page_name } =~ /([^:]*$page)\.(?:pod|pm):/
- ) {
- $page = $1 ;
- }
- else {
- # NOTE: This branch assumes that all A::B pages are located in
- # $Htmlroot/A/B.html . This is often incorrect, since they are
- # often in $Htmlroot/lib/A/B.html or such like. Perhaps we could
- # analyze the contents of %Pages and figure out where any
- # cousins of A::B are, then assume that. So, if A::B isn't found,
- # but A::C is found in lib/A/C.pm, then A::B is assumed to be in
- # lib/A/B.pm. This is also limited, but it's an improvement.
- # Maybe a hints file so that the links point to the correct places
- # nonetheless?
-
- }
- $link = "$Htmlroot/$page.html";
- $link .= "#" . anchorify( $section ) if ($section);
- } elsif (!defined $Pages{$page}) {
- $link = "";
- } else {
- $section = anchorify( $section ) if $section ne "";
- ### print STDERR "...section=$section\n";
-
- # if there is a directory by the name of the page, then assume that an
- # appropriate section will exist in the subdirectory
-# if ($section ne "" && $Pages{$page} =~ /([^:]*[^(\.pod|\.pm)]):/) {
- if ($section ne "" && $Pages{$page} =~ /([^:]*(?<!\.pod)(?<!\.pm)):/) {
- $link = "$Htmlroot/$1/$section.html";
- ### print STDERR "...link=$link\n";
-
- # since there is no directory by the name of the page, the section will
- # have to exist within a .html of the same name. thus, make sure there
- # is a .pod or .pm that might become that .html
- } else {
- $section = "#$section" if $section;
- ### print STDERR "...section=$section\n";
-
- # check if there is a .pod with the page name.
- # for L<Foo>, Foo.(pod|pm) is preferred to A/Foo.(pod|pm)
- if ($Pages{$page} =~ /([^:]*)\.(?:pod|pm):/) {
- $link = "$Htmlroot/$1.html$section";
- } else {
- $link = "";
- }
- }
- }
-
- if ($link) {
- # Here, we take advantage of the knowledge that $Htmlfileurl ne ''
- # implies $Htmlroot eq ''. This means that the link in question
- # needs a prefix of $Htmldir if it begins with '/'. The test for
- # the initial '/' is done to avoid '#'-only links, and to allow
- # for other kinds of links, like file:, ftp:, etc.
- my $url ;
- if ( $Htmlfileurl ne '' ) {
- $link = "$Htmldir$link" if $link =~ m{^/}s;
- $url = relativize_url( $link, $Htmlfileurl );
-# print( " b: [$link,$Htmlfileurl,$url]\n" );
- }
- else {
- $url = $link ;
- }
- return $url;
-
- } else {
- return undef();
- }
-}
-
-#
-# relativize_url - convert an absolute URL to one relative to a base URL.
-# Assumes both end in a filename.
-#
-sub relativize_url {
- my ($dest,$source) = @_ ;
-
- my ($dest_volume,$dest_directory,$dest_file) =
- File::Spec::Unix->splitpath( $dest ) ;
- $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' ) ;
-
- my ($source_volume,$source_directory,$source_file) =
- File::Spec::Unix->splitpath( $source ) ;
- $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' ) ;
-
- my $rel_path = '' ;
- if ( $dest ne '' ) {
- $rel_path = File::Spec::Unix->abs2rel( $dest, $source ) ;
- }
-
- if ( $rel_path ne '' &&
- substr( $rel_path, -1 ) ne '/' &&
- substr( $dest_file, 0, 1 ) ne '#'
- ) {
- $rel_path .= "/$dest_file" ;
- }
- else {
- $rel_path .= "$dest_file" ;
- }
-
- return $rel_path ;
-}
-
-
-#
-# coderef - make URL from the text of a C<>
-#
-sub coderef($$){
- my( $page, $item ) = @_;
- my( $url );
-
- my $fid = fragment_id( $item );
-
- if( defined( $page ) && $page ne "" ){
- # we have been given a $page...
- $page =~ s{::}{/}g;
-
- Carp::confess("Undefined fragment '$item' from fragment_id() in coderef() in $Podfile")
- if !defined $fid;
- # Do we take it? Item could be a section!
- my $base = $Items{$fid} || "";
- $base =~ s{[^/]*/}{};
- if( $base ne "$page.html" ){
- ### print STDERR "coderef( $page, $item ): items{$fid} = $Items{$fid} = $base => discard page!\n";
- $page = undef();
- }
-
- } else {
- # no page - local items precede cached items
- if( defined( $fid ) ){
- if( exists $Local_Items{$fid} ){
- $page = $Local_Items{$fid};
- } else {
- $page = $Items{$fid};
- }
- }
- }
-
- # if there was a pod file that we found earlier with an appropriate
- # =item directive, then create a link to that page.
- if( defined $page ){
- if( $page ){
- if( exists $Pages{$page} and $Pages{$page} =~ /([^:.]*)\.[^:]*:/){
- $page = $1 . '.html';
- }
- my $link = "$Htmlroot/$page#" . anchorify($fid);
-
- # Here, we take advantage of the knowledge that $Htmlfileurl
- # ne '' implies $Htmlroot eq ''.
- if ( $Htmlfileurl ne '' ) {
- $link = "$Htmldir$link" ;
- $url = relativize_url( $link, $Htmlfileurl ) ;
- } else {
- $url = $link ;
- }
- } else {
- $url = "#" . anchorify($fid);
- }
-
- confess "url has space: $url" if $url =~ /"[^"]*\s[^"]*"/;
- }
- return( $url, $fid );
-}
-
-
-
-#
-# Adapted from Nick Ing-Simmons' PodToHtml package.
-sub relative_url {
- my $source_file = shift ;
- my $destination_file = shift;
-
- my $source = URI::file->new_abs($source_file);
- my $uo = URI::file->new($destination_file,$source)->abs;
- return $uo->rel->as_string;
-}
-
-
-#
-# finish_list - finish off any pending HTML lists. this should be called
-# after the entire pod file has been read and converted.
-#
-sub finish_list {
- my $fh = shift;
- if( $Listlevel ){
- warn "$0: $Podfile: unterminated list(s) at =head in paragraph $Paragraph. ignoring.\n" unless $Quiet;
- while( $Listlevel ){
- process_back( $fh );
- }
- }
-}
-
#
# htmlify - converts a pod section specification to a suitable section
# specification for HTML. Note that we keep spaces and special characters
@@ -2082,166 +652,156 @@ sub anchorify {
}
#
-# depod - convert text by eliminating all interior sequences
-# Note: can be called with copy or modify semantics
+# store POD files in %Pages
#
-my %E2c;
-$E2c{lt} = '<';
-$E2c{gt} = '>';
-$E2c{sol} = '/';
-$E2c{verbar} = '|';
-$E2c{amp} = '&'; # in Tk's pods
-
-sub depod1($;$$);
-
-sub depod($){
- my $string;
- if( ref( $_[0] ) ){
- $string = ${$_[0]};
- ${$_[0]} = depod1( \$string );
- } else {
- $string = $_[0];
- depod1( \$string );
- }
-}
+sub _save_page {
+ my ($modspec, $modname) = @_;
-sub depod1($;$$){
- my( $rstr, $func, $closing ) = @_;
- my $res = '';
- return $res unless defined $$rstr;
- if( ! defined( $func ) ){
- # skip to next begin of an interior sequence
- while( $$rstr =~ s/\A(.*?)([BCEFILSXZ])<(<+[^\S\n]+)?//s ){
- # recurse into its text
- $res .= $1 . depod1( $rstr, $2, closing $3);
- }
- $res .= $$rstr;
- } elsif( $func eq 'E' ){
- # E<x> - convert to character
- $$rstr =~ s/^([^>]*)>//;
- $res .= $E2c{$1} || "";
- } elsif( $func eq 'X' ){
- # X<> - ignore
- $$rstr =~ s/^[^>]*>//;
- } elsif( $func eq 'Z' ){
- # Z<> - empty
- $$rstr =~ s/^>//;
- } else {
- # all others: either recurse into new function or
- # terminate at closing angle bracket
- my $term = pattern $closing;
- while( $$rstr =~ s/\A(.*?)(([BCEFILSXZ])<(<+[^\S\n]+)?|$term)//s ){
- $res .= $1;
- last unless $3;
- $res .= depod1( $rstr, $3, closing $4 );
- }
- ## If we're here and $2 ne '>': undelimited interior sequence.
- ## Ignored, as this is called without proper indication of where we are.
- ## Rely on process_text to produce diagnostics.
- }
- return $res;
+ # Remove Podroot from path
+ $modspec = $Podroot eq File::Spec->curdir
+ ? File::Spec->abs2rel($modspec)
+ : File::Spec->abs2rel($modspec,
+ File::Spec->canonpath($Podroot));
+
+ # Convert path to unix style path
+ $modspec = Pod::Html::_unixify($modspec);
+
+ my ($file, $dir) = fileparse($modspec, qr/\.[^.]*/); # strip .ext
+ $Pages{$modname} = $dir.$file;
}
-{
- my %seen; # static fragment record hash
+sub _unixify {
+ my $full_path = shift;
+ return '' unless $full_path;
+ return $full_path if $full_path eq '/';
-sub fragment_id_readable {
- my $text = shift;
- my $generate = shift; # optional flag
+ my ($vol, $dirs, $file) = File::Spec->splitpath($full_path);
+ my @dirs = $dirs eq File::Spec->curdir()
+ ? (File::Spec::Unix->curdir())
+ : File::Spec->splitdir($dirs);
+ if (defined($vol) && $vol) {
+ $vol =~ s/:$// if $^O eq 'VMS';
+ $vol = uc $vol if $^O eq 'MSWin32';
- my $orig = $text;
+ if( $dirs[0] ) {
+ unshift @dirs, $vol;
+ }
+ else {
+ $dirs[0] = $vol;
+ }
+ }
+ unshift @dirs, '' if File::Spec->file_name_is_absolute($full_path);
+ return $file unless scalar(@dirs);
+ $full_path = File::Spec::Unix->catfile(File::Spec::Unix->catdir(@dirs),
+ $file);
+ $full_path =~ s|^\/|| if $^O eq 'MSWin32'; # C:/foo works, /C:/foo doesn't
+ return $full_path;
+}
- # leave the words for the fragment identifier,
- # change everything else to underbars.
- $text =~ s/[^A-Za-z0-9_]+/_/g; # do not use \W to avoid locale dependency.
- $text =~ s/_{2,}/_/g;
- $text =~ s/\A_//;
- $text =~ s/_\Z//;
+package Pod::Simple::XHTML::LocalPodLinks;
+use strict;
+use warnings;
+use base 'Pod::Simple::XHTML';
- unless ($text)
- {
- # Nothing left after removing punctuation, so leave it as is
- # E.g. if option is named: "=item -#"
+use File::Spec;
+use File::Spec::Unix;
- $text = $orig;
- }
+__PACKAGE__->_accessorize(
+ 'htmldir',
+ 'htmlfileurl',
+ 'htmlroot',
+ 'pages', # Page name => relative/path/to/page from root POD dir
+ 'quiet',
+ 'verbose',
+);
+
+sub resolve_pod_page_link {
+ my ($self, $to, $section) = @_;
+
+ return undef unless defined $to || defined $section;
+ if (defined $section) {
+ $section = '#' . $self->idify($section, 1);
+ return $section unless defined $to;
+ } else {
+ $section = '';
+ }
+
+ my $path; # path to $to according to %Pages
+ unless (exists $self->pages->{$to}) {
+ # Try to find a POD that ends with $to and use that.
+ # e.g., given L<XHTML>, if there is no $Podpath/XHTML in %Pages,
+ # look for $Podpath/*/XHTML in %Pages, with * being any path,
+ # as a substitute (e.g., $Podpath/Pod/Simple/XHTML)
+ my @matches;
+ foreach my $modname (keys %{$self->pages}) {
+ push @matches, $modname if $modname =~ /::\Q$to\E\z/;
+ }
- if ($generate) {
- if ( exists $seen{$text} ) {
- # This already exists, make it unique
- $seen{$text}++;
- $text = $text . $seen{$text};
+ if ($#matches == -1) {
+ warn "Cannot find \"$to\" in podpath: " .
+ "cannot find suitable replacement path, cannot resolve link\n"
+ unless $self->quiet;
+ return '';
+ } elsif ($#matches == 0) {
+ warn "Cannot find \"$to\" in podpath: " .
+ "using $matches[0] as replacement path to $to\n"
+ unless $self->quiet;
+ $path = $self->pages->{$matches[0]};
} else {
- $seen{$text} = 1; # first time seen this fragment
+ warn "Cannot find \"$to\" in podpath: " .
+ "more than one possible replacement path to $to, " .
+ "using $matches[-1]\n" unless $self->quiet;
+ # Use [-1] so newer (higher numbered) perl PODs are used
+ $path = $self->pages->{$matches[-1]};
}
+ } else {
+ $path = $self->pages->{$to};
}
- $text;
-}}
-
-my @HC;
-sub fragment_id_obfuscated { # This was the old "_2d_2d__"
- my $text = shift;
- my $generate = shift; # optional flag
+ my $url = File::Spec::Unix->catfile(Pod::Html::_unixify($self->htmlroot),
+ $path);
- # text? Normalize by obfuscating the fragment id to make it unique
- $text =~ s/\s+/_/sg;
-
- $text =~ s{(\W)}{
- defined( $HC[ord($1)] ) ? $HC[ord($1)]
- : ( $HC[ord($1)] = sprintf( "%%%02X", ord($1) ) ) }gxe;
- $text = substr( $text, 0, 50 );
+ if ($self->htmlfileurl ne '') {
+ # then $self->htmlroot eq '' (by definition of htmlfileurl) so
+ # $self->htmldir needs to be prepended to link to get the absolute path
+ # that will be relativized
+ $url = relativize_url(
+ File::Spec::Unix->catdir(Pod::Html::_unixify($self->htmldir), $url),
+ $self->htmlfileurl # already unixified
+ );
+ }
- $text;
+ return $url . ".html$section";
}
#
-# fragment_id - construct a fragment identifier from:
-# a) =item text
-# b) contents of C<...>
+# relativize_url - convert an absolute URL to one relative to a base URL.
+# Assumes both end in a filename.
#
+sub relativize_url {
+ my ($dest, $source) = @_;
-sub fragment_id {
- my $text = shift;
- my $generate = shift; # optional flag
-
- $text =~ s/\s+\Z//s;
- if( $text ){
- # a method or function?
- return $1 if $text =~ /(\w+)\s*\(/;
- return $1 if $text =~ /->\s*(\w+)\s*\(?/;
-
- # a variable name?
- return $1 if $text =~ /^([\$\@%*]\S+)/;
-
- # some pattern matching operator?
- return $1 if $text =~ m|^(\w+/).*/\w*$|;
+ # Remove each file from its path
+ my ($dest_volume, $dest_directory, $dest_file) =
+ File::Spec::Unix->splitpath( $dest );
+ $dest = File::Spec::Unix->catpath( $dest_volume, $dest_directory, '' );
- # fancy stuff... like "do { }"
- return $1 if $text =~ m|^(\w+)\s*{.*}$|;
+ my ($source_volume, $source_directory, $source_file) =
+ File::Spec::Unix->splitpath( $source );
+ $source = File::Spec::Unix->catpath( $source_volume, $source_directory, '' );
- # honour the perlfunc manpage: func [PAR[,[ ]PAR]...]
- # and some funnies with ... Module ...
- return $1 if $text =~ m{^([a-z\d_]+)(\s+[A-Z,/& ][A-Z\d,/& ]*)?$};
- return $1 if $text =~ m{^([a-z\d]+)\s+Module(\s+[A-Z\d,/& ]+)?$};
+ my $rel_path = '';
+ if ($dest ne '') {
+ $rel_path = File::Spec::Unix->abs2rel( $dest, $source );
+ }
- return fragment_id_readable($text, $generate);
+ if ($rel_path ne '' && substr( $rel_path, -1 ) ne '/') {
+ $rel_path .= "/$dest_file";
} else {
- return;
+ $rel_path .= "$dest_file";
}
-}
-#
-# make_URL_href - generate HTML href from URL
-# Special treatment for CGI queries.
-#
-sub make_URL_href($){
- my( $url ) = @_;
- if( $url !~
- s{^(http:[-\w/#~:.+=&%@!]+)(\?.*)$}{<a href="$1$2">$1</a>}i ){
- $url = "<a href=\"$url\">$url</a>";
- }
- return $url;
+ return $rel_path;
}
1;
diff --git a/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm b/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm
index 13a86188bcb..2ed71fa2551 100644
--- a/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm
@@ -12,7 +12,7 @@ package Pod::InputObjects;
use strict;
use vars qw($VERSION);
-$VERSION = '1.31'; ## Current version of this package
+$VERSION = '1.51'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
@@ -39,10 +39,10 @@ This module defines some basic input objects used by B<Pod::Parser> when
reading and parsing POD text from an input source. The following objects
are defined:
-=over 4
-
=begin __PRIVATE__
+=over 4
+
=item package B<Pod::InputSource>
An object corresponding to a source of POD input text. It is mostly a
@@ -50,8 +50,12 @@ wrapper around a filehandle or C<IO::Handle>-type object (or anything
that implements the C<getline()> method) which keeps track of some
additional information relevant to the parsing of PODs.
+=back
+
=end __PRIVATE__
+=over 4
+
=item package B<Pod::Paragraph>
An object corresponding to a paragraph of POD input text. It may be a
@@ -923,6 +927,8 @@ sub DESTROY {
=head1 SEE ALSO
+B<Pod::InputObjects> is part of the L<Pod::Parser> distribution.
+
See L<Pod::Parser>, L<Pod::Select>
=head1 AUTHOR
diff --git a/Master/tlpkg/tlperl/lib/Pod/LaTeX.pm b/Master/tlpkg/tlperl/lib/Pod/LaTeX.pm
index 6404b27f578..f4b1aaf97b9 100644
--- a/Master/tlpkg/tlperl/lib/Pod/LaTeX.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/LaTeX.pm
@@ -33,7 +33,7 @@ use Carp;
use vars qw/ $VERSION %HTML_Escapes @LatexSections /;
-$VERSION = '0.59';
+$VERSION = '0.60';
# Definitions of =headN -> latex mapping
@LatexSections = (qw/
@@ -263,7 +263,7 @@ $VERSION = '0.59';
'prod' => q|$\prod$|, # n-ary product = product sign
# prod is NOT the same character as 'greek capital letter pi' though the
# same glyph might be used for both
- 'sum' => q|$\sum$|, # n-ary sumation
+ 'sum' => q|$\sum$|, # n-ary summation
# sum is NOT the same character as 'greek capital letter sigma' though
# the same glyph might be used for both
'minus' => q|$-$|, # minus sign
@@ -414,7 +414,7 @@ sub initialize {
$self->{StartWithNewPage} = 0 # Start new page for pod section
unless exists $self->{StartWithNewPage};
$self->{TableOfContents} = 0 # Add table of contents
- unless exists $self->{TableOfContents}; # only relevent if AddPreamble=1
+ unless exists $self->{TableOfContents}; # only relevant if AddPreamble=1
$self->{AddPostamble} = 1 # Add closing latex code at end
unless exists $self->{AddPostamble}; # effectively end{document} and index
$self->{MakeIndex} = 1 # Add index (only relevant AddPostamble
@@ -446,7 +446,7 @@ sub initialize {
$self->{Label} = undef # label to be used as prefix
unless exists $self->{Label}; # to all internal section names
- # These allow the caller to add arbritrary latex code to
+ # These allow the caller to add arbitrary latex code to
# start and end of document. AddPreamble and AddPostamble are ignored
# if these are set.
# Also MakeIndex and TableOfContents are also ignored.
@@ -1057,7 +1057,7 @@ sub command {
} else {
# Suppress all subsequent paragraphs unless
- # it is explcitly intended for latex
+ # it is explicitly intended for latex
$self->{_suppress_all_para} = 1;
}
@@ -1382,7 +1382,7 @@ sub end_list {
# What to write depends on list type
my $type = $self->lists->[-1]->type;
- # Dont write anything if the list type is not set
+ # Don't write anything if the list type is not set
# iomplying that a list was created but no entries were
# placed in it (eg because of a =begin/=end combination)
$self->_output("\\end{$type}\n")
@@ -1418,7 +1418,7 @@ sub add_item {
return;
}
- # If paragraphs printing is turned off via =begin/=end or whatver
+ # If paragraphs printing is turned off via =begin/=end or whatever
# simply return immediately
return if $self->{_suppress_all_para};
@@ -1621,6 +1621,10 @@ sub _replace_special_chars {
# Now add the dollars around each \backslash
$paragraph =~ s/(\\backslash)/\$$1\$/g;
+
+ # Convert ------ to -{}-{}-{}-{}-{}-
+ $paragraph =~ s/-(?=-)/-{}/g;
+
return $paragraph;
}
diff --git a/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm b/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm
index f3c7ef46779..3c74d786801 100644
--- a/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm
@@ -11,7 +11,7 @@ package Pod::ParseUtils;
use strict;
use vars qw($VERSION);
-$VERSION = '1.36'; ## Current version of this package
+$VERSION = '1.51'; ## Current version of this package
require 5.005; ## requires this Perl version or later
=head1 NAME
@@ -845,6 +845,8 @@ Marek Rouchal E<lt>marekr@cpan.orgE<gt>, borrowing
a lot of things from L<pod2man> and L<pod2roff> as well as other POD
processing tools by Tom Christiansen, Brad Appleton and Russ Allbery.
+B<Pod::ParseUtils> is part of the L<Pod::Parser> distribution.
+
=head1 SEE ALSO
L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>,
diff --git a/Master/tlpkg/tlperl/lib/Pod/Parser.pm b/Master/tlpkg/tlperl/lib/Pod/Parser.pm
index c807f3fbade..9a6acd62f18 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Parser.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Parser.pm
@@ -12,7 +12,7 @@ use strict;
## These "variables" are used as local "glob aliases" for performance
use vars qw($VERSION @ISA %myData %myOpts @input_stack);
-$VERSION = '1.37'; ## Current version of this package
+$VERSION = '1.51'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
@@ -778,11 +778,11 @@ sub parse_text {
## Iterate over all sequence starts text (NOTE: split with
## capturing parens keeps the delimiters)
$_ = $text;
- my @tokens = split /([A-Z]<(?:<+\s)?)/;
+ my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/;
while ( @tokens ) {
$_ = shift @tokens;
## Look for the beginning of a sequence
- if ( /^([A-Z])(<(?:<+\s)?)$/ ) {
+ if ( /^([A-Z])(<(?:<+(?:\r?\n|[ \t]))?)$/ ) {
## Push a new sequence onto the stack of those "in-progress"
my $ldelim_orig;
($cmd, $ldelim_orig) = ($1, $2);
@@ -840,7 +840,7 @@ sub parse_text {
$seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_);
}
## Keep track of line count
- $line += s/\r*\n//;
+ $line += /\n/;
## Remember the "current" sequence
$seq = $seq_stack[-1];
}
@@ -963,6 +963,8 @@ sub parse_paragraph {
$pfx = $1;
$_ = substr($text, length $pfx);
($cmd, $sep, $text) = split /(\s+)/, $_, 2;
+ $sep = '' unless defined $sep;
+ $text = '' unless defined $text;
## If this is a "cut" directive then we dont need to do anything
## except return to "cutting" mode.
if ($cmd eq 'cut') {
@@ -1016,7 +1018,8 @@ sub parse_paragraph {
}
# Update the whitespace for the next time around
- $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0;
+ #$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0;
+ $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0;
return 1;
}
@@ -1096,7 +1099,7 @@ sub parse_from_filehandle {
## See if this line is blank and ends the current paragraph.
## If it isnt, then keep iterating until it is.
- next unless (($textline =~ /^([^\S\r\n]*)[\r\n]*$/)
+ next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/)
&& (length $paragraph));
## Now process the paragraph
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm
index 083a6e907e1..a0dd24addc2 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc.pm
@@ -1,18 +1,19 @@
+use 5.006; # we use some open(X, "<", $y) syntax
-require 5;
-use 5.006; # we use some open(X, "<", $y) syntax
package Pod::Perldoc;
use strict;
use warnings;
use Config '%Config';
use Fcntl; # for sysopen
+use File::Basename qw(basename);
use File::Spec::Functions qw(catfile catdir splitdir);
use vars qw($VERSION @Pagers $Bindir $Pod2man
$Temp_Files_Created $Temp_File_Lifetime
);
-$VERSION = '3.15_04';
+$VERSION = '3.17';
+
#..........................................................................
BEGIN { # Make a DEBUG constant very first thing...
@@ -27,6 +28,32 @@ BEGIN { # Make a DEBUG constant very first thing...
}
use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
+use Carp qw(croak carp);
+
+# these are also in BaseTo, which I don't want to inherit
+sub debugging {
+ my $self = shift;
+
+ ( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() )
+ }
+
+sub debug {
+ my( $self, @messages ) = @_;
+ return unless $self->debugging;
+ print STDERR map { "DEBUG : $_" } @messages;
+ }
+
+sub warn {
+ my( $self, @messages ) = @_;
+
+ carp( join "\n", @messages, '' );
+ }
+
+sub die {
+ my( $self, @messages ) = @_;
+
+ croak( join "\n", @messages, '' );
+ }
#..........................................................................
@@ -35,13 +62,13 @@ sub FALSE () {return}
sub BE_LENIENT () {1}
BEGIN {
- *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS;
- *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
- *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
- *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
- *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_vms = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &is_vms;
+ *is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32;
+ *is_dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &is_dos;
+ *is_os2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &is_os2;
+ *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;
}
$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
@@ -52,7 +79,7 @@ $Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
#..........................................................................
{ my $pager = $Config{'pager'};
- push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
+ push @Pagers, $pager if -x (split /\s+/, $pager)[0] or __PACKAGE__->is_vms;
}
$Bindir = $Config{'scriptdirexp'};
$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
@@ -83,7 +110,7 @@ sub opt_w_with { # Specify an option for the formatter subclass
$option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar"
$self->add_formatter_option( $option, $option_value );
} else {
- warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n";
+ $self->warn( qq("$value" isn't a good formatter option name. I'm ignoring it!\n ) );
}
return;
}
@@ -99,17 +126,17 @@ sub opt_M_with { # specify formatter class name(s)
# A mildly restrictive concept of what modulenames are valid.
push @classes_to_add, $1; # untaint
} else {
- warn "\"$classname\" isn't a valid classname. Ignoring.\n";
+ $self->warn( qq("$classname" isn't a valid classname. Ignoring.\n) );
}
}
-
+
unshift @{ $self->{'formatter_classes'} }, @classes_to_add;
-
+
DEBUG > 3 and print(
"Adding @classes_to_add to the list of formatter classes, "
. "making them @{ $self->{'formatter_classes'} }.\n"
);
-
+
return;
}
@@ -119,9 +146,9 @@ sub opt_V { # report version and exit
(defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
? (" (win32 build ", &Win32::BuildNumber(), ")") : (),
-
+
(chr(65) eq 'A') ? () : " (non-ASCII)",
-
+
"\n",
;
exit;
@@ -152,14 +179,14 @@ sub opt_o_with { # "o" for output format
if($rest =~ m/^(\w+)$/s) {
$rest = $1; #untaint
} else {
- warn "\"$rest\" isn't a valid output format. Skipping.\n";
+ $self->warn( qq("$rest" isn't a valid output format. Skipping.\n") );
return;
}
-
+
$self->aside("Noting \"$rest\" as desired output format...\n");
-
+
# Figure out what class(es) that could actually mean...
-
+
my @classes;
foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
# Messy but smart:
@@ -168,10 +195,10 @@ sub opt_o_with { # "o" for output format
"\L$rest", "\L\u$rest", "\U$rest" # And then try variations
) {
+ $self->aside("Considering $prefix$stem\n");
push @classes, $prefix . $stem;
- #print "Considering $prefix$stem\n";
}
-
+
# Tidier, but misses too much:
#push @classes, $prefix . ucfirst(lc($rest));
}
@@ -233,27 +260,27 @@ sub aside { # If we're in -D or DEBUG mode, say this.
sub usage {
my $self = shift;
- warn "@_\n" if @_;
-
+ $self->warn( "@_\n" ) if @_;
+
# Erase evidence of previous errors (if any), so exit status is simple.
$! = 0;
-
- die <<EOF;
-perldoc [options] PageName|ModuleName|ProgramName...
+
+ CORE::die( <<EOF );
+perldoc [options] PageName|ModuleName|ProgramName|URL...
perldoc [options] -f BuiltinFunction
perldoc [options] -q FAQRegex
perldoc [options] -v PerlVariable
Options:
-h Display this help message
- -V report version
+ -V Report version
-r Recursive search (slow)
-i Ignore case
- -t Display pod using pod2text instead of pod2man and nroff
+ -t Display pod using pod2text instead of Pod::Man and groff
(-t is the default on win32 unless -n is specified)
-u Display unformatted pod text
-m Display module's file in its entirety
- -n Specify replacement for nroff
+ -n Specify replacement for groff
-l Display the module's file name
-F Arguments are file names, not modules
-D Verbosely describe what's going on
@@ -263,20 +290,21 @@ Options:
-M FormatterModuleNameToUse
-w formatter_option:option_value
-L translation_code Choose doc translation (if any)
- -X use index if present (looks for pod.idx at $Config{archlib})
+ -X Use index if present (looks for pod.idx at $Config{archlib})
-q Search the text of questions (not answers) in perlfaq[1-9]
-f Search Perl built-in functions
-v Search predefined Perl variables
-PageName|ModuleName...
+PageName|ModuleName|ProgramName|URL...
is the name of a piece of documentation that you want to look at. You
may either give a descriptive name of the page (as in the case of
`perlfunc') the name of a module, either like `Term::Info' or like
- `Term/Info', or the name of a program, like `perldoc'.
+ `Term/Info', or the name of a program, like `perldoc', or a URL
+ starting with http(s).
BuiltinFunction
is the name of a perl function. Will extract documentation from
- `perlfunc'.
+ `perlfunc' or `perlop'.
FAQRegex
is a regex. Will search perlfaq[1-9] for and extract any
@@ -292,18 +320,87 @@ EOF
#..........................................................................
+sub program_name {
+ my( $self ) = @_;
+
+ if( my $link = readlink( $0 ) ) {
+ $self->debug( "The value in $0 is a symbolic link to $link\n" );
+ }
+
+ my $basename = basename( $0 );
+
+ $self->debug( "\$0 is [$0]\nbasename is [$basename]\n" );
+ # possible name forms
+ # perldoc
+ # perldoc-v5.14
+ # perldoc-5.14
+ # perldoc-5.14.2
+ # perlvar # an alias mentioned in Camel 3
+ {
+ my( $untainted ) = $basename =~ m/(
+ \A
+ perl
+ (?: doc | func | faq | help | op | toc | var # Camel 3
+ )
+ (?: -? v? \d+ \. \d+ (?:\. \d+)? )? # possible version
+ (?: \. (?: bat | exe | com ) )? # possible extension
+ \z
+ )
+ /x;
+
+ $self->debug($untainted);
+ return $untainted if $untainted;
+ }
+
+ $self->warn(<<"HERE");
+You called the perldoc command with a name that I didn't recognize.
+This might mean that someone is tricking you into running a
+program you don't intend to use, but it also might mean that you
+created your own link to perldoc. I think your program name is
+[$basename].
+
+I'll allow this if the filename only has [a-zA-Z0-9._-].
+HERE
+
+ {
+ my( $untainted ) = $basename =~ m/(
+ \A [a-zA-Z0-9._-]+ \z
+ )/x;
+
+ $self->debug($untainted);
+ return $untainted if $untainted;
+ }
+
+ $self->die(<<"HERE");
+I think that your name for perldoc is potentially unsafe, so I'm
+going to disallow it. I'd rather you be safe than sorry. If you
+intended to use the name I'm disallowing, please tell the maintainers
+about it. Write to:
+
+ Pod-Perldoc\@rt.cpan.org
+
+HERE
+}
+
+#..........................................................................
+
sub usage_brief {
- my $me = $0; # Editing $0 is unportable
+ my $self = shift;
+ my $program_name = $self->program_name;
+
+ CORE::die( <<"EOUSAGE" );
+Usage: $program_name [-hVriDtumFXlT] [-n nroffer_program]
+ [-d output_filename] [-o output_format] [-M FormatterModule]
+ [-w formatter_option:option_value] [-L translation_code]
+ PageName|ModuleName|ProgramName
+
+Examples:
- $me =~ s,.*[/\\],,; # get basename
-
- die <<"EOUSAGE";
-Usage: $me [-h] [-V] [-r] [-i] [-D] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName
- $me -f PerlFunc
- $me -q FAQKeywords
- $me -v PerlVar
+ $program_name -f PerlFunc
+ $program_name -q FAQKeywords
+ $program_name -v PerlVar
-The -h option prints more help. Also try "perldoc perldoc" to get
+The -h option prints more help. Also try "$program_name perldoc" to get
acquainted with the system. [Perldoc v$VERSION]
EOUSAGE
@@ -311,7 +408,7 @@ EOUSAGE
#..........................................................................
-sub pagers { @{ shift->{'pagers'} } }
+sub pagers { @{ shift->{'pagers'} } }
#..........................................................................
@@ -335,8 +432,8 @@ sub init {
$self->{'args'} ||= \@ARGV;
$self->{'found'} ||= [];
$self->{'temp_file_list'} ||= [];
-
-
+
+
$self->{'target'} = undef;
$self->init_formatter_class_list;
@@ -373,7 +470,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('man') unless IS_MSWin32 || IS_Dos
+ $self->opt_o_with('man') unless $self->is_mswin32 || $self->is_dos
|| !($ENV{TERM} && (
($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
));
@@ -403,14 +500,14 @@ sub process {
# TODO: make it deal with being invoked as various different things
# such as perlfaq".
-
+
return $self->usage_brief unless @{ $self->{'args'} };
$self->pagers_guessing;
$self->options_reading;
$self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION);
$self->drop_privs_maybe;
$self->options_processing;
-
+
# Hm, we have @pages and @found, but we only really act on one
# file per call, with the exception of the opt_q hack, and with
# -l things
@@ -419,7 +516,7 @@ sub process {
my @pages;
$self->{'pages'} = \@pages;
- if( $self->opt_f) { @pages = ("perlfunc") }
+ if( $self->opt_f) { @pages = qw(perlfunc perlop) }
elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") }
elsif( $self->opt_v) { @pages = ("perlvar") }
else { @pages = @{$self->{'args'}};
@@ -434,11 +531,11 @@ sub process {
$self->maybe_diddle_INC();
# for when we're apparently in a module or extension directory
-
+
my @found = $self->grand_search_init(\@pages);
- exit (IS_VMS ? 98962 : 1) unless @found;
-
- if ($self->opt_l) {
+ exit ($self->is_vms ? 98962 : 1) unless @found;
+
+ if ($self->opt_l and not $self->opt_q ) {
DEBUG and print "We're in -l mode, so byebye after this:\n";
print join("\n", @found), "\n";
return;
@@ -459,8 +556,8 @@ my( %class_seen, %class_loaded );
sub find_good_formatter_class {
my $self = $_[0];
my @class_list = @{ $self->{'formatter_classes'} || [] };
- die "WHAT? Nothing in the formatter class list!?" unless @class_list;
-
+ $self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list;
+
my $good_class_found;
foreach my $c (@class_list) {
DEBUG > 4 and print "Trying to load $c...\n";
@@ -469,22 +566,22 @@ sub find_good_formatter_class {
$good_class_found = $c;
last;
}
-
+
if($class_seen{$c}) {
DEBUG > 4 and print
"I've tried $c before, and it's no good. Skipping.\n";
next;
}
-
+
$class_seen{$c} = 1;
-
+
if( $c->can('parse_from_file') ) {
DEBUG > 4 and print
"Interesting, the formatter class $c is already loaded!\n";
-
+
} elsif(
- (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2)
- # the alway case-insensitive fs's
+ ( $self->is_os2 or $self->is_mswin32 or $self->is_dos or $self->is_os2)
+ # the always case-insensitive filesystems
and $class_seen{lc("~$c")}++
) {
DEBUG > 4 and print
@@ -508,7 +605,7 @@ sub find_good_formatter_class {
next;
}
}
-
+
if( $c->can('parse_from_file') ) {
DEBUG > 4 and print "Settling on $c\n";
my $v = $c->VERSION;
@@ -520,13 +617,13 @@ sub find_good_formatter_class {
DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n";
}
}
-
- die "Can't find any loadable formatter class in @class_list?!\nAborting"
+
+ $self->die( "Can't find any loadable formatter class in @class_list?!\nAborting" )
unless $good_class_found;
-
+
$self->{'formatter_class'} = $good_class_found;
$self->aside("Will format with the class $good_class_found\n");
-
+
return;
}
@@ -536,8 +633,8 @@ sub find_good_formatter_class {
sub formatter_sanity_check {
my $self = shift;
my $formatter_class = $self->{'formatter_class'}
- || die "NO FORMATTER CLASS YET!?";
-
+ || $self->die( "NO FORMATTER CLASS YET!?" );
+
if(!$self->opt_T # so -T can FORCE sending to STDOUT
and $formatter_class->can('is_pageable')
and !$formatter_class->is_pageable
@@ -548,11 +645,12 @@ sub formatter_sanity_check {
&& $formatter_class->output_extension
) || '';
$ext = ".$ext" if length $ext;
-
- die
+
+ my $me = $self->program_name;
+ $self->die(
"When using Perldoc to format with $formatter_class, you have to\n"
. "specify -T or -dsomefile$ext\n"
- . "See `perldoc perldoc' for more information on those switches.\n"
+ . "See `$me perldoc' for more information on those switches.\n" )
;
}
}
@@ -561,18 +659,18 @@ sub formatter_sanity_check {
sub render_and_page {
my($self, $found_list) = @_;
-
+
$self->maybe_generate_dynamic_pod($found_list);
my($out, $formatter) = $self->render_findings($found_list);
-
+
if($self->opt_d) {
printf "Perldoc (%s) output saved to %s\n",
$self->{'formatter_class'} || ref($self),
$out;
print "But notice that it's 0 bytes long!\n" unless -s $out;
-
-
+
+
} elsif( # Allow the formatter to "page" itself, if it wants.
$formatter->can('page_for_perldoc')
and do {
@@ -587,25 +685,25 @@ sub render_and_page {
}
) {
# Do nothing, since the formatter has "paged" it for itself.
-
+
} else {
# Page it normally (internally)
-
+
if( -s $out ) { # Usual case:
$self->page($out, $self->{'output_to_stdout'}, $self->pagers);
-
+
} else {
# Odd case:
$self->aside("Skipping $out (from $$found_list[0] "
. "via $$self{'formatter_class'}) as it is 0-length.\n");
-
+
push @{ $self->{'temp_file_list'} }, $out;
$self->unlink_if_temp_file($out);
}
}
-
+
$self->after_rendering(); # any extra cleanup or whatever
-
+
return;
}
@@ -613,7 +711,7 @@ sub render_and_page {
sub options_reading {
my $self = shift;
-
+
if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) {
require Text::ParseWords;
$self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n");
@@ -636,7 +734,7 @@ sub options_reading {
and print " Args after switch processing: @{$self->{'args'}}\n";
return $self->usage if $self->opt_h;
-
+
return;
}
@@ -644,7 +742,7 @@ sub options_reading {
sub options_processing {
my $self = shift;
-
+
if ($self->opt_X) {
my $podidx = "$Config{'archlib'}/pod.idx";
$podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
@@ -655,8 +753,11 @@ sub options_processing {
$self->options_sanity;
- $self->opt_n("nroff") unless $self->opt_n;
- $self->add_formatter_option( '__nroffer' => $self->opt_n );
+ # This used to set a default, but that's now moved into any
+ # formatter that cares to have a default.
+ if( $self->opt_n ) {
+ $self->add_formatter_option( '__nroffer' => $self->opt_n );
+ }
# Get language from PERLDOC_POD2 environment variable
if ( ! $self->opt_L && $ENV{PERLDOC_POD2} ) {
@@ -689,19 +790,19 @@ sub options_sanity {
#;
#
#$self->usage("only one of -t, -u, -m or -l") if $opts > 1;
-
-
+
+
# Any sanity-checking need doing here?
-
- # But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
- if( $self->opt_f or $self->opt_q ) {
- $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
- warn
- "Perldoc is only really meant for reading one word at a time.\n",
- "So these parameters are being ignored: ",
- join(' ', @{$self->{'args'}}),
- "\n"
- if @{$self->{'args'}}
+
+ # But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
+ if( $self->opt_f or $self->opt_q ) {
+ $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
+ $self->warn(
+ "Perldoc is only really meant for reading one word at a time.\n",
+ "So these parameters are being ignored: ",
+ join(' ', @{$self->{'args'}}),
+ "\n" )
+ if @{$self->{'args'}}
}
return;
}
@@ -712,6 +813,24 @@ sub grand_search_init {
my($self, $pages, @found) = @_;
foreach (@$pages) {
+ if (/^http(s)?:\/\//) {
+ require HTTP::Tiny;
+ require File::Temp;
+ my $response = HTTP::Tiny->new->get($_);
+ if ($response->{success}) {
+ my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1);
+ $fh->print($response->{content});
+ push @found, $filename;
+ ($self->{podnames}{$filename} =
+ m{.*/([^/#?]+)} ? uc $1 : "UNKNOWN")
+ =~ s/\.P(?:[ML]|OD)\z//;
+ }
+ else {
+ print STDERR "No " .
+ ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
+ }
+ next;
+ }
if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) {
my $searchfor = catfile split '::', $_;
$self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" );
@@ -720,7 +839,7 @@ sub grand_search_init {
chomp;
push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
}
- close(PODIDX) or die "Can't close $$self{'podidx'}: $!";
+ close(PODIDX) or $self->die( "Can't close $$self{'podidx'}: $!" );
next;
}
@@ -728,7 +847,7 @@ sub grand_search_init {
if ($self->opt_F) {
next unless -r;
- push @found, $_ if $self->opt_m or $self->containspod($_);
+ push @found, $_ if $self->opt_l or $self->opt_m or $self->containspod($_);
next;
}
@@ -741,7 +860,7 @@ sub grand_search_init {
# for executables, like h2xs or perldoc itself.
push @searchdirs, ($self->{'bindir'}, @INC);
unless ($self->opt_m) {
- if (IS_VMS) {
+ if ($self->is_vms) {
my($i,$trn);
for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
push(@searchdirs,$trn);
@@ -758,7 +877,7 @@ sub grand_search_init {
$self->aside( "Found as @files\n" );
}
# add "perl" prefix, so "perldoc foo" may find perlfoo.pod
- elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) {
+ elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) {
$self->aside( "Loosely found as @files\n" );
}
else {
@@ -773,14 +892,15 @@ sub grand_search_init {
($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n";
if ( @{ $self->{'found'} } ) {
print STDERR "However, try\n";
+ my $me = $self->program_name;
for my $dir (@{ $self->{'found'} }) {
- opendir(DIR, $dir) or die "opendir $dir: $!";
+ opendir(DIR, $dir) or $self->die( "opendir $dir: $!" );
while (my $file = readdir(DIR)) {
next if ($file =~ /^\./s);
$file =~ s/\.(pm|pod)\z//; # XXX: badfs
- print STDERR "\tperldoc $_\::$file\n";
+ print STDERR "\t$me $_\::$file\n";
}
- closedir(DIR) or die "closedir $dir: $!";
+ closedir(DIR) or $self->die( "closedir $dir: $!" );
}
}
}
@@ -795,11 +915,11 @@ sub grand_search_init {
sub maybe_generate_dynamic_pod {
my($self, $found_things) = @_;
my @dynamic_pod;
-
+
$self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
$self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v;
-
+
$self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v ) {
@@ -807,22 +927,22 @@ sub maybe_generate_dynamic_pod {
} elsif ( @dynamic_pod ) {
$self->aside("Hm, I found some Pod from that search!\n");
my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
-
+
push @{ $self->{'temp_file_list'} }, $buffer;
# I.e., it MIGHT be deleted at the end.
-
- my $in_list = $self->opt_f || $self->opt_v;
+
+ my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v;
print $buffd "=over 8\n\n" if $in_list;
- print $buffd @dynamic_pod or die "Can't print $buffer: $!";
+ print $buffd @dynamic_pod or $self->die( "Can't print $buffer: $!" );
print $buffd "=back\n" if $in_list;
- close $buffd or die "Can't close $buffer: $!";
-
+ close $buffd or $self->die( "Can't close $buffer: $!" );
+
@$found_things = $buffer;
# Yes, so found_things never has more than one thing in
# it, by time we leave here
-
+
$self->add_formatter_option('__filter_nroff' => 1);
} else {
@@ -835,13 +955,21 @@ sub maybe_generate_dynamic_pod {
#..........................................................................
+sub not_dynamic {
+ my ($self,$value) = @_;
+ $self->{__not_dynamic} = $value if @_ == 2;
+ return $self->{__not_dynamic};
+}
+
+#..........................................................................
+
sub add_formatter_option { # $self->add_formatter_option('key' => 'value');
my $self = shift;
push @{ $self->{'formatter_switches'} }, [ @_ ] if @_;
DEBUG > 3 and printf "Formatter switches now: [%s]\n",
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
-
+
return;
}
@@ -854,12 +982,12 @@ sub new_translator { # $tr = $self->new_translator($lang);
my $pack = 'POD2::' . uc($lang);
eval "require $pack";
if ( !$@ && $pack->can('new') ) {
- return $pack->new();
+ return $pack->new();
}
eval { require POD2::Base };
return if $@;
-
+
return POD2::Base->new({ lang => $lang });
}
@@ -876,7 +1004,7 @@ sub add_translator { # $self->add_translator($lang);
$self->aside( "translator for '$lang' loaded\n" );
} else {
# non-installed or bad translator package
- warn "Perldoc cannot load translator package for '$lang': ignored\n";
+ $self->warn( "Perldoc cannot load translator package for '$lang': ignored\n" );
}
}
@@ -891,23 +1019,23 @@ sub search_perlvar {
my $opt = $self->opt_v;
if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) {
- die "'$opt' does not look like a Perl variable\n";
+ CORE::die( "'$opt' does not look like a Perl variable\n" );
}
DEBUG > 2 and print "Search: @$found_things\n";
-
+
my $perlvar = shift @$found_things;
open(PVAR, "<", $perlvar) # "Funk is its own reward"
- or die("Can't open $perlvar: $!");
+ or $self->die("Can't open $perlvar: $!");
- if ( $opt =~ /^\$\d+$/ ) { # handle $1, $2, ..., $9
+ if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ...
$opt = '$<I<digits>>';
}
my $search_re = quotemeta($opt);
DEBUG > 2 and
print "Going to perlvar-scan for $search_re in $perlvar\n";
-
+
# Skip introduction
local $_;
while (<PVAR>) {
@@ -930,13 +1058,13 @@ sub search_perlvar {
elsif (!/^\s+$/) { # not a blank line
if ( $found ) {
$inheader = 0; # don't accept more =item (unless inlist)
- }
+ }
else {
@$pod = (); # reset
$inheader = 1; # start over
next;
}
- }
+ }
if (/^=over/) {
++$inlist;
@@ -950,15 +1078,68 @@ sub search_perlvar {
}
@$pod = () unless $found;
if (!@$pod) {
- die "No documentation for perl variable '$opt' found\n";
+ CORE::die( "No documentation for perl variable '$opt' found\n" );
}
- close PVAR or die "Can't open $perlvar: $!";
+ close PVAR or $self->die( "Can't open $perlvar: $!" );
return;
}
#..........................................................................
+sub search_perlop {
+ my ($self,$found_things,$pod) = @_;
+
+ $self->not_dynamic( 1 );
+
+ my $perlop = shift @$found_things;
+ open( PERLOP, '<', $perlop ) or $self->die( "Can't open $perlop: $!" );
+
+ my $paragraph = "";
+ my $has_text_seen = 0;
+ my $thing = $self->opt_f;
+ my $list = 0;
+
+ while( my $line = <PERLOP> ){
+ if( $paragraph and $line =~ m!^=(?:head|item)! and $paragraph =~ m!X<+\s*\Q$thing\E\s*>+! ){
+ if( $list ){
+ $paragraph =~ s!=back.*?\z!!s;
+ }
+
+ if( $paragraph =~ m!^=item! ){
+ $paragraph = "=over 8\n\n" . $paragraph . "=back\n";
+ }
+
+ push @$pod, $paragraph;
+ $paragraph = "";
+ $has_text_seen = 0;
+ $list = 0;
+ }
+
+ if( $line =~ m!^=over! ){
+ $list++;
+ }
+ elsif( $line =~ m!^=back! ){
+ $list--;
+ }
+
+ if( $line =~ m!^=(?:head|item)! and $has_text_seen ){
+ $paragraph = "";
+ }
+ elsif( $line !~ m!^=(?:head|item)! and $line !~ m!^\s*$! and $line !~ m!^\s*X<! ){
+ $has_text_seen = 1;
+ }
+
+ $paragraph .= $line;
+ }
+
+ close PERLOP;
+
+ return;
+}
+
+#..........................................................................
+
sub search_perlfunc {
my($self, $found_things, $pod) = @_;
@@ -966,7 +1147,7 @@ sub search_perlfunc {
my $perlfunc = shift @$found_things;
open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
- or die("Can't open $perlfunc: $!");
+ or $self->die("Can't open $perlfunc: $!");
# Functions like -r, -e, etc. are listed under `-X'.
my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
@@ -992,13 +1173,31 @@ sub search_perlfunc {
# Look for our function
my $found = 0;
my $inlist = 0;
+
+ my @perlops = qw(m q qq qr qx qw s tr y);
+
+ my @related;
+ my $related_re;
while (<PFUNC>) { # "The Mothership Connection is here!"
+ last if( grep{ $self->opt_f eq $_ }@perlops );
if ( m/^=item\s+$search_re\b/ ) {
$found = 1;
}
+ elsif (@related > 1 and /^=item/) {
+ $related_re ||= join "|", @related;
+ if (m/^=item\s+(?:$related_re)\b/) {
+ $found = 1;
+ }
+ else {
+ last;
+ }
+ }
elsif (/^=item/) {
last if $found > 1 and not $inlist;
}
+ elsif ($found and /^X<[^>]+>/) {
+ push @related, m/X<([^>]+)>/g;
+ }
next unless $found;
if (/^=over/) {
++$inlist;
@@ -1010,13 +1209,18 @@ sub search_perlfunc {
push @$pod, $_;
++$found if /^\w/; # found descriptive text
}
+
+ if( !@$pod ){
+ $self->search_perlop( $found_things, $pod );
+ }
+
if (!@$pod) {
- die sprintf
- "No documentation for perl function `%s' found\n",
- $self->opt_f
+ CORE::die( sprintf
+ "No documentation for perl function '%s' found\n",
+ $self->opt_f )
;
}
- close PFUNC or die "Can't open $perlfunc: $!";
+ close PFUNC or $self->die( "Can't open $perlfunc: $!" );
return;
}
@@ -1029,9 +1233,9 @@ sub search_perlfaqs {
my $found = 0;
my %found_in;
my $search_key = $self->opt_q;
-
+
my $rx = eval { qr/$search_key/ }
- or die <<EOD;
+ or $self->die( <<EOD );
Invalid regular expression '$search_key' given as -q pattern:
$@
Did you mean \\Q$search_key ?
@@ -1040,9 +1244,9 @@ EOD
local $_;
foreach my $file (@$found_things) {
- die "invalid file spec: $!" if $file =~ /[<>|]/;
+ $self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/;
open(INFAQ, "<", $file) # XXX 5.6ism
- or die "Can't read-open $file: $!\nAborting";
+ or $self->die( "Can't read-open $file: $!\nAborting" );
while (<INFAQ>) {
if ( m/^=head2\s+.*(?:$search_key)/i ) {
$found = 1;
@@ -1056,9 +1260,12 @@ EOD
}
close(INFAQ);
}
- die("No documentation for perl FAQ keyword `$search_key' found\n")
+ CORE::die("No documentation for perl FAQ keyword '$search_key' found\n")
unless @$pod;
+ if ( $self->opt_l ) {
+ CORE::die((join "\n", keys %found_in) . "\n");
+ }
return;
}
@@ -1071,25 +1278,25 @@ sub render_findings {
my($self, $found_things) = @_;
my $formatter_class = $self->{'formatter_class'}
- || die "No formatter class set!?";
+ || $self->die( "No formatter class set!?" );
my $formatter = $formatter_class->can('new')
? $formatter_class->new
: $formatter_class
;
if(! @$found_things) {
- die "Nothing found?!";
+ $self->die( "Nothing found?!" );
# should have been caught before here
} elsif(@$found_things > 1) {
- warn
+ $self->warn(
"Perldoc is only really meant for reading one document at a time.\n",
"So these parameters are being ignored: ",
join(' ', @$found_things[1 .. $#$found_things] ),
- "\n"
+ "\n" );
}
my $file = $found_things->[0];
-
+
DEBUG > 3 and printf "Formatter switches now: [%s]\n",
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
@@ -1099,21 +1306,26 @@ sub render_findings {
my($switch, $value, $silent_fail) = @$f;
if( $formatter->can($switch) ) {
eval { $formatter->$switch( defined($value) ? $value : () ) };
- warn "Got an error when setting $formatter_class\->$switch:\n$@\n"
+ $self->warn( "Got an error when setting $formatter_class\->$switch:\n$@\n" )
if $@;
} else {
if( $silent_fail or $switch =~ m/^__/s ) {
DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n";
} else {
- warn "$formatter_class doesn't recognize the $switch switch.\n";
+ $self->warn( "$formatter_class doesn't recognize the $switch switch.\n" );
}
}
}
}
-
+
$self->{'output_is_binary'} =
$formatter->can('write_with_binmode') && $formatter->write_with_binmode;
+ if( $self->{podnames} and exists $self->{podnames}{$file} and
+ $formatter->can('name') ) {
+ $formatter->name($self->{podnames}{$file});
+ }
+
my ($out_fh, $out) = $self->new_output_file(
( $formatter->can('output_extension') && $formatter->output_extension )
|| undef,
@@ -1130,19 +1342,19 @@ sub render_findings {
# The average user just has no reason to be seeing
# $^W-suppressible warnings from the formatting!
}
-
+
eval { $formatter->parse_from_file( $file, $out_fh ) };
}
-
- warn "Error while formatting with $formatter_class:\n $@\n" if $@;
+
+ $self->warn( "Error while formatting with $formatter_class:\n $@\n" ) if $@;
DEBUG > 2 and print "Back from formatting with $formatter_class\n";
- close $out_fh
- or warn "Can't close $out: $!\n(Did $formatter already close it?)";
+ close $out_fh
+ or $self->warn( "Can't close $out: $!\n(Did $formatter already close it?)" );
sleep 0; sleep 0; sleep 0;
# Give the system a few timeslices to meditate on the fact
# that the output file does in fact exist and is closed.
-
+
$self->unlink_if_temp_file($file);
unless( -s $out ) {
@@ -1152,7 +1364,7 @@ sub render_findings {
# as a 0-length output file?
$formatter->if_zero_length( $file, $out, $out_fh );
} else {
- warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n"
+ $self->warn( "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" );
}
}
@@ -1171,11 +1383,11 @@ sub unlink_if_temp_file {
#
my($self, $file) = @_;
return unless defined $file and length $file;
-
+
my $temp_file_list = $self->{'temp_file_list'} || return;
if(grep $_ eq $file, @$temp_file_list) {
$self->aside("Unlinking $file\n");
- unlink($file) or warn "Odd, couldn't unlink $file: $!";
+ unlink($file) or $self->warn( "Odd, couldn't unlink $file: $!" );
} else {
DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n";
}
@@ -1184,129 +1396,25 @@ sub unlink_if_temp_file {
#..........................................................................
-sub MSWin_temp_cleanup {
-
- # Nothing particularly MSWin-specific in here, but I don't know if any
- # other OS needs its temp dir policed like MSWin does!
-
- my $self = shift;
-
- my $tempdir = $ENV{'TEMP'};
- return unless defined $tempdir and length $tempdir
- and -e $tempdir and -d _ and -w _;
-
- $self->aside(
- "Considering whether any old files of mine in $tempdir need unlinking.\n"
- );
-
- opendir(TMPDIR, $tempdir) || return;
- my @to_unlink;
-
- my $limit = time() - $Temp_File_Lifetime;
-
- DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n",
- ($limit) x 2;
-
- my $filespec;
-
- while(defined($filespec = readdir(TMPDIR))) {
- if(
- $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s
- ) {
- if( hex($1) < $limit ) {
- push @to_unlink, "$tempdir/$filespec";
- $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" );
- } else {
- DEBUG > 5 and
- printf " $tempdir/$filespec is too recent (after %x)\n", $limit;
- }
- } else {
- DEBUG > 5 and
- print " $tempdir/$filespec doesn't look like a perldoc temp file.\n";
- }
- }
- closedir(TMPDIR);
- $self->aside(sprintf "Unlinked %s items of mine in %s\n",
- scalar(unlink(@to_unlink)),
- $tempdir
- );
- return;
-}
-
-# . . . . . . . . . . . . . . . . . . . . . . . . .
-
-sub MSWin_perldoc_tempfile {
- my($self, $suffix, $infix) = @_;
-
- my $tempdir = $ENV{'TEMP'};
- return unless defined $tempdir and length $tempdir
- and -e $tempdir and -d _ and -w _;
-
- my $spec;
-
- do {
- $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
- # Yes, we embed the create-time in the filename!
- $tempdir,
- $infix || 'x',
- time(),
- $$,
- defined( &Win32::GetTickCount )
- ? (Win32::GetTickCount() & 0xff)
- : int(rand 256)
- # Under MSWin, $$ values get reused quickly! So if we ran
- # perldoc foo and then perldoc bar before there was time for
- # time() to increment time."_$$" would likely be the same
- # for each process! So we tack on the tick count's lower
- # bits (or, in a pinch, rand)
- ,
- $suffix || 'txt';
- ;
- } while( -e $spec );
-
- my $counter = 0;
-
- while($counter < 50) {
- my $fh;
- # If we are running before perl5.6.0, we can't autovivify
- if ($] < 5.006) {
- require Symbol;
- $fh = Symbol::gensym();
- }
- DEBUG > 3 and print "About to try making temp file $spec\n";
- return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
- $self->aside("Can't create temp file $spec: $!\n");
- }
-
- $self->aside("Giving up on making a temp file!\n");
- die "Can't make a tempfile!?";
-}
-
-#..........................................................................
-
sub after_rendering {
my $self = $_[0];
- $self->after_rendering_VMS if IS_VMS;
- $self->after_rendering_MSWin32 if IS_MSWin32;
- $self->after_rendering_Dos if IS_Dos;
- $self->after_rendering_OS2 if IS_OS2;
+ $self->after_rendering_VMS if $self->is_vms;
+ $self->after_rendering_MSWin32 if $self->is_mswin32;
+ $self->after_rendering_Dos if $self->is_dos;
+ $self->after_rendering_OS2 if $self->is_os2;
return;
}
sub after_rendering_VMS { return }
sub after_rendering_Dos { return }
sub after_rendering_OS2 { return }
-
-sub after_rendering_MSWin32 {
- shift->MSWin_temp_cleanup() if $Temp_Files_Created;
-}
+sub after_rendering_MSWin32 { return }
#..........................................................................
-# : : : : : : : : :
+# : : : : : : : : :
#..........................................................................
-
sub minus_f_nocase { # i.e., do like -f, but without regard to case
my($self, $dir, $file) = @_;
@@ -1314,59 +1422,59 @@ sub minus_f_nocase { # i.e., do like -f, but without regard to case
return $path if -f $path and -r _;
if(!$self->opt_i
- or IS_VMS or IS_MSWin32
- or IS_Dos or IS_OS2
+ or $self->is_vms or $self->is_mswin32
+ or $self->Is_dos or $self->is_os2
) {
# On a case-forgiving file system, or if case is important,
- # that is it, all we can do.
- warn "Ignored $path: unreadable\n" if -f _;
- return '';
+ # that is it, all we can do.
+ $self->warn( "Ignored $path: unreadable\n" ) if -f _;
+ return '';
}
-
+
local *DIR;
my @p = ($dir);
my($p,$cip);
foreach $p (splitdir $file){
- my $try = catfile @p, $p;
+ my $try = catfile @p, $p;
$self->aside("Scrutinizing $try...\n");
- stat $try;
- if (-d _) {
- push @p, $p;
- if ( $p eq $self->{'target'} ) {
- my $tmp_path = catfile @p;
- my $path_f = 0;
- for (@{ $self->{'found'} }) {
- $path_f = 1 if $_ eq $tmp_path;
- }
- push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
- $self->aside( "Found as $tmp_path but directory\n" );
- }
- }
- elsif (-f _ && -r _) {
- return $try;
- }
- elsif (-f _) {
- warn "Ignored $try: unreadable\n";
- }
- elsif (-d catdir(@p)) { # at least we see the containing directory!
- my $found = 0;
- my $lcp = lc $p;
- my $p_dirspec = catdir(@p);
- opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!";
- while(defined( $cip = readdir(DIR) )) {
- if (lc $cip eq $lcp){
- $found++;
- last; # XXX stop at the first? what if there's others?
- }
- }
- closedir DIR or die "closedir $p_dirspec: $!";
- return "" unless $found;
-
- push @p, $cip;
- my $p_filespec = catfile(@p);
- return $p_filespec if -f $p_filespec and -r _;
- warn "Ignored $p_filespec: unreadable\n" if -f _;
- }
+ stat $try;
+ if (-d _) {
+ push @p, $p;
+ if ( $p eq $self->{'target'} ) {
+ my $tmp_path = catfile @p;
+ my $path_f = 0;
+ for (@{ $self->{'found'} }) {
+ $path_f = 1 if $_ eq $tmp_path;
+ }
+ push (@{ $self->{'found'} }, $tmp_path) unless $path_f;
+ $self->aside( "Found as $tmp_path but directory\n" );
+ }
+ }
+ elsif (-f _ && -r _ && lc($try) eq lc($path)) {
+ return $try;
+ }
+ elsif (-f _) {
+ $self->warn( "Ignored $try: unreadable or file/dir mismatch\n" );
+ }
+ elsif (-d catdir(@p)) { # at least we see the containing directory!
+ my $found = 0;
+ my $lcp = lc $p;
+ my $p_dirspec = catdir(@p);
+ opendir DIR, $p_dirspec or $self->die( "opendir $p_dirspec: $!" );
+ while(defined( $cip = readdir(DIR) )) {
+ if (lc $cip eq $lcp){
+ $found++;
+ last; # XXX stop at the first? what if there's others?
+ }
+ }
+ closedir DIR or $self->die( "closedir $p_dirspec: $!" );
+ return "" unless $found;
+
+ push @p, $cip;
+ my $p_filespec = catfile(@p);
+ return $p_filespec if -f $p_filespec and -r _;
+ $self->warn( "Ignored $p_filespec: unreadable\n" ) if -f _;
+ }
}
return "";
}
@@ -1380,34 +1488,35 @@ sub pagers_guessing {
push @pagers, $self->pagers;
$self->{'pagers'} = \@pagers;
- if (IS_MSWin32) {
+ if ($self->is_mswin32) {
push @pagers, qw( more< less notepad );
unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
}
- elsif (IS_VMS) {
+ elsif ($self->is_vms) {
push @pagers, qw( most more less type/page );
}
- elsif (IS_Dos) {
+ elsif ($self->is_dos) {
push @pagers, qw( less.exe more.com< );
unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
}
else {
- if (IS_OS2) {
+ if ($self->is_os2) {
unshift @pagers, 'less', 'cmd /c more <';
}
push @pagers, qw( more less pg view cat );
- unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+ unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER};
}
- if (IS_Cygwin) {
+ if ($self->is_cygwin) {
if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
unshift @pagers, '/usr/bin/less -isrR';
- }
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
+ }
}
unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
-
- return;
+
+ return;
}
#..........................................................................
@@ -1427,62 +1536,23 @@ sub page_module_file {
# occasionally hazy distinction between OS-local extension
# associations, and browser-specific MIME mappings.
- if ($self->{'output_to_stdout'}) {
- $self->aside("Sending unpaged output to STDOUT.\n");
- local $_;
- my $any_error = 0;
- foreach my $output (@found) {
- unless( open(TMP, "<", $output) ) { # XXX 5.6ism
- warn("Can't open $output: $!");
- $any_error = 1;
- next;
- }
- while (<TMP>) {
- print or die "Can't print to stdout: $!";
- }
- close TMP or die "Can't close while $output: $!";
- $self->unlink_if_temp_file($output);
- }
- return $any_error; # successful
+ if(@found > 1) {
+ $self->warn(
+ "Perldoc is only really meant for reading one document at a time.\n" .
+ "So these files are being ignored: " .
+ join(' ', @found[1 .. $#found] ) .
+ "\n" )
}
- foreach my $pager ( $self->pagers ) {
- $self->aside("About to try calling $pager @found\n");
- if (system($pager, @found) == 0) {
- $self->aside("Yay, it worked.\n");
- return 0;
- }
- $self->aside("That didn't work.\n");
-
- # Odd -- when it fails, under Win32, this seems to neither
- # return with a fail nor return with a success!!
- # That's discouraging!
- }
+ return $self->page($found[0], $self->{'output_to_stdout'}, $self->pagers);
- $self->aside(
- sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n",
- join(' ', @found),
- join(' ', $self->pagers),
- );
-
- if (IS_VMS) {
- DEBUG > 1 and print "Bailing out in a VMSish way.\n";
- eval q{
- use vmsish qw(status exit);
- exit $?;
- 1;
- } or die;
- }
-
- return 1;
- # i.e., an UNSUCCESSFUL return value!
}
#..........................................................................
sub check_file {
my($self, $dir, $file) = @_;
-
+
unless( ref $self ) {
# Should never get called:
$Carp::Verbose = 1;
@@ -1493,29 +1563,41 @@ sub check_file {
"Aborting"
);
}
-
+
if(length $dir and not -d $dir) {
DEBUG > 3 and print " No dir $dir -- skipping.\n";
return "";
}
-
- if ($self->opt_m) {
- return $self->minus_f_nocase($dir,$file);
- }
-
- else {
- my $path = $self->minus_f_nocase($dir,$file);
- if( length $path and $self->containspod($path) ) {
- DEBUG > 3 and print
- " The file $path indeed looks promising!\n";
- return $path;
- }
+
+ my $path = $self->minus_f_nocase($dir,$file);
+ if( length $path and ($self->opt_m ? $self->isprintable($path)
+ : $self->containspod($path)) ) {
+ DEBUG > 3 and print
+ " The file $path indeed looks promising!\n";
+ return $path;
}
DEBUG > 3 and print " No good: $file in $dir\n";
-
+
return "";
}
+sub isprintable {
+ my($self, $file, $readit) = @_;
+ my $size= 1024;
+ my $maxunprintfrac= 0.2; # tolerate some unprintables for UTF-8 comments etc.
+
+ return 1 if !$readit && $file =~ /\.(?:pl|pm|pod|cmd|com|bat)\z/i;
+
+ my $data;
+ local($_);
+ open(TEST,"<", $file) or $self->die( "Can't open $file: $!" );
+ read TEST, $data, $size;
+ close TEST;
+ $size= length($data);
+ $data =~ tr/\x09-\x0D\x20-\x7E//d;
+ return length($data) <= $size*$maxunprintfrac;
+}
+
#..........................................................................
sub containspod {
@@ -1536,21 +1618,21 @@ sub containspod {
#
# $ perldoc perl.pod
- if ( IS_Cygwin and -x $file and -f "$file.exe" )
+ if ( $self->is_cygwin and -x $file and -f "$file.exe" )
{
- warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_D;
+ $self->warn( "Cygwin $file.exe search skipped\n" ) if DEBUG or $self->opt_D;
return 0;
}
local($_);
- open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
+ open(TEST,"<", $file) or $self->die( "Can't open $file: $!" ); # XXX 5.6ism
while (<TEST>) {
- if (/^=head/) {
- close(TEST) or die "Can't close $file: $!";
- return 1;
- }
+ if (/^=head/) {
+ close(TEST) or $self->die( "Can't close $file: $!" );
+ return 1;
+ }
}
- close(TEST) or die "Can't close $file: $!";
+ close(TEST) or $self->die( "Can't close $file: $!" );
return 0;
}
@@ -1558,21 +1640,21 @@ sub containspod {
sub maybe_diddle_INC {
my $self = shift;
-
+
# Does this look like a module or extension directory?
-
+
if (-f "Makefile.PL" || -f "Build.PL") {
# Add "." and "lib" to @INC (if they exist)
- eval q{ use lib qw(. lib); 1; } or die;
+ eval q{ use lib qw(. lib); 1; } or $self->die;
# don't add if superuser
if ($< && $> && -d "blib") { # don't be looking too hard now!
eval q{ use blib; 1 };
- warn $@ if $@ && $self->opt_D;
+ $self->warn( $@ ) if $@ && $self->opt_D;
}
}
-
+
return;
}
@@ -1582,21 +1664,21 @@ sub new_output_file {
my $self = shift;
my $outspec = $self->opt_d; # Yes, -d overrides all else!
# So don't call this twice per format-job!
-
+
return $self->new_tempfile(@_) unless defined $outspec and length $outspec;
# Otherwise open a write-handle on opt_d!f
my $fh;
# If we are running before perl5.6.0, we can't autovivify
- if ($] < 5.006) {
+ if ($^V < 5.006) {
require Symbol;
$fh = Symbol::gensym();
}
DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
- die "Can't write-open $outspec: $!"
+ $self->die( "Can't write-open $outspec: $!" )
unless open($fh, ">", $outspec); # XXX 5.6ism
-
+
DEBUG > 3 and print "Successfully opened $outspec\n";
binmode($fh) if $self->{'output_is_binary'};
return($fh, $outspec);
@@ -1617,7 +1699,7 @@ sub useful_filename_bit {
my $self = shift;
my $pages = $self->{'pages'} || return undef;
return undef unless @$pages;
-
+
my $chunk = $pages->[0];
return undef unless defined $chunk;
$chunk =~ s/:://g;
@@ -1639,12 +1721,6 @@ sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] )
++$Temp_Files_Created;
- if( IS_MSWin32 ) {
- my @out = $self->MSWin_perldoc_tempfile(@_);
- return @out if @out;
- # otherwise fall thru to the normal stuff below...
- }
-
require File::Temp;
return File::Temp::tempfile(UNLINK => 1);
}
@@ -1655,32 +1731,32 @@ sub page { # apply a pager to the output file
my ($self, $output, $output_to_stdout, @pagers) = @_;
if ($output_to_stdout) {
$self->aside("Sending unpaged output to STDOUT.\n");
- open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
- local $_;
- while (<TMP>) {
- print or die "Can't print to stdout: $!";
- }
- close TMP or die "Can't close while $output: $!";
- $self->unlink_if_temp_file($output);
+ open(TMP, "<", $output) or $self->die( "Can't open $output: $!" ); # XXX 5.6ism
+ local $_;
+ while (<TMP>) {
+ print or $self->die( "Can't print to stdout: $!" );
+ }
+ close TMP or $self->die( "Can't close while $output: $!" );
+ $self->unlink_if_temp_file($output);
} else {
# On VMS, quoting prevents logical expansion, and temp files with no
# extension get the wrong default extension (such as .LIS for TYPE)
- $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
+ $output = VMS::Filespec::rmsexpand($output, '.') if $self->is_vms;
- $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
- # Altho "/" under MSWin is in theory good as a pathsep,
- # many many corners of the OS don't like it. So we
- # have to force it to be "\" to make everyone happy.
+ $output =~ s{/}{\\}g if $self->is_mswin32 || $self->is_dos;
+ # Altho "/" under MSWin is in theory good as a pathsep,
+ # many many corners of the OS don't like it. So we
+ # have to force it to be "\" to make everyone happy.
foreach my $pager (@pagers) {
$self->aside("About to try calling $pager $output\n");
- if (IS_VMS) {
+ if ($self->is_vms) {
last if system("$pager $output") == 0;
} else {
- last if system("$pager \"$output\"") == 0;
+ last if system("$pager \"$output\"") == 0;
}
- }
+ }
}
return;
}
@@ -1690,7 +1766,7 @@ sub page { # apply a pager to the output file
sub searchfor {
my($self, $recurse,$s,@dirs) = @_;
$s =~ s!::!/!g;
- $s = VMS::Filespec::unixify($s) if IS_VMS;
+ $s = VMS::Filespec::unixify($s) if $self->is_vms;
return $s if -f $s && $self->containspod($s);
$self->aside( "Looking for $s in @dirs\n" );
my $ret;
@@ -1698,41 +1774,41 @@ sub searchfor {
my $dir;
$self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
for ($i=0; $i<@dirs; $i++) {
- $dir = $dirs[$i];
- next unless -d $dir;
- ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
- if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
- or ( $ret = $self->check_file($dir,"$s.pm"))
- or ( $ret = $self->check_file($dir,$s))
- or ( IS_VMS and
- $ret = $self->check_file($dir,"$s.com"))
- or ( IS_OS2 and
- $ret = $self->check_file($dir,"$s.cmd"))
- or ( (IS_MSWin32 or IS_Dos or IS_OS2) and
- $ret = $self->check_file($dir,"$s.bat"))
- or ( $ret = $self->check_file("$dir/pod","$s.pod"))
- or ( $ret = $self->check_file("$dir/pod",$s))
- or ( $ret = $self->check_file("$dir/pods","$s.pod"))
- or ( $ret = $self->check_file("$dir/pods",$s))
- ) {
- DEBUG > 1 and print " Found $ret\n";
- return $ret;
- }
+ $dir = $dirs[$i];
+ next unless -d $dir;
+ ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $self->is_vms;
+ if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
+ or ( $ret = $self->check_file($dir,"$s.pm"))
+ or ( $ret = $self->check_file($dir,$s))
+ or ( $self->is_vms and
+ $ret = $self->check_file($dir,"$s.com"))
+ or ( $self->is_os2 and
+ $ret = $self->check_file($dir,"$s.cmd"))
+ or ( ($self->is_mswin32 or $self->is_dos or $self->is_os2) and
+ $ret = $self->check_file($dir,"$s.bat"))
+ or ( $ret = $self->check_file("$dir/pod","$s.pod"))
+ or ( $ret = $self->check_file("$dir/pod",$s))
+ or ( $ret = $self->check_file("$dir/pods","$s.pod"))
+ or ( $ret = $self->check_file("$dir/pods",$s))
+ ) {
+ DEBUG > 1 and print " Found $ret\n";
+ return $ret;
+ }
- if ($recurse) {
- opendir(D,$dir) or die "Can't opendir $dir: $!";
- my @newdirs = map catfile($dir, $_), grep {
- not /^\.\.?\z/s and
- not /^auto\z/s and # save time! don't search auto dirs
- -d catfile($dir, $_)
- } readdir D;
- closedir(D) or die "Can't closedir $dir: $!";
- next unless @newdirs;
- # what a wicked map!
- @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS;
- $self->aside( "Also looking in @newdirs\n" );
- push(@dirs,@newdirs);
- }
+ if ($recurse) {
+ opendir(D,$dir) or $self->die( "Can't opendir $dir: $!" );
+ my @newdirs = map catfile($dir, $_), grep {
+ not /^\.\.?\z/s and
+ not /^auto\z/s and # save time! don't search auto dirs
+ -d catfile($dir, $_)
+ } readdir D;
+ closedir(D) or $self->die( "Can't closedir $dir: $!" );
+ next unless @newdirs;
+ # what a wicked map!
+ @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $self->is_vms;
+ $self->aside( "Also looking in @newdirs\n" );
+ push(@dirs,@newdirs);
+ }
}
return ();
}
@@ -1745,10 +1821,10 @@ sub searchfor {
return if $already_asserted;
- eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~;
+ eval q~ END { close(STDOUT) || CORE::die "Can't close STDOUT: $!" } ~;
# What for? to let the pager know that nothing more will come?
-
- die $@ if $@;
+
+ $self->die( $@ ) if $@;
$already_asserted = 1;
return;
}
@@ -1758,21 +1834,22 @@ sub searchfor {
sub tweak_found_pathnames {
my($self, $found) = @_;
- if (IS_MSWin32) {
+ if ($self->is_mswin32) {
foreach (@$found) { s,/,\\,g }
}
+ foreach (@$found) { s,',\\',g } # RT 37347
return;
}
#..........................................................................
-# : : : : : : : : :
+# : : : : : : : : :
#..........................................................................
sub am_taint_checking {
my $self = shift;
- die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way
+ $self->die( "NO ENVIRONMENT?!?!" ) unless keys %ENV; # reset iterator along the way
my($k,$v) = each %ENV;
- return is_tainted($v);
+ return is_tainted($v);
}
#..........................................................................
@@ -1789,10 +1866,10 @@ sub is_tainted { # just a function
sub drop_privs_maybe {
my $self = shift;
-
+
# Attempt to drop privs if we should be tainting and aren't
- if (!(IS_VMS || IS_MSWin32 || IS_Dos
- || IS_OS2
+ if (!( $self->is_vms || $self->is_mswin32 || $self->is_dos
+ || $self->is_os2
)
&& ($> == 0 || $< == 0)
&& !$self->am_taint_checking()
@@ -1873,94 +1950,11 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
-
-#
-#
-# Perldoc -- look up a piece of documentation in .pod format that
-# is embedded in the perl installation tree.
-#
-#~~~~~~
-#
-# See ChangeLog in CPAN dist for Pod::Perldoc for later notes.
-#
-# Version 3.01: Sun Nov 10 21:38:09 MST 2002
-# Sean M. Burke <sburke@cpan.org>
-# Massive refactoring and code-tidying.
-# Now it's a module(-family)!
-# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm
-# Added -T, -d, -o, -M, -w.
-# Added some improved MSWin funk.
-#
-#~~~~~~
-#
-# Version 2.05: Sat Oct 12 16:09:00 CEST 2002
-# Hugo van der Sanden <hv@crypt.org>
-# Made -U the default, based on patch from Simon Cozens
-# Version 2.04: Sun Aug 18 13:27:12 BST 2002
-# Randy W. Sims <RandyS@ThePierianSpring.org>
-# allow -n to enable nroff under Win32
-# Version 2.03: Sun Apr 23 16:56:34 BST 2000
-# Hugo van der Sanden <hv@crypt.org>
-# don't die when 'use blib' fails
-# Version 2.02: Mon Mar 13 18:03:04 MST 2000
-# Tom Christiansen <tchrist@perl.com>
-# Added -U insecurity option
-# Version 2.01: Sat Mar 11 15:22:33 MST 2000
-# Tom Christiansen <tchrist@perl.com>, querulously.
-# Security and correctness patches.
-# What a twisted bit of distasteful spaghetti code.
-# Version 2.0: ????
-#
-#~~~~~~
-#
-# Version 1.15: Tue Aug 24 01:50:20 EST 1999
-# Charles Wilson <cwilson@ece.gatech.edu>
-# changed /pod/ directory to /pods/ for cygwin
-# to support cygwin/win32
-# Version 1.14: Wed Jul 15 01:50:20 EST 1998
-# Robin Barker <rmb1@cise.npl.co.uk>
-# -strict, -w cleanups
-# Version 1.13: Fri Feb 27 16:20:50 EST 1997
-# Gurusamy Sarathy <gsar@activestate.com>
-# -doc tweaks for -F and -X options
-# Version 1.12: Sat Apr 12 22:41:09 EST 1997
-# Gurusamy Sarathy <gsar@activestate.com>
-# -various fixes for win32
-# Version 1.11: Tue Dec 26 09:54:33 EST 1995
-# Kenneth Albanowski <kjahds@kjahds.com>
-# -added Charles Bailey's further VMS patches, and -u switch
-# -added -t switch, with pod2text support
-#
-# Version 1.10: Thu Nov 9 07:23:47 EST 1995
-# Kenneth Albanowski <kjahds@kjahds.com>
-# -added VMS support
-# -added better error recognition (on no found pages, just exit. On
-# missing nroff/pod2man, just display raw pod.)
-# -added recursive/case-insensitive matching (thanks, Andreas). This
-# slows things down a bit, unfortunately. Give a precise name, and
-# it'll run faster.
-#
-# Version 1.01: Tue May 30 14:47:34 EDT 1995
-# Andy Dougherty <doughera@lafcol.lafayette.edu>
-# -added pod documentation.
-# -added PATH searching.
-# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
-# and friends.
-#
-#~~~~~~~
-#
-# TODO:
-#
-# Cache the directories read during sloppy match
-# (To disk, or just in-memory?)
-#
-# Backport this to perl 5.005?
-#
-# Implement at least part of the "perlman" interface described
-# in Programming Perl 3e?
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm
index 29a3b7d108e..aa8d84493ff 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/BaseTo.pm
@@ -1,9 +1,14 @@
-
-require 5;
package Pod::Perldoc::BaseTo;
use strict;
use warnings;
+use vars qw($VERSION);
+$VERSION = '3.17';
+
+use Carp qw(croak carp);
+use Config qw(%Config);
+use File::Spec::Functions qw(catfile);
+
sub is_pageable { '' }
sub write_with_binmode { 1 }
@@ -14,6 +19,22 @@ sub output_extension { 'txt' } # override in subclass!
#sub new { return bless {}, ref($_[0]) || $_[0] }
+# this is also in Perldoc.pm, but why look there when you're a
+# subclass of this?
+sub TRUE () {1}
+sub FALSE () {return}
+
+BEGIN {
+ *is_vms = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &is_vms;
+ *is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32;
+ *is_dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &is_dos;
+ *is_os2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &is_os2;
+ *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_openbsd = $^O =~ m/openbsd/ ? \&TRUE : \&FALSE unless defined &is_openbsd;
+}
+
sub _perldoc_elem {
my($self, $name) = splice @_,0,2;
if(@_) {
@@ -23,6 +44,54 @@ sub _perldoc_elem {
}
}
+sub debugging {
+ my( $self, @messages ) = @_;
+
+ ( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() )
+ }
+
+sub debug {
+ my( $self, @messages ) = @_;
+ return unless $self->debugging;
+ print STDERR map { "DEBUG $_" } @messages;
+ }
+
+sub warn {
+ my( $self, @messages ) = @_;
+ carp join "\n", @messages, '';
+ }
+
+sub die {
+ my( $self, @messages ) = @_;
+ croak join "\n", @messages, '';
+ }
+
+sub _get_path_components {
+ my( $self ) = @_;
+
+ my @paths = split /\Q$Config{path_sep}/, $ENV{PATH};
+
+ return @paths;
+ }
+
+sub _find_executable_in_path {
+ my( $self, $program ) = @_;
+
+ my @found = ();
+ foreach my $dir ( $self->_get_path_components ) {
+ my $binary = catfile( $dir, $program );
+ $self->debug( "Looking for $binary\n" );
+ next unless -e $binary;
+ unless( -x $binary ) {
+ $self->warn( "Found $binary but it's not executable. Skipping.\n" );
+ next;
+ }
+ $self->debug( "Found $binary\n" );
+ push @found, $binary;
+ }
+
+ return @found;
+ }
1;
@@ -73,9 +142,11 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm
index fa83fb74ccf..c77d5460483 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/GetOptsOO.pm
@@ -1,23 +1,8 @@
-
-require 5;
package Pod::Perldoc::GetOptsOO;
use strict;
-# Rather like Getopt::Std's getopts
-# Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth)
-# Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT )
-# (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo")
-# Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth)
-# (Truth defaults to 1)
-# Otherwise we try calling $object->handle_unknown_option('n')
-# (and we increment the error count by the return value of it)
-# If there's no handle_unknown_option, then we just warn, and then increment
-# the error counter
-#
-# The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors,
-# otherwise it's false.
-#
-## sburke@cpan.org 2002-10-31
+use vars qw($VERSION);
+$VERSION = '3.17';
BEGIN { # Make a DEBUG constant ASAP
*DEBUG = defined( &Pod::Perldoc::DEBUG )
@@ -28,7 +13,7 @@ BEGIN { # Make a DEBUG constant ASAP
sub getopts {
my($target, $args, $truth) = @_;
-
+
$args ||= \@ARGV;
$target->aside(
@@ -50,11 +35,14 @@ sub getopts {
shift @$args;
last;
}
+ if ($first eq '-' and $rest) { # GNU style long param names
+ ($first, $rest) = split '=', $rest, 2;
+ }
my $method = "opt_${first}_with";
if( $target->can($method) ) { # it's argumental
if($rest eq '') { # like -f bar
shift @$args;
- warn "Option $first needs a following argument!\n" unless @$args;
+ $target->warn( "Option $first needs a following argument!\n" ) unless @$args;
$rest = shift @$args;
} else { # like -fbar (== -f bar)
shift @$args;
@@ -75,14 +63,14 @@ sub getopts {
} elsif( $target->can('handle_unknown_option') ) {
DEBUG > 3
and print " calling handle_unknown_option('$first')\n";
-
+
$error_count += (
$target->handle_unknown_option( $first ) || 0
);
} else {
++$error_count;
- warn "Unknown option: $first\n";
+ $target->warn( "Unknown option: $first\n" );
}
if($rest eq '') { # like -f
@@ -93,7 +81,7 @@ sub getopts {
}
}
}
-
+
$target->aside(
"Ending switch processing. Args are [@$args] with $error_count errors.\n"
@@ -123,9 +111,32 @@ Pod::Perldoc::GetOptsOO - Customized option parser for Pod::Perldoc
Implements a customized option parser used for
L<Pod::Perldoc>.
+Rather like Getopt::Std's getopts:
+
+=over
+
+=item Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth)
+
+=item Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT )
+ (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo")
+
+=item Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth)
+ (Truth defaults to 1)
+
+=item Otherwise we try calling $object->handle_unknown_option('n')
+ (and we increment the error count by the return value of it)
+
+=item If there's no handle_unknown_option, then we just warn, and then increment
+ the error counter
+
+=back
+
+The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors,
+otherwise it's false.
+
=head1 SEE ALSO
- Pod::Perldoc
+L<Pod::Perldoc>
=head1 COPYRIGHT AND DISCLAIMERS
@@ -140,9 +151,11 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToANSI.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToANSI.pm
new file mode 100644
index 00000000000..7be62e23589
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToANSI.pm
@@ -0,0 +1,96 @@
+package Pod::Perldoc::ToANSI;
+use strict;
+use warnings;
+use parent qw(Pod::Perldoc::BaseTo);
+
+use vars qw($VERSION);
+$VERSION = '3.17';
+
+sub is_pageable { 1 }
+sub write_with_binmode { 0 }
+sub output_extension { 'txt' }
+
+use Pod::Text::Color ();
+
+sub alt { shift->_perldoc_elem('alt' , @_) }
+sub indent { shift->_perldoc_elem('indent' , @_) }
+sub loose { shift->_perldoc_elem('loose' , @_) }
+sub quotes { shift->_perldoc_elem('quotes' , @_) }
+sub sentence { shift->_perldoc_elem('sentence', @_) }
+sub width { shift->_perldoc_elem('width' , @_) }
+
+sub new { return bless {}, ref($_[0]) || $_[0] }
+
+sub parse_from_file {
+ my $self = shift;
+
+ my @options =
+ map {; $_, $self->{$_} }
+ grep !m/^_/s,
+ keys %$self
+ ;
+
+ defined(&Pod::Perldoc::DEBUG)
+ and Pod::Perldoc::DEBUG()
+ and print "About to call new Pod::Text::Color ",
+ $Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '',
+ "with options: ",
+ @options ? "[@options]" : "(nil)", "\n";
+ ;
+
+ Pod::Text::Color->new(@options)->parse_from_file(@_);
+}
+
+1;
+
+=head1 NAME
+
+Pod::Perldoc::ToANSI - render Pod with ANSI color escapes
+
+=head1 SYNOPSIS
+
+ perldoc -o ansi Some::Modulename
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Pod::Text as a formatter class.
+
+It supports the following options, which are explained in
+L<Pod::Text>: alt, indent, loose, quotes, sentence, width
+
+For example:
+
+ perldoc -o term -w indent:5 Some::Modulename
+
+=head1 CAVEAT
+
+This module may change to use a different text formatter class in the
+future, and this may change what options are supported.
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Text::Color>, L<Pod::Perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2011 Mark Allen. All rights reserved.
+
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+=head1 AUTHOR
+
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
+
+Past contributions from:
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
+
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm
index 10870109e60..32c309bd445 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToChecker.pm
@@ -1,10 +1,11 @@
-
-require 5;
package Pod::Perldoc::ToChecker;
use strict;
use warnings;
use vars qw(@ISA);
+use vars qw($VERSION);
+$VERSION = '3.17';
+
# Pick our superclass...
#
eval 'require Pod::Simple::Checker';
@@ -66,10 +67,12 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm
index 09b0e817377..55616e8b899 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToMan.pm
@@ -1,15 +1,22 @@
-
-require 5;
+require 5.006;
package Pod::Perldoc::ToMan;
use strict;
use warnings;
+use parent qw(Pod::Perldoc::BaseTo);
+
+use vars qw($VERSION);
+$VERSION = '3.17';
+use File::Spec::Functions qw(catfile);
+use Pod::Man 2.18;
# This class is unlike ToText.pm et al, because we're NOT paging thru
# the output in our particular format -- we make the output and
# then we run nroff (or whatever) on it, and then page thru the
# (plaintext) output of THAT!
-use base qw(Pod::Perldoc::BaseTo);
+sub SUCCESS () { 1 }
+sub FAILED () { 0 }
+
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'txt' }
@@ -26,112 +33,486 @@ sub fixed { shift->_perldoc_elem('fixed' , @_) }
sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) }
sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) }
sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) }
+sub name { shift->_perldoc_elem('name' , @_) }
sub quotes { shift->_perldoc_elem('quotes' , @_) }
sub release { shift->_perldoc_elem('release' , @_) }
sub section { shift->_perldoc_elem('section' , @_) }
-sub new { return bless {}, ref($_[0]) || $_[0] }
+sub new {
+ my( $either ) = shift;
+ my $self = bless {}, ref($either) || $either;
+ $self->init( @_ );
+ return $self;
+ }
-use File::Spec::Functions qw(catfile);
+sub init {
+ my( $self, @args ) = @_;
+
+ unless( $self->__nroffer ) {
+ my $roffer = $self->_find_roffer( $self->_roffer_candidates );
+ $self->debug( "Using $roffer\n" );
+ $self->__nroffer( $roffer );
+ }
+ else {
+ $self->debug( "__nroffer is " . $self->__nroffer() . "\n" );
+ }
+
+ $self->_check_nroffer;
+ }
+
+sub _roffer_candidates {
+ my( $self ) = @_;
+
+ if( $self->is_openbsd ) { qw( mandoc groff nroff ) }
+ else { qw( groff nroff mandoc ) }
+ }
+
+sub _find_roffer {
+ my( $self, @candidates ) = @_;
+
+ my @found = ();
+ foreach my $candidate ( @candidates ) {
+ push @found, $self->_find_executable_in_path( $candidate );
+ }
+
+ return wantarray ? @found : $found[0];
+ }
+
+sub _check_nroffer {
+ return 1;
+ # where is it in the PATH?
+
+ # is it executable?
+
+ # what is its real name?
+
+ # what is its version?
+
+ # does it support the flags we need?
+
+ # is it good enough for us?
+ }
+
+sub _get_stty { `stty -a` }
+
+sub _get_columns_from_stty {
+ my $output = $_[0]->_get_stty;
+
+ if( $output =~ /\bcolumns\s+(\d+)/ ) { return $1 }
+ elsif( $output =~ /;\s*(\d+)\s+columns;/ ) { return $1 }
+ else { return 0 }
+ }
+
+sub _get_columns_from_manwidth {
+ my( $self ) = @_;
+
+ return 0 unless defined $ENV{MANWIDTH};
+
+ unless( $ENV{MANWIDTH} =~ m/\A\d+\z/ ) {
+ $self->warn( "Ignoring non-numeric MANWIDTH ($ENV{MANWIDTH})\n" );
+ return 0;
+ }
+
+ if( $ENV{MANWIDTH} == 0 ) {
+ $self->warn( "Ignoring MANWIDTH of 0. Really? Why even run the program? :)\n" );
+ return 0;
+ }
+
+ if( $ENV{MANWIDTH} =~ m/\A(\d+)\z/ ) { return $1 }
+
+ return 0;
+ }
+
+sub _get_default_width {
+ 73
+ }
+
+sub _get_columns {
+ $_[0]->_get_columns_from_manwidth ||
+ $_[0]->_get_columns_from_stty ||
+ $_[0]->_get_default_width;
+ }
+
+sub _get_podman_switches {
+ my( $self ) = @_;
+
+ my @switches = grep !m/^_/s, keys %$self;
+
+ push @switches, 'utf8' => 1;
+ $self->debug( "Pod::Man switches are [@switches]\n" );
+
+ return @switches;
+ }
+
+sub _parse_with_pod_man {
+ my( $self, $file ) = @_;
+
+ #->output_fh and ->output_string from Pod::Simple aren't
+ # working, apparently, so there's this ugly hack:
+ local *STDOUT;
+ open STDOUT, '>', $self->{_text_ref};
+ my $parser = Pod::Man->new( $self->_get_podman_switches );
+ $self->debug( "Parsing $file\n" );
+ $parser->parse_from_file( $file );
+ $self->debug( "Done parsing $file\n" );
+ close STDOUT;
+
+ $self->die( "No output from Pod::Man!\n" )
+ unless length $self->{_text_ref};
+
+ $self->_save_pod_man_output if $self->debugging;
+
+ return SUCCESS;
+ }
+
+sub _save_pod_man_output {
+ my( $self, $fh ) = @_;
+
+ $fh = do {
+ my $file = "podman.out.$$.txt";
+ $self->debug( "Writing $file with Pod::Man output\n" );
+ open my $fh2, '>', $file;
+ $fh2;
+ } unless $fh;
+
+ print { $fh } ${ $self->{_text_ref} };
+ }
+
+sub _have_groff_with_utf8 {
+ my( $self ) = @_;
+
+ return 0 unless $self->_is_groff;
+ my $roffer = $self->__nroffer;
+
+ my $minimum_groff_version = '1.20.1';
+
+ my $version_string = `$roffer -v`;
+ my( $version ) = $version_string =~ /\(?groff\)? version (\d+\.\d+(?:\.\d+)?)/;
+ $self->debug( "Found groff $version\n" );
+
+ # is a string comparison good enough?
+ if( $version lt $minimum_groff_version ) {
+ $self->warn(
+ "You have an old groff." .
+ " Update to version $minimum_groff_version for good Unicode support.\n" .
+ "If you don't upgrade, wide characters may come out oddly.\n"
+ );
+ }
+
+ $version ge $minimum_groff_version;
+ }
+
+sub _have_mandoc_with_utf8 {
+ my( $self ) = @_;
+
+ return 0 unless $self->_is_mandoc;
+ my $roffer = $self->__nroffer;
+
+ my $minimum_mandoc_version = '1.11';
+
+ my $version_string = `$roffer -V`;
+ my( $version ) = $version_string =~ /mandoc ((\d+)\.(\d+))/;
+ $self->debug( "Found mandoc $version\n" );
+
+ # is a string comparison good enough?
+ if( $version lt $minimum_mandoc_version ) {
+ $self->warn(
+ "You have an older mandoc." .
+ " Update to version $minimum_mandoc_version for better Unicode support.\n" .
+ "If you don't upgrade, wide characters may come out oddly.\n" .
+ "Your results still might be odd. If you have groff, that's even better.\n"
+ );
+ }
+
+ $version ge $minimum_mandoc_version;
+ }
+
+sub _collect_nroff_switches {
+ my( $self ) = shift;
+
+ my @render_switches = $self->_is_mandoc ? qw(-mandoc) : qw(-man);
+
+ push @render_switches, $self->_get_device_switches;
+
+ # Thanks to Brendan O'Dea for contributing the following block
+ if( $self->_is_roff and $self->is_linux and -t STDOUT and my ($cols) = $self->_get_columns ) {
+ my $c = $cols * 39 / 40;
+ $cols = $c > $cols - 2 ? $c : $cols -2;
+ push @render_switches, '-rLL=' . (int $c) . 'n' if $cols > 80;
+ }
+
+ # I hear persistent reports that adding a -c switch to $render
+ # solves many people's problems. But I also hear that some mans
+ # don't have a -c switch, so that unconditionally adding it here
+ # would presumably be a Bad Thing -- sburke@cpan.org
+ push @render_switches, '-c' if( $self->_is_roff and $self->is_cygwin );
+
+ return @render_switches;
+ }
+
+sub _get_device_switches {
+ my( $self ) = @_;
+
+ if( $self->_is_nroff ) { qw() }
+ elsif( $self->_have_groff_with_utf8 ) { qw(-Kutf8 -Tutf8) }
+ elsif( $self->_is_ebcdic ) { qw(-Tcp1047) }
+ elsif( $self->_have_mandoc_with_utf8 ) { qw(-Tutf8) }
+ elsif( $self->_is_mandoc ) { qw() }
+ else { qw(-Tlatin1) }
+ }
+
+sub _is_roff {
+ my( $self ) = @_;
+
+ $self->_is_nroff or $self->_is_groff;
+ }
+
+sub _is_nroff {
+ my( $self ) = @_;
+
+ $self->__nroffer =~ /\bnroff\b/;
+ }
+
+sub _is_groff {
+ my( $self ) = @_;
+
+ $self->__nroffer =~ /\bgroff\b/;
+ }
+
+sub _is_mandoc {
+ my ( $self ) = @_;
+
+ $self->__nroffer =~ /\bmandoc\b/;
+ }
+
+sub _is_ebcdic {
+ my( $self ) = @_;
+
+ return 0;
+ }
+
+sub _filter_through_nroff {
+ my( $self ) = shift;
+ $self->debug( "Filtering through " . $self->__nroffer() . "\n" );
+
+ # Maybe someone set rendering switches as part of the opt_n value
+ # Deal with that here.
+
+ my ($render, $switches) = $self->__nroffer() =~ /\A([\/a-zA-Z0-9_-]+)\b(.+)?\z/;
+
+ $self->die("no nroffer!?") unless $render;
+ my @render_switches = $self->_collect_nroff_switches;
+
+ if ( $switches ) {
+ # Eliminate whitespace
+ $switches =~ s/\s//g;
+
+ # Then seperate the switches with a zero-width positive
+ # lookahead on the dash.
+ #
+ # See:
+ # http://www.effectiveperlprogramming.com/blog/1411
+ # for a good discussion of this technique
+
+ push @render_switches, split(/(?=-)/, $switches);
+ }
+
+ $self->debug( "render is $render\n" );
+ $self->debug( "render options are @render_switches\n" );
+
+ require Symbol;
+ require IPC::Open3;
+ require IO::Handle;
+
+ my $pid = IPC::Open3::open3(
+ my $writer,
+ my $reader,
+ my $err = Symbol::gensym(),
+ $render,
+ @render_switches
+ );
+
+ $reader->autoflush(1);
+
+ use IO::Select;
+ my $selector = IO::Select->new( $reader );
+
+ $self->debug( "Writing to pipe to $render\n" );
+
+ my $offset = 0;
+ my $chunk_size = 4096;
+ my $length = length( ${ $self->{_text_ref} } );
+ my $chunks = $length / $chunk_size;
+ my $done;
+ my $buffer;
+ while( $offset <= $length ) {
+ $self->debug( "Writing chunk $chunks\n" ); $chunks++;
+ syswrite $writer, ${ $self->{_text_ref} }, $chunk_size, $offset
+ or $self->die( $! );
+ $offset += $chunk_size;
+ $self->debug( "Checking read\n" );
+ READ: {
+ last READ unless $selector->can_read( 0.01 );
+ $self->debug( "Reading\n" );
+ my $bytes = sysread $reader, $buffer, 4096;
+ $self->debug( "Read $bytes bytes\n" );
+ $done .= $buffer;
+ $self->debug( sprintf "Output is %d bytes\n",
+ length $done
+ );
+ next READ;
+ }
+ }
+ close $writer;
+ $self->debug( "Done writing\n" );
+
+ # read any leftovers
+ $done .= do { local $/; <$reader> };
+ $self->debug( sprintf "Done reading. Output is %d bytes\n",
+ length $done
+ );
+
+ if( $? ) {
+ $self->warn( "Error from pipe to $render!\n" );
+ $self->debug( 'Error: ' . do { local $/; <$err> } );
+ }
+
+
+ close $reader;
+ if( my $err = $? ) {
+ $self->debug(
+ "Nonzero exit ($?) while running `$render @render_switches`.\n" .
+ "Falling back to Pod::Perldoc::ToPod\n"
+ );
+ return $self->_fallback_to_pod( @_ );
+ }
+
+ $self->debug( "Output:\n----\n$done\n----\n" );
+
+ ${ $self->{_text_ref} } = $done;
+
+ return length ${ $self->{_text_ref} } ? SUCCESS : FAILED;
+ }
sub parse_from_file {
- my $self = shift;
- my($file, $outfh) = @_;
-
- my $render = $self->{'__nroffer'} || die "no nroffer set!?";
-
- # turn the switches into CLIs
- my $switches = join ' ',
- map qq{"--$_=$self->{$_}"},
- grep !m/^_/s,
- keys %$self
- ;
-
- my $pod2man =
- catfile(
- ($self->{'__bindir'} || die "no bindir set?!" ),
- ($self->{'__pod2man'} || die "no pod2man set?!" ),
- )
- ;
- unless(-e $pod2man) {
- # This is rarely needed, I think.
- $pod2man = $self->{'__pod2man'} || die "no pod2man set?!";
- die "Can't find a pod2man?! (". $self->{'__pod2man'} .")\nAborting"
- unless -e $pod2man;
- }
-
- my $command = "$pod2man $switches --lax $file | $render -man";
- # no temp file, just a pipe!
-
- # Thanks to Brendan O'Dea for contributing the following block
- if(Pod::Perldoc::IS_Linux and -t STDOUT
- and my ($cols) = `stty -a` =~ m/\bcolumns\s+(\d+)/
- ) {
- my $c = $cols * 39 / 40;
- $cols = $c > $cols - 2 ? $c : $cols -2;
- $command .= ' -rLL=' . (int $c) . 'n' if $cols > 80;
- }
-
- if(Pod::Perldoc::IS_Cygwin) {
- $command .= ' -c';
- }
-
- # I hear persistent reports that adding a -c switch to $render
- # solves many people's problems. But I also hear that some mans
- # don't have a -c switch, so that unconditionally adding it here
- # would presumably be a Bad Thing -- sburke@cpan.org
-
- $command .= " | col -x" if Pod::Perldoc::IS_HPUX;
-
- defined(&Pod::Perldoc::DEBUG)
- and Pod::Perldoc::DEBUG()
- and print "About to run $command\n";
- ;
-
- my $rslt = `$command`;
-
- my $err;
-
- if( $self->{'__filter_nroff'} ) {
- defined(&Pod::Perldoc::DEBUG)
- and &Pod::Perldoc::DEBUG()
- and print "filter_nroff is set, so filtering...\n";
- $rslt = $self->___Do_filter_nroff($rslt);
- } else {
- defined(&Pod::Perldoc::DEBUG)
- and Pod::Perldoc::DEBUG()
- and print "filter_nroff isn't set, so not filtering.\n";
- }
-
- if (($err = $?)) {
- defined(&Pod::Perldoc::DEBUG)
- and Pod::Perldoc::DEBUG()
- and print "Nonzero exit ($?) while running $command.\n",
- "Falling back to Pod::Perldoc::ToPod\n ",
- ;
- # A desperate fallthru:
- require Pod::Perldoc::ToPod;
- return Pod::Perldoc::ToPod->new->parse_from_file(@_);
-
- } else {
- print $outfh $rslt
- or die "Can't print to $$self{__output_file}: $!";
- }
-
- return;
-}
-
-
-sub ___Do_filter_nroff {
- my $self = shift;
- my @data = split /\n{2,}/, shift;
-
- shift @data while @data and $data[0] !~ /\S/; # Go to header
- shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
- pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
- # 28/Jan/99 perl 5.005, patch 53 1
- join "\n\n", @data;
-}
+ my( $self, $file, $outfh) = @_;
+
+ # We have a pipeline of filters each affecting the reference
+ # in $self->{_text_ref}
+ $self->{_text_ref} = \my $output;
+
+ $self->_parse_with_pod_man( $file );
+ # so far, nroff is an external command so we ensure it worked
+ my $result = $self->_filter_through_nroff;
+ return $self->_fallback_to_pod( @_ ) unless $result == SUCCESS;
+
+ $self->_post_nroff_processing;
+
+ print { $outfh } $output or
+ $self->die( "Can't print to $$self{__output_file}: $!" );
+
+ return;
+ }
+
+sub _fallback_to_pod {
+ my( $self, @args ) = @_;
+ $self->warn( "Falling back to Pod because there was a problem!\n" );
+ require Pod::Perldoc::ToPod;
+ return Pod::Perldoc::ToPod->new->parse_from_file(@_);
+ }
+
+# maybe there's a user setting we should check?
+sub _get_tab_width { 4 }
+
+sub _expand_tabs {
+ my( $self ) = @_;
+
+ my $tab_width = ' ' x $self->_get_tab_width;
+
+ ${ $self->{_text_ref} } =~ s/\t/$tab_width/g;
+ }
+
+sub _post_nroff_processing {
+ my( $self ) = @_;
+
+ if( $self->is_hpux ) {
+ $self->debug( "On HP-UX, I'm going to expand tabs for you\n" );
+ # this used to be a pipe to `col -x` for HP-UX
+ $self->_expand_tabs;
+ }
+
+ if( $self->{'__filter_nroff'} ) {
+ $self->debug( "filter_nroff is set, so filtering\n" );
+ $self->_remove_nroff_header;
+ $self->_remove_nroff_footer;
+ }
+ else {
+ $self->debug( "filter_nroff is not set, so not filtering\n" );
+ }
+
+ $self->_handle_unicode;
+
+ return 1;
+ }
+
+# I don't think this does anything since there aren't two consecutive
+# newlines in the Pod::Man output
+sub _remove_nroff_header {
+ my( $self ) = @_;
+ $self->debug( "_remove_nroff_header is still a stub!\n" );
+ return 1;
+
+# my @data = split /\n{2,}/, shift;
+# shift @data while @data and $data[0] !~ /\S/; # Go to header
+# shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
+ }
+
+# I don't think this does anything since there aren't two consecutive
+# newlines in the Pod::Man output
+sub _remove_nroff_footer {
+ my( $self ) = @_;
+ $self->debug( "_remove_nroff_footer is still a stub!\n" );
+ return 1;
+ ${ $self->{_text_ref} } =~ s/\n\n+.*\w.*\Z//m;
+
+# my @data = split /\n{2,}/, shift;
+# pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
+ # 28/Jan/99 perl 5.005, patch 53 1
+ }
+
+sub _unicode_already_handled {
+ my( $self ) = @_;
+
+ $self->_have_groff_with_utf8 ||
+ 1 # so, we don't have a case that needs _handle_unicode
+ ;
+ }
+
+sub _handle_unicode {
+# this is the job of preconv
+# we don't need this with groff 1.20 and later.
+ my( $self ) = @_;
+
+ return 1 if $self->_unicode_already_handled;
+
+ require Encode;
+
+ # it's UTF-8 here, but we need character data
+ my $text = Encode::decode( 'UTF-8', ${ $self->{_text_ref} } ) ;
+
+# http://www.mail-archive.com/groff@gnu.org/msg01378.html
+# http://linux.die.net/man/7/groff_char
+# http://www.gnu.org/software/groff/manual/html_node/Using-Symbols.html
+# http://lists.gnu.org/archive/html/groff/2011-05/msg00007.html
+# http://www.simplicidade.org/notes/archives/2009/05/fixing_the_pod.html
+# http://lists.freebsd.org/pipermail/freebsd-questions/2011-July/232239.html
+ $text =~ s/(\P{ASCII})/
+ sprintf '\\[u%04X]', ord $1
+ /eg;
+
+ # should we encode?
+ ${ $self->{_text_ref} } = $text;
+ }
1;
@@ -148,7 +529,7 @@ Pod::Perldoc::ToMan - let Perldoc render Pod as man pages
=head1 DESCRIPTION
This is a "plug-in" class that allows Perldoc to use
-Pod::Man and C<nroff> for reading Pod pages.
+Pod::Man and C<groff> for reading Pod pages.
The following options are supported: center, date, fixed, fixedbold,
fixeditalic, fixedbolditalic, quotes, release, section
@@ -170,6 +551,8 @@ L<Pod::Man>, L<Pod::Perldoc>, L<Pod::Perldoc::ToNroff>
=head1 COPYRIGHT AND DISCLAIMERS
+Copyright (c) 2011 brian d foy. All rights reserved.
+
Copyright (c) 2002,3,4 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify it
@@ -181,10 +564,12 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm
index 991c1e3269c..2e92f2a134e 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToNroff.pm
@@ -1,12 +1,12 @@
-
-require 5;
package Pod::Perldoc::ToNroff;
use strict;
use warnings;
+use parent qw(Pod::Perldoc::BaseTo);
-# This is unlike ToMan.pm in that it emits the raw nroff source!
+use vars qw($VERSION);
+$VERSION = '3.17';
-use base qw(Pod::Perldoc::BaseTo);
+# This is unlike ToMan.pm in that it emits the raw nroff source!
sub is_pageable { 1 } # well, if you ask for it...
sub write_with_binmode { 0 }
@@ -29,13 +29,13 @@ sub new { return bless {}, ref($_[0]) || $_[0] }
sub parse_from_file {
my $self = shift;
my $file = $_[0];
-
+
my @options =
map {; $_, $self->{$_} }
grep !m/^_/s,
keys %$self
;
-
+
defined(&Pod::Perldoc::DEBUG)
and Pod::Perldoc::DEBUG()
and print "About to call new Pod::Man ",
@@ -94,10 +94,12 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm
index c3173d43702..6c15c02a781 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToPod.pm
@@ -1,18 +1,11 @@
-
-# This class is just a hack to act as a "formatter" for
-# actually unformatted Pod.
-#
-# Note that this isn't the same as just passing thru whatever
-# we're given -- we pass thru only the pod source, and suppress
-# the Perl code (or whatever non-pod stuff is in the source file).
-
-
-require 5;
package Pod::Perldoc::ToPod;
use strict;
use warnings;
+use parent qw(Pod::Perldoc::BaseTo);
+
+use vars qw($VERSION);
+$VERSION = '3.17';
-use base qw(Pod::Perldoc::BaseTo);
sub is_pageable { 1 }
sub write_with_binmode { 0 }
sub output_extension { 'pod' }
@@ -22,10 +15,10 @@ sub new { return bless {}, ref($_[0]) || $_[0] }
sub parse_from_file {
my( $self, $in, $outfh ) = @_;
- open(IN, "<", $in) or die "Can't read-open $in: $!\nAborting";
+ open(IN, "<", $in) or $self->die( "Can't read-open $in: $!\nAborting" );
my $cut_mode = 1;
-
+
# A hack for finding things between =foo and =cut, inclusive
local $_;
while (<IN>) {
@@ -37,10 +30,10 @@ sub parse_from_file {
}
}
next if $cut_mode;
- print $outfh $_ or die "Can't print to $outfh: $!";
+ print $outfh $_ or $self->die( "Can't print to $outfh: $!" );
}
-
- close IN or die "Can't close $in: $!";
+
+ close IN or $self->die( "Can't close $in: $!" );
return;
}
@@ -84,10 +77,12 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallencpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm
index 14d419fc313..a7d4739a6f0 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToRtf.pm
@@ -1,17 +1,10 @@
-
-require 5;
package Pod::Perldoc::ToRtf;
use strict;
use warnings;
-use vars qw($VERSION);
-
-use base qw( Pod::Simple::RTF );
-
-$VERSION # so that ->VERSION is happy
-# stop CPAN from seeing this
- =
-$Pod::Simple::RTF::VERSION;
+use parent qw( Pod::Simple::RTF );
+use vars qw($VERSION);
+$VERSION = '3.17';
sub is_pageable { 0 }
sub write_with_binmode { 0 }
@@ -20,11 +13,11 @@ sub output_extension { 'rtf' }
sub page_for_perldoc {
my($self, $tempfile, $perldoc) = @_;
return unless $perldoc->IS_MSWin32;
-
+
my $rtf_pager = $ENV{'RTFREADER'} || 'write.exe';
-
+
$perldoc->aside( "About to launch <\"$rtf_pager\" \"$tempfile\">\n" );
-
+
return 1 if system( qq{"$rtf_pager"}, qq{"$tempfile"} ) == 0;
return 0;
}
@@ -79,10 +72,12 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTerm.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTerm.pm
new file mode 100644
index 00000000000..dddc4c8fce7
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTerm.pm
@@ -0,0 +1,90 @@
+package Pod::Perldoc::ToTerm;
+use strict;
+use warnings;
+
+use vars qw($VERSION);
+$VERSION = '3.17';
+
+use parent qw(Pod::Perldoc::BaseTo);
+
+sub is_pageable { 1 }
+sub write_with_binmode { 0 }
+sub output_extension { 'txt' }
+
+use Pod::Text::Termcap ();
+
+sub alt { shift->_perldoc_elem('alt' , @_) }
+sub indent { shift->_perldoc_elem('indent' , @_) }
+sub loose { shift->_perldoc_elem('loose' , @_) }
+sub quotes { shift->_perldoc_elem('quotes' , @_) }
+sub sentence { shift->_perldoc_elem('sentence', @_) }
+sub width { shift->_perldoc_elem('width' , @_) }
+
+sub new { return bless {}, ref($_[0]) || $_[0] }
+
+sub parse_from_file {
+ my $self = shift;
+
+ my @options =
+ map {; $_, $self->{$_} }
+ grep !m/^_/s,
+ keys %$self
+ ;
+
+ defined(&Pod::Perldoc::DEBUG)
+ and Pod::Perldoc::DEBUG()
+ and print "About to call new Pod::Text::Termcap ",
+ $Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '',
+ "with options: ",
+ @options ? "[@options]" : "(nil)", "\n";
+ ;
+
+ Pod::Text::Termcap->new(@options)->parse_from_file(@_);
+}
+
+1;
+
+=head1 NAME
+
+Pod::Perldoc::ToTerm - render Pod with terminal escapes
+
+=head1 SYNOPSIS
+
+ perldoc -o term Some::Modulename
+
+=head1 DESCRIPTION
+
+This is a "plug-in" class that allows Perldoc to use
+Pod::Text as a formatter class.
+
+It supports the following options, which are explained in
+L<Pod::Text>: alt, indent, loose, quotes, sentence, width
+
+For example:
+
+ perldoc -o term -w indent:5 Some::Modulename
+
+=head1 CAVEAT
+
+This module may change to use a different text formatter class in the
+future, and this may change what options are supported.
+
+=head1 SEE ALSO
+
+L<Pod::Text>, L<Pod::Text::Termcap>, L<Pod::Perldoc>
+
+=head1 COPYRIGHT AND DISCLAIMERS
+
+Copyright (c) 2011 Mark Allen.
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
+
+=head1 AUTHOR
+
+Mark Allen C<< <mallen@cpan.org> >>
+
+=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm
index 7d1784cd59a..0e4e2dacf4d 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToText.pm
@@ -1,10 +1,11 @@
-
-require 5;
package Pod::Perldoc::ToText;
use strict;
use warnings;
-use base qw(Pod::Perldoc::BaseTo);
+use vars qw($VERSION);
+$VERSION = '3.17';
+
+use parent qw(Pod::Perldoc::BaseTo);
sub is_pageable { 1 }
sub write_with_binmode { 0 }
@@ -23,13 +24,13 @@ sub new { return bless {}, ref($_[0]) || $_[0] }
sub parse_from_file {
my $self = shift;
-
+
my @options =
map {; $_, $self->{$_} }
grep !m/^_/s,
keys %$self
;
-
+
defined(&Pod::Perldoc::DEBUG)
and Pod::Perldoc::DEBUG()
and print "About to call new Pod::Text ",
@@ -85,10 +86,12 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm
index 5b29fd996e5..fb8da15c245 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToTk.pm
@@ -1,10 +1,11 @@
-
-require 5;
package Pod::Perldoc::ToTk;
use strict;
use warnings;
-use base qw(Pod::Perldoc::BaseTo);
+use vars qw($VERSION);
+$VERSION = '3.17';
+
+use parent qw(Pod::Perldoc::BaseTo);
sub is_pageable { 1 }
sub write_with_binmode { 0 }
@@ -20,12 +21,30 @@ sub forky { shift->_perldoc_elem('forky' , @_) }
use Pod::Perldoc ();
use File::Spec::Functions qw(catfile);
-use Tk;
-die join '', __PACKAGE__, " doesn't work nice with Tk.pm version $Tk::VERSION"
- if $Tk::VERSION eq '800.003';
+BEGIN{ # Tk is not core, but this is
+ eval { require Tk } ||
+ __PACKAGE__->die( <<"HERE" );
+You must have the Tk module to use Pod::Perldoc::ToTk.
+If you have it installed, ensure it's in your Perl library
+path.
+HERE
+
+ __PACKAGE__->die(
+ __PACKAGE__,
+ " doesn't work nice with Tk.pm version $Tk::VERSION"
+ ) if $Tk::VERSION eq '800.003';
+ }
+
BEGIN { eval { require Tk::FcyEntry; }; };
-use Tk::Pod;
+BEGIN{ # Tk::Pod is not core, but this is
+ eval { require Tk::Pod } ||
+ __PACKAGE__->die( <<"HERE" );
+You must have the Tk::Pod module to use Pod::Perldoc::ToTk.
+If you have it installed, ensure it's in your Perl library
+path.
+HERE
+ }
# The following was adapted from "tkpod" in the Tk-Pod dist.
@@ -35,29 +54,29 @@ sub parse_from_file {
if($self->{'forky'}) {
return if fork; # i.e., parent process returns
}
-
+
$Input_File =~ s{\\}{/}g
- if Pod::Perldoc::IS_MSWin32 or Pod::Perldoc::IS_Dos
+ if $self->is_mswin32 or $self->is_dos
# and maybe OS/2
;
-
+
my($tk_opt, $tree);
$tree = $self->{'tree' };
$tk_opt = $self->{'tk_opt'};
-
+
#require Tk::ErrorDialog;
-
+
# Add 'Tk' subdirectories to search path so, e.g.,
# 'Scrolled' will find doc in 'Tk/Scrolled'
-
+
if( $tk_opt ) {
push @INC, grep -d $_, map catfile($_,'Tk'), @INC;
}
-
+
my $mw = MainWindow->new();
#eval 'use blib "/home/e/eserte/src/perl/Tk-App";require Tk::App::Debug';
$mw->withdraw;
-
+
# CDE use Font Settings if available
my $ufont = $mw->optionGet('userFont','UserFont'); # fixed width
my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional
@@ -67,18 +86,18 @@ sub parse_from_file {
$mw->optionAdd('*Entry.Font', $ufont);
$mw->optionAdd('*Text.Font', $ufont);
}
-
+
$mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0);
-
+
$mw->Pod(
'-file' => $Input_File,
(($Tk::Pod::VERSION >= 4) ? ('-tree' => $tree) : ())
)->focusNext;
-
+
# xxx dirty but it works. A simple $mw->destroy if $mw->children
# does not work because Tk::ErrorDialogs could be created.
# (they are withdrawn after Ok instead of destory'ed I guess)
-
+
if ($mw->children) {
$mw->repeat(1000, sub {
# ErrorDialog is withdrawn not deleted :-(
@@ -122,10 +141,13 @@ L<Tk::Pod>, L<Pod::Perldoc>
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke C<sburke@cpan.org>, with significant portions copied from
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>;
+Sean M. Burke C<< <sburke@cpan.org> >>;
+significant portions copied from
F<tkpod> in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al.
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm
index 439e736c20e..96f35c4f4b7 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Perldoc/ToXml.pm
@@ -1,17 +1,12 @@
-
-require 5;
package Pod::Perldoc::ToXml;
use strict;
use warnings;
use vars qw($VERSION);
-use base qw( Pod::Simple::XMLOutStream );
-
-$VERSION # so that ->VERSION is happy
-# stop CPAN from seeing this
- =
-$Pod::Simple::XMLOutStream::VERSION;
+use parent qw( Pod::Simple::XMLOutStream );
+use vars qw($VERSION);
+$VERSION = '3.17';
sub is_pageable { 0 }
sub write_with_binmode { 0 }
@@ -57,10 +52,12 @@ merchantability or fitness for a particular purpose.
=head1 AUTHOR
-Current maintainer: Adriano R. Ferreira <ferreira@cpan.org>
+Current maintainer: Mark Allen C<< <mallen@cpan.org> >>
Past contributions from:
-Sean M. Burke <sburke@cpan.org>
+brian d foy C<< <bdfoy@cpan.org> >>
+Adriano R. Ferreira C<< <ferreira@cpan.org> >>,
+Sean M. Burke C<< <sburke@cpan.org> >>
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/PlainText.pm b/Master/tlpkg/tlperl/lib/Pod/PlainText.pm
index 0dce1799b2b..06df184097f 100644
--- a/Master/tlpkg/tlperl/lib/Pod/PlainText.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/PlainText.pm
@@ -29,7 +29,7 @@ use vars qw(@ISA %ESCAPES $VERSION);
# by Pod::Usage.
@ISA = qw(Pod::Select);
-$VERSION = '2.04';
+$VERSION = '2.05';
BEGIN {
if ($] < 5.006) {
@@ -390,7 +390,7 @@ sub cmd_for {
my $self = shift;
local $_ = shift;
my $line = shift;
- return unless s/^text\b[ \t]*\n?//;
+ return unless s/^text\b[ \t]*\r?\n?//;
$self->verbatim ($_, $line);
}
@@ -485,7 +485,7 @@ sub item {
my $margin = $$self{MARGIN};
$$self{MARGIN} = $indent;
my $output = $self->reformat ($tag);
- $output =~ s/\n*$/\n/;
+ $output =~ s/[\r\n]*$/\n/;
$self->output ($output);
$$self{MARGIN} = $margin;
$self->output ($self->reformat ($_)) if /\S/;
@@ -514,7 +514,7 @@ sub wrap {
my $spaces = ' ' x $$self{MARGIN};
my $width = $$self{width} - $$self{MARGIN};
while (length > $width) {
- if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) {
+ if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) {
$output .= $spaces . $1 . "\n";
} else {
last;
@@ -535,8 +535,8 @@ sub reformat {
# munging to support that. Otherwise, smash all repeated whitespace.
if ($$self{sentence}) {
s/ +$//mg;
- s/\.\n/. \n/g;
- s/\n/ /g;
+ s/\.\r?\n/. \n/g;
+ s/[\r\n]+/ /g;
s/ +/ /g;
} else {
s/\s+/ /g;
@@ -723,6 +723,8 @@ subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>.
=head1 SEE ALSO
+B<Pod::PlainText> is part of the L<Pod::Parser> distribution.
+
L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>,
pod2text(1)
diff --git a/Master/tlpkg/tlperl/lib/Pod/Select.pm b/Master/tlpkg/tlperl/lib/Pod/Select.pm
index 4724cb79cf9..300eee537e8 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Select.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Select.pm
@@ -11,7 +11,7 @@ package Pod::Select;
use strict;
use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections);
-$VERSION = '1.36'; ## Current version of this package
+$VERSION = '1.51'; ## Current version of this package
require 5.005; ## requires this Perl version or later
#############################################################################
@@ -740,6 +740,8 @@ Brad Appleton E<lt>bradapp@enteract.comE<gt>
Based on code for B<pod2text> written by
Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
+B<Pod::Select> is part of the L<Pod::Parser> distribution.
+
=cut
1;
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple.pm b/Master/tlpkg/tlperl/lib/Pod/Simple.pm
index 909a2ec8341..ad7a19b8eff 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.16';
+$VERSION = '3.20';
@Known_formatting_codes = qw(I B C L E F S X Z);
%Known_formatting_codes = map(($_=>1), @Known_formatting_codes);
@@ -93,10 +93,15 @@ __PACKAGE__->_accessorize(
'codes_in_verbatim', # for PseudoPod extensions
'code_handler', # coderef to call when a code (non-pod) line is seen
- 'cut_handler', # coderef to call when a =cut line is seen
+ 'cut_handler', # ... when a =cut line is seen
+ 'pod_handler', # ... when a =pod line is seen
+ 'whiteline_handler', # ... when a line with only whitespace is seen
#Called like:
# $code_handler->($line, $self->{'line_count'}, $self) if $code_handler;
# $cut_handler->($line, $self->{'line_count'}, $self) if $cut_handler;
+ # $pod_handler->($line, $self->{'line_count'}, $self) if $pod_handler;
+ # $wl_handler->($line, $self->{'line_count'}, $self) if $wl_handler;
+ 'parse_empty_lists', # whether to acknowledge empty =over/=back blocks
);
@@ -356,7 +361,8 @@ sub parse_string_document {
next unless defined $line_group and length $line_group;
pos($line_group) = 0;
while($line_group =~
- m/([^\n\r]*)((?:\r?\n)?)/g
+ m/([^\n\r]*)(\r?\n?)/g # supports \r, \n ,\r\n
+ #m/([^\n\r]*)((?:\r?\n)?)/g
) {
#print(">> $1\n"),
$self->parse_lines($1)
@@ -406,16 +412,30 @@ sub parse_file {
# By here, $source is a FH.
$self->{'source_fh'} = $source;
-
+
my($i, @lines);
until( $self->{'source_dead'} ) {
splice @lines;
+
for($i = MANY_LINES; $i--;) { # read those many lines at a time
local $/ = $NL;
push @lines, scalar(<$source>); # readline
last unless defined $lines[-1];
# but pass thru the undef, which will set source_dead to true
}
+
+ my $at_eof = ! $lines[-1]; # keep track of the undef
+ pop @lines if $at_eof; # silence warnings
+
+ # be eol agnostic
+ s/\r\n?/\n/g for @lines;
+
+ # make sure there are only one line elements for parse_lines
+ @lines = split(/(?<=\n)/, join('', @lines));
+
+ # push the undef back after popping it to set source_dead to true
+ push @lines, undef if $at_eof;
+
$self->parse_lines(@lines);
}
delete($self->{'source_fh'}); # so it can be GC'd
@@ -960,7 +980,7 @@ sub _treat_Zs { # Nix Z<...>'s
# possibly a man page name (like "crontab(5)" is).
#
-############# Not implemented, I guess.
+############# The "raw" attribute that is already there.
# Sixth:
# The raw original L<...> content, before text is split on "|", "/", etc,
# and before E<...> codes are expanded.
@@ -1330,6 +1350,10 @@ sub _treat_Es {
DEBUG > 1 and print "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 ",
defined($charnum) ? $charnum : "undef", ".\n";
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple.pod b/Master/tlpkg/tlperl/lib/Pod/Simple.pod
index d3f168d7e0a..a8ad211d3b6 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple.pod
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple.pod
@@ -85,9 +85,9 @@ the last call) ends with an C<undef> value.
=item C<< $parser->content_seen >>
-This returns true only if there has been any real content seen
-for this document.
-
+This returns true only if there has been any real content seen for this
+document. Returns false in cases where the document contains content,
+but does not make use of any Pod markup.
=item C<< I<SomeClass>->filter( I<$filename> ); >>
@@ -211,6 +211,117 @@ that you don't want I<any> lines indented. You can do something like this:
=back
+=head1 TERTIARY METHODS
+
+=over
+
+=item C<< $parser->abandon_output_fh() >>X<abandon_output_fh>
+
+Cancel output to the file handle. Any POD read by the C<$parser> is not
+effected.
+
+=item C<< $parser->abandon_output_string() >>X<abandon_output_string>
+
+Cancel output to the output string. Any POD read by the C<$parser> is not
+effected.
+
+=item C<< $parser->accept_code( @codes ) >>X<accept_code>
+
+Alias for L<< accept_codes >>.
+
+=item C<< $parser->accept_codes( @codes ) >>X<accept_codes>
+
+Allows C<$parser> to accept a list of L<perlpod/Formatting Codes>. This can be
+used to implement user-defined codes.
+
+=item C<< $parser->accept_directive_as_data( @directives ) >>X<accept_directive_as_data>
+
+Allows C<$parser> to accept a list of directives for data paragraphs. A
+directive is the label of a L<perlpod/Command Paragraph>. A data paragraph is
+one delimited by C<< =begin/=for/=end >> directives. This can be used to
+implement user-defined directives.
+
+=item C<< $parser->accept_directive_as_processed( @directives ) >>X<accept_directive_as_processed>
+
+Allows C<$parser> to accept a list of directives for processed paragraphs. A
+directive is the label of a L<perlpod/Command Paragraph>. A processed
+paragraph is also known as L<perlpod/Ordinary Paragraph>. This can be used to
+implement user-defined directives.
+
+=item C<< $parser->accept_directive_as_verbatim( @directives ) >>X<accept_directive_as_verbatim>
+
+Allows C<$parser> to accept a list of directives for L<perlpod/Verbatim
+Paragraph>. A directive is the label of a L<perlpod/Command Paragraph>. This
+can be used to implement user-defined directives.
+
+=item C<< $parser->accept_target( @targets ) >>X<accept_target>
+
+Alias for L<< accept_targets >>.
+
+=item C<< $parser->accept_target_as_text( @targets ) >>X<accept_target_as_text>
+
+Alias for L<< accept_targets_as_text >>.
+
+=item C<< $parser->accept_targets( @targets ) >>X<accept_targets>
+
+Accepts targets for C<< =begin/=for/=end >> sections of the POD.
+
+=item C<< $parser->accept_targets_as_text( @targets ) >>X<accept_targets_as_text>
+
+Accepts targets for C<< =begin/=for/=end >> sections that should be parsed as
+POD. For details, see L<< perlpodspec/About Data Paragraphs >>.
+
+=item C<< $parser->any_errata_seen() >>X<any_errata_seen>
+
+Used to check if any errata was seen.
+
+I<Example:>
+
+ die "too many errors\n" if $parser->any_errata_seen();
+
+=item C<< $parser->parse_from_file( $source, $to ) >>X<parse_from_file>
+
+Parses from C<$source> file to C<$to> file. Similar to L<<
+Pod::Parser/parse_from_file >>.
+
+=item C<< $parser->scream( @error_messages ) >>X<scream>
+
+Log an error that can't be ignored.
+
+=item C<< $parser->unaccept_code( @codes ) >>X<unaccept_code>
+
+Alias for L<< unaccept_codes >>.
+
+=item C<< $parser->unaccept_codes( @codes ) >>X<unaccept_codes>
+
+Removes C<< @codes >> as valid codes for the parse.
+
+=item C<< $parser->unaccept_directive( @directives ) >>X<unaccept_directive>
+
+Alias for L<< unaccept_directives >>.
+
+=item C<< $parser->unaccept_directives( @directives ) >>X<unaccept_directives>
+
+Removes C<< @directives >> as valid directives for the parse.
+
+=item C<< $parser->unaccept_target( @targets ) >>X<unaccept_target>
+
+Alias for L<< unaccept_targets >>.
+
+=item C<< $parser->unaccept_targets( @targets ) >>X<unaccept_targets>
+
+Removes C<< @targets >> as valid targets for the parse.
+
+=item C<< $parser->version_report() >>X<version_report>
+
+Returns a string describing the version.
+
+=item C<< $parser->whine( @error_messages ) >>X<whine>
+
+Log an error unless C<< $parser->no_whining( TRUE ); >>.
+
+=back
+
=head1 CAVEATS
This is just a beta release -- there are a good number of things still
@@ -271,4 +382,14 @@ Pod::Simple is maintained by:
=back
+Documentation has been contributed by:
+
+=over
+
+=item * Gabor Szabo C<szabgab@gmail.com>
+
+=item * Shawn H Corey C<SHCOREY at cpan.org>
+
+=back
+
=cut
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm
index 4765744d82c..c17cfd0ad51 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm
@@ -23,7 +23,7 @@ use integer; # vroom!
use strict;
use Carp ();
use vars qw($VERSION );
-$VERSION = '3.16';
+$VERSION = '3.20';
#use constant DEBUG => 7;
BEGIN {
require Pod::Simple;
@@ -42,6 +42,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines)
my $code_handler = $self->{'code_handler'};
my $cut_handler = $self->{'cut_handler'};
+ my $wl_handler = $self->{'whiteline_handler'};
$self->{'line_count'} ||= 0;
my $scratch;
@@ -191,7 +192,12 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines)
# TODO: add to docs: Note: this may cause cuts to be processed out
# of order relative to pods, but in order relative to code.
- } elsif($line =~ m/^\s*$/s) { # it's a blank line
+ } elsif($line =~ m/^(\s*)$/s) { # it's a blank line
+ if (defined $1 and $1 =~ /[^\S\r\n]/) { # it's a white line
+ $wl_handler->(map $_, $line, $self->{'line_count'}, $self)
+ if $wl_handler;
+ }
+
if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') {
DEBUG > 1 and print "Saving blank line at line ${$self}{'line_count'}\n";
push @{$paras->[-1]}, $line;
@@ -592,7 +598,8 @@ sub _ponder_paragraph_buffer {
if($para_type eq '=item') {
my $over;
- unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
+ unless(@$curr_open and
+ $over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) {
$self->whine(
$para->[1]{'start_line'},
"'=item' outside of any '=over'"
@@ -917,7 +924,7 @@ sub _ponder_begin {
$para->[1]{'title'} = $title if ($title);
$para->[1]{'target'} = $target; # without any ':'
$content = $target; # strip off the title
-
+
$content =~ s/^:!/!:/s;
my $neg; # whether this is a negation-match
$neg = 1 if $content =~ s/^!//s;
@@ -983,7 +990,7 @@ sub _ponder_end {
$content =~ s/^\s+//s;
$content =~ s/\s+$//s;
DEBUG and print "Ogling '=end $content' directive\n";
-
+
unless(length($content)) {
$self->whine(
$para->[1]{'start_line'},
@@ -1039,7 +1046,7 @@ sub _ponder_end {
# what's that for?
$self->{'content_seen'} ||= 1;
- $self->_handle_element_end( my $scratch = 'for' );
+ $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";
pop @$curr_open;
@@ -1092,7 +1099,18 @@ sub _ponder_pod {
"=pod directives shouldn't be over one line long! Ignoring all "
. (@$para - 2) . " lines of content"
) if @$para > 3;
- # Content is always ignored.
+
+ # Content ignored unless 'pod_handler' is set
+ if (my $pod_handler = $self->{'pod_handler'}) {
+ my ($line_num, $line) = map $_, $para->[1]{'start_line'}, $para->[2];
+ $line = $line eq '' ? "=pod" : "=pod $line"; # imitate cut_handler output
+ $pod_handler->($line, $line_num, $self);
+ }
+
+ # The surrounding methods set content_seen, so let us remain consistent.
+ # I do not know why it was not here before -- should it not be here?
+ # $self->{'content_seen'} ||= 1;
+
return;
}
@@ -1105,10 +1123,13 @@ sub _ponder_over {
$list_type = $self->_get_initial_item_type($paras->[0]);
} elsif($paras->[0][0] eq '=back') {
- # Ignore empty lists. TODO: make this an option?
- shift @$paras;
- return 1;
-
+ # Ignore empty lists by default
+ if ($self->{'parse_empty_lists'}) {
+ $list_type = 'empty';
+ } else {
+ shift @$paras;
+ return 1;
+ }
} elsif($paras->[0][0] eq '~end') {
$self->whine(
$para->[1]{'start_line'},
@@ -1169,7 +1190,7 @@ sub _ponder_back {
#my $over = pop @$curr_open;
$self->{'content_seen'} ||= 1;
$self->_handle_element_end( my $scratch =
- 'over-' . ( (pop @$curr_open)->[1]{'~type'} )
+ 'over-' . ( (pop @$curr_open)->[1]{'~type'} ), $para->[1]
);
} else {
DEBUG > 1 and print "=back found without a matching =over. Stack: (",
@@ -1185,7 +1206,8 @@ sub _ponder_back {
sub _ponder_item {
my ($self,$para,$curr_open,$paras) = @_;
my $over;
- unless(@$curr_open and ($over = $curr_open->[-1])->[0] eq '=over') {
+ unless(@$curr_open and
+ $over = (grep { $_->[0] eq '=over' } @$curr_open)[-1]) {
$self->whine(
$para->[1]{'start_line'},
"'=item' outside of any '=over'"
@@ -1383,7 +1405,7 @@ sub _ponder_Verbatim {
for(my $i = 2; $i < @$para; $i++) {
foreach my $line ($para->[$i]) { # just for aliasing
# Strip indentation.
- $line =~ s/^\E$indent// if $indent
+ $line =~ s/^\Q$indent// if $indent
&& !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted});
while( $line =~
# Sort of adapted from Text::Tabs -- yes, it's hardwired in that
@@ -1471,7 +1493,9 @@ sub _closers_for_all_curr_open {
$copy[-1] = '' unless defined $copy[-1];
# since =over's don't have targets
}
-
+
+ $copy[1]{'fake-closer'} = 1;
+
DEBUG and print "Queuing up fake-o event: ", pretty(\@copy), "\n";
unshift @closers, \@copy;
}
@@ -1638,6 +1662,10 @@ sub _treelet_from_formatting_codes {
my @stack;
my @lineage = ($treelet);
+ my $raw = ''; # raw content of L<> fcode before splitting/processing
+ # XXX 'raw' is not 100% accurate: all surrounding whitespace is condensed
+ # into just 1 ' '. Is this the regex's doing or 'raw's?
+ my $inL = 0;
DEBUG > 4 and print "Paragraph:\n$para\n\n";
@@ -1709,7 +1737,13 @@ sub _treelet_from_formatting_codes {
}
push @lineage, [ substr($1,0,1), {}, ]; # new node object
push @{ $lineage[-2] }, $lineage[-1];
-
+ if ('L' eq substr($1,0,1)) {
+ $raw = $inL ? $raw.$1 : ''; # reset raw content accumulator
+ $inL = 1;
+ } else {
+ $raw .= $1 if $inL;
+ }
+
} elsif(defined $4) {
DEBUG > 3 and print "Found apparent complex end-text code \"$3$4\"\n";
# This is where it gets messy...
@@ -1743,6 +1777,14 @@ sub _treelet_from_formatting_codes {
pop @stack;
pop @lineage;
+
+ unless (@stack) { # not in an L if there are no open fcodes
+ $inL = 0;
+ if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') {
+ $lineage[-1][-1][1]{'raw'} = $raw
+ }
+ }
+ $raw .= $3.$4 if $inL;
} elsif(defined $5) {
DEBUG > 3 and print "Found apparent simple end-text code \"$5\"\n";
@@ -1764,10 +1806,21 @@ sub _treelet_from_formatting_codes {
push @{ $lineage[-1] }, $5;
}
+ unless (@stack) { # not in an L if there are no open fcodes
+ $inL = 0;
+ if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') {
+ $lineage[-1][-1][1]{'raw'} = $raw
+ }
+ }
+ $raw .= $5 if $inL;
+
} elsif(defined $6) {
DEBUG > 3 and print "Found stuff \"$6\"\n";
push @{ $lineage[-1] }, $6;
-
+ $raw .= $6 if $inL;
+ # XXX does not capture multiplace whitespaces -- 'raw' ends up with
+ # at most 1 leading/trailing whitespace, why not all of it?
+
} else {
# should never ever ever ever happen
DEBUG and print "AYYAYAAAAA at line ", __LINE__, "\n";
@@ -1795,7 +1848,7 @@ sub _treelet_from_formatting_codes {
"Unterminated $x sequence",
);
}
-
+
return $treelet;
}
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm
index 6aca3894191..c97267a86ba 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.16';
+$VERSION = '3.20';
@ISA = ('Pod::Simple::Methody');
BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
? \&Pod::Simple::DEBUG
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm
index b3de557af3f..57733028427 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm
@@ -3,7 +3,7 @@ require 5;
package Pod::Simple::Debug;
use strict;
use vars qw($VERSION );
-$VERSION = '3.16';
+$VERSION = '3.20';
sub import {
my($value,$variable);
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsText.pm
index 5609c71e342..5e2d7ebf5ff 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.16';
+$VERSION = '3.20';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/DumpAsXML.pm
index beef7caad8a..e43422bbd7c 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.16';
+$VERSION = '3.20';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
index 9d7d069645a..12fad403589 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm
@@ -10,7 +10,7 @@ use vars qw(
$Doctype_decl $Content_decl
);
@ISA = ('Pod::Simple::PullParser');
-$VERSION = '3.16';
+$VERSION = '3.20';
BEGIN {
if(defined &DEBUG) { } # no-op
@@ -491,8 +491,11 @@ sub _do_middle_main_loop {
$name = $self->do_section($name, $token) if defined $name;
print $fh "<a ";
- print $fh "class='u' href='#___top' title='click to go to top of document'\n"
- if $tagname =~ m/^head\d$/s;
+ if ($tagname =~ m/^head\d$/s) {
+ print $fh "class='u'", $self->index
+ ? " href='#___top' title='click to go to top of document'\n"
+ : "\n";
+ }
if(defined $name) {
my $esc = esc( $self->section_name_tidy( $name ) );
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm
index 7686cd41477..52e77bcc1b8 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.16';
+$VERSION = '3.20';
@ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML!
# TODO: nocontents stylesheets. Strike some of the color variations?
@@ -1082,7 +1082,7 @@ Example:
% mkdir out_html
% perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go @INC out_html
(to convert the pod from Perl's @INC
- files under the directory ../htmlversion)
+ files under the directory ./out_html)
(Note that the command line there contains a literal atsign-I-N-C. This
is handled as a special case by batch_convert, in order to save you having
@@ -1095,7 +1095,7 @@ Example:
% chmod og-rx ../seekrut
% perl -MPod::Simple::HTMLBatch -e Pod::Simple::HTMLBatch::go . ../htmlversion
(to convert the pod under the current dir into HTML
- files under the directory ../htmlversion)
+ files under the directory ./seekrut)
Example:
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm
index 7d77ebb1f82..5aa5bc19897 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.16';
+$VERSION = '3.20';
use strict;
use Pod::Simple::BlackBox;
use vars qw($VERSION );
-$VERSION = '3.16';
+$VERSION = '3.20';
use overload( # So it'll stringify nice
'""' => \&Pod::Simple::BlackBox::stringify_lol,
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Methody.pm
index 0d69b7a1d99..4113daf2351 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.16';
+$VERSION = '3.20';
@ISA = ('Pod::Simple');
# Yes, we could use named variables, but I want this to be impose
@@ -32,7 +32,7 @@ sub _handle_element_end {
( $_[0]->can( 'end_' . $_[1] )
|| return
)->(
- $_[0]
+ $_[0], $_[2]
);
}
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm
index 622909bb2b1..e85084a1c26 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.16';
+$VERSION = '3.20';
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 4033213e825..c9726fd564a 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm
@@ -1,7 +1,7 @@
require 5;
package Pod::Simple::PullParser;
-$VERSION = '3.16';
+$VERSION = '3.20';
use Pod::Simple ();
BEGIN {@ISA = ('Pod::Simple')}
@@ -231,6 +231,8 @@ sub unget_token {
sub set_source {
my $self = shift @_;
return $self->{'source_fh'} unless @_;
+ Carp::croak("Cannot assign new source to pull parser; create a new instance, instead")
+ if $self->{'source_fh'} || $self->{'source_scalar_ref'} || $self->{'source_arrayref'};
my $handle;
if(!defined $_[0]) {
Carp::croak("Can't use empty-string as a source for set_source");
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm
index 8b12e646dcc..a45aba18bae 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.16';
+$VERSION = '3.20';
sub new { # Class->new(tagname);
my $class = shift;
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserStartToken.pm
index 232ef235f38..e9fbaa2b5ec 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.16';
+$VERSION = '3.20';
sub new { # Class->new(tagname, optional_attrhash);
my $class = shift;
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserTextToken.pm
index a7fcb0fbb16..34985fdfb03 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.16';
+$VERSION = '3.20';
sub new { # Class->new(text);
my $class = shift;
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserToken.pm
index ad6ebf38b44..b323ece2a32 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.16';
+$VERSION = '3.20';
use strict;
sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm
index 7dbc643de52..0d184e3a66b 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.16';
+$VERSION = '3.20';
use Pod::Simple::PullParser ();
BEGIN {@ISA = ('Pod::Simple::PullParser')}
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm
index b7d209b1031..7e507e62b95 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm
@@ -4,7 +4,7 @@ package Pod::Simple::Search;
use strict;
use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY);
-$VERSION = '3.16'; ## Current version of this package
+$VERSION = '3.20'; ## Current version of this package
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level
use Carp ();
@@ -25,7 +25,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',
+ 'limit_re', 'shadows', 'verbose', 'name2path', 'path2name', 'recurse',
);
#==========================================================================
@@ -39,6 +39,7 @@ sub new {
sub init {
my $self = shift;
$self->inc(1);
+ $self->recurse(1);
$self->verbose(DEBUG);
return $self;
}
@@ -127,9 +128,11 @@ 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) =
+ my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress,
+ $path2name, $name2path, $recurse) =
map scalar($self->$_()),
- qw(laborious verbose shadows limit_re callback progress path2name name2path);
+ qw(laborious verbose shadows limit_re callback progress
+ path2name name2path recurse);
my($file, $shortname, $isdir, $modname_bits);
return sub {
@@ -137,6 +140,11 @@ sub _make_search_callback {
if($isdir) { # this never gets called on the startdir itself, just subdirs
+ unless( $recurse ) {
+ $verbose and print "Not recursing into '$file' as per requested.\n";
+ return 'PRUNE';
+ }
+
if( $self->{'_dirs_visited'}{$file} ) {
$verbose and print "Directory '$file' already seen, skipping.\n";
return 'PRUNE';
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm
index fc8b7a2a12a..3671af121f0 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm
@@ -6,7 +6,7 @@ use strict;
use Carp ();
use Pod::Simple ();
use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS);
-$VERSION = '3.16';
+$VERSION = '3.20';
BEGIN {
@ISA = ('Pod::Simple');
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod
index f5363183155..792d1be5a24 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod
@@ -17,7 +17,11 @@ Pod::Simple::Subclassing -- write a formatter as a Pod::Simple subclass
}
sub _handle_element_end {
- my($parser, $element_name) = @_;
+ my($parser, $element_name, $attr_hash_r) = @_;
+ # NOTE: $attr_hash_r is only present when $element_name is "over" or "begin"
+ # The remaining code excerpts will mostly ignore this $attr_hash_r, as it is
+ # mostly useless. It is documented where "over-*" and "begin" events are
+ # documented.
...
}
@@ -214,7 +218,7 @@ There are, at first glance, three kinds of L links: URL, man, and pod.
When a LE<lt>I<some_url>E<gt> code is parsed, it produces this event
structure:
- <L content-implicit="yes" to="that_url" type="url">
+ <L content-implicit="yes" raw="that_url" to="that_url" type="url">
that_url
</L>
@@ -227,14 +231,14 @@ For example, this Pod source:
produces this event structure:
- <L content-implicit="yes" to="http://www.perl.com/CPAN/authors/" type="url">
+ <L content-implicit="yes" raw="http://www.perl.com/CPAN/authors/" to="http://www.perl.com/CPAN/authors/" type="url">
http://www.perl.com/CPAN/authors/
</L>
When a LE<lt>I<manpage(section)>E<gt> code is parsed (and these are
fairly rare and not terribly useful), it produces this event structure:
- <L content-implicit="yes" to="manpage(section)" type="man">
+ <L content-implicit="yes" raw="manpage(section)" to="manpage(section)" type="man">
manpage(section)
</L>
@@ -247,7 +251,7 @@ For example, this Pod source:
produces this event structure:
- <L content-implicit="yes" to="crontab(5)" type="man">
+ <L content-implicit="yes" raw="crontab(5)" to="crontab(5)" type="man">
crontab(5)
</L>
@@ -258,7 +262,7 @@ in a I<section> attribute. For example, this Pod source:
will produce this event structure:
- <L content-implicit="yes" section="ENVIRONMENT" to="crontab(5)" type="man">
+ <L content-implicit="yes" raw="crontab(5)/&quot;ENVIRONMENT&quot;" section="ENVIRONMENT" to="crontab(5)" type="man">
"ENVIRONMENT" in crontab(5)
</L>
@@ -278,7 +282,7 @@ For example, this Pod source:
will produce this event structure:
- <L to="crontab(5)" type="man">
+ <L raw="hell itself!|crontab(5)" to="crontab(5)" type="man">
hell itself!
</L>
@@ -290,7 +294,7 @@ specified for this type of L code.
In the most common case, the simple case of a LE<lt>podpageE<gt> code
produces this event structure:
- <L content-implicit="yes" to="Net::Ping" type="pod">
+ <L content-implicit="yes" raw="podpage" to="podpage" type="pod">
podpage
</L>
@@ -300,7 +304,7 @@ For example, this Pod source:
produces this event structure:
- <L content-implicit="yes" to="Net::Ping" type="pod">
+ <L content-implicit="yes" raw="Net::Ping" to="Net::Ping" type="pod">
Net::Ping
</L>
@@ -313,7 +317,7 @@ case discussed above. For example, this Pod source:
produces this event structure:
- <L to="perldiag" type="pod">
+ <L raw="Perl Error Messages|perldiag" to="perldiag" type="pod">
Perl Error Messages
</L>
@@ -325,7 +329,7 @@ For example, this Pod source:
produces this event structure:
- <L content-implicit="yes" section="Member Data" type="pod">
+ <L content-implicit="yes" raw="/&quot;Member Data&quot;" section="Member Data" type="pod">
"Member Data"
</L>
@@ -335,7 +339,7 @@ As another example, this Pod source:
produces this event structure:
- <L section="Member Data" type="pod">
+ <L raw="the various attributes|/&quot;Member Data&quot;" section="Member Data" type="pod">
the various attributes
</L>
@@ -347,7 +351,7 @@ For example, this Pod source:
produces this event structure:
- <L content-implicit="yes" section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
+ <L content-implicit="yes" raw="perlsyn/&quot;Basic BLOCKs and Switch Statements&quot;" section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
"Basic BLOCKs and Switch Statements" in perlsyn
</L>
@@ -357,7 +361,7 @@ As another example, this Pod source:
produces this event structure:
- <L section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
+ <L raw="SWITCH statements|perlsyn/&quot;Basic BLOCKs and Switch Statements&quot;" section="Basic BLOCKs and Switch Statements" to="perlsyn" type="pod">
SWITCH statements
</L>
@@ -368,12 +372,33 @@ Incidentally, note that we do not distinguish between these syntaxes:
L</Member Data>
L<Member Data> [deprecated syntax]
-That is, they all produce the same event structure, namely:
+That is, they all produce the same event structure (for the most part), namely:
- <L content-implicit="yes" section="Member Data" type="pod">
+ <L content-implicit="yes" raw="$depends_on_syntax" section="Member Data" type="pod">
&#34;Member Data&#34;
</L>
+The I<raw> attribute depends on what the raw content of the L<> is, so that is
+why the event structure is the same "for the most part".
+
+If you have not guessed it yet, the I<raw> attribute contains the raw,
+original, unescaped content of the L<> formatting code. In addition to the
+examples above, take notice of the following event structure produced by
+the following L<> formatting code.
+
+ L<click B<here>|page/About the C<-M> switch>
+
+ <L raw="click B<here>|page/About the C<-M> switch" section="About the -M switch" to="page" type="pod">
+ click B<here>
+ </L>
+
+Specifically, notice that the formatting codes are present and unescaped
+in I<raw>.
+
+There is a known bug in the I<raw> attribute where any surrounding whitespace
+is condensed into a single ' '. For example, given LE<60> linkE<62>, I<raw>
+will be " link".
+
=item events with an element_name of E or Z
While there are Pod codes EE<lt>...E<gt> and ZE<lt>E<gt>, these
@@ -432,7 +457,36 @@ a bulleted list, it will produce this event structure:
...Stuff...
</item-bullet>
...more item-bullets...
- </over-bullet>
+ </over-bullet fake-closer="1">
+
+The attribute I<fake-closer> is only present if it is a true value; it is not
+present if it is a false value. It is shown in the above example to illustrate
+where the attribute is (in the B<closing> tag). It signifies that the C<=over>
+did not have a matching C<=back>, and thus Pod::Simple had to create a fake
+closer.
+
+For example, this Pod source:
+
+ =over
+
+ =item *
+
+ Something
+
+ =back
+
+Would produce an event structure that does B<not> have the I<fake-closer>
+attribute, whereas this Pod source:
+
+ =over
+
+ =item *
+
+ Gasp! An unclosed =over block!
+
+would. The rest of the over-* examples will not demonstrate this attribute,
+but they all can have it. See L<Pod::Checker>'s source for an example of this
+attribute being used.
The value of the I<indent> attribute is whatever value is after the
"=over" directive, as in "=over 8". If no such value is specified
@@ -490,7 +544,7 @@ message might be issued to the user.
=item events with an element_name of over-text
-These events are are somewhat unlike the other over-*
+These events are somewhat unlike the other over-*
structures, as far as what their contents are. When
an "=over ... Z<>=back" block is parsed where the items are
a list of text "subheadings", it will produce this event structure:
@@ -504,7 +558,7 @@ a list of text "subheadings", it will produce this event structure:
...more item-text and/or stuff...
</over-text>
-The I<indent> attribute is as with the other over-* events.
+The I<indent> and I<fake-closer> attributes are as with the other over-* events.
For example, this Pod source:
@@ -545,7 +599,7 @@ produces this event structure:
=item events with an element_name of over-block
-These events are are somewhat unlike the other over-*
+These events are somewhat unlike the other over-*
structures, as far as what their contents are. When
an "=over ... Z<>=back" block is parsed where there are no items,
it will produce this event structure:
@@ -554,7 +608,7 @@ it will produce this event structure:
...stuff (generally Para or Verbatim elements)...
</over-block>
-The I<indent> attribute is as with the other over-* events.
+The I<indent> and I<fake-closer> attributes are as with the other over-* events.
For example, this Pod source:
@@ -569,7 +623,7 @@ For example, this Pod source:
circumstances of cruelty and perfidy scarcely paralleled in the most
barbarous ages, and totally unworthy the head of a civilized nation.
- =cut
+ =back
will produce this event structure:
@@ -585,6 +639,41 @@ will produce this event structure:
</Para>
</over-block>
+=item events with an element_name of over-empty
+
+B<Note: These events are only triggered if C<parse_empty_lists()> is set to a
+true value.>
+
+These events are somewhat unlike the other over-* structures, as far as what
+their contents are. When an "=over ... Z<>=back" block is parsed where there
+is no content, it will produce this event structure:
+
+ <over-empty indent="4" start_line="543">
+ </over-empty>
+
+The I<indent> and I<fake-closer> attributes are as with the other over-* events.
+
+For example, this Pod source:
+
+ =over
+
+ =over
+
+ =back
+
+ =back
+
+will produce this event structure:
+
+ <over-block indent="4" start_line="1">
+ <over-empty indent="4" start_line="3">
+ </over-empty>
+ </over-block>
+
+Note that the outer C<=over> is a block because it has no C<=item>s but still
+has content: the inner C<=over>. The inner C<=over>, in turn, is completely
+empty, and is treated as such.
+
=item events with an element_name of item-bullet
See L</"events with an element_name of over-bullet">, above.
@@ -673,7 +762,7 @@ B<TODO: document how this interacts with =extend, and long element names>
In the unlikely situation that you need to tell the parser that you will
accept additional directives ("=foo" things), you need to first set the
-parset to treat its content as data (i.e., not really processed at
+parser to treat its content as data (i.e., not really processed at
all), or as verbatim (mostly just expanding tabs), or as processed text
(parsing formatting codes like BE<lt>...E<gt>).
@@ -783,6 +872,21 @@ This is just like the code_handler attribute, except that it's for
unlikely to be interesting, but this is included for completeness.
+=item C<< $parser->pod_handler( I<CODE_REF> ) >>
+
+This is just like the code_handler attribute, except that it's for
+"=pod" lines, not code lines. The same caveats apply. "=pod" lines are
+unlikely to be interesting, but this is included for completeness.
+
+
+=item C<< $parser->whiteline_handler( I<CODE_REF> ) >>
+
+This is just like the code_handler attribute, except that it's for
+lines that are seemingly blank but have whitespace (" " and/or "\t") on them,
+not code lines. The same caveats apply. These lines are unlikely to be
+interesting, but this is included for completeness.
+
+
=item C<< $parser->whine( I<linenumber>, I<complaint string> ) >>
This notes a problem in the Pod, which will be reported to in the "Pod
@@ -847,8 +951,13 @@ conventions as two spaces after periods will be preserved by the parser.
This is primarily useful for output formats that treat whitespace as
significant (such as text or *roff, but not HTML).
-=back
+=item C<< $parser->parse_empty_lists( I<SOMEVALUE> ) >>
+
+If this attribute is set to true, the parser will not ignore empty
+C<=over>/C<=back> blocks. The type of C<=over> will be I<empty>, documented
+above, L<events with an element_name of over-empty>.
+=back
=head1 SEE ALSO
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm
index 55dae9a6dbe..3032d0fcd57 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.16';
+$VERSION = '3.20';
@ISA = ('Pod::Simple::Methody');
BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG)
? \&Pod::Simple::DEBUG
@@ -71,7 +71,7 @@ sub end_L {
if (my $link = delete $_[0]{'Link'}) {
# Append the URL to the output unless it's already present.
$_[0]{'Thispara'} .= " <$link->{to}>"
- unless $_[0]{'Thispara'} =~ /\b\E$link->{to}/;
+ unless $_[0]{'Thispara'} =~ /\b\Q$link->{to}/;
}
}
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm
index 36a4988cf12..dea1cde7ccf 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.16';
+$VERSION = '3.20';
@ISA = ('Pod::Simple');
sub new {
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TiedOutFH.pm
index e6e5a4a058f..9f2a224a278 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.16';
+$VERSION = '3.20';
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm
index dec3b967b39..892436db7f0 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm
@@ -2,7 +2,7 @@
require 5;
package Pod::Simple::Transcode;
use vars qw($VERSION );
-$VERSION = '3.16';
+$VERSION = '3.20';
BEGIN {
if(defined &DEBUG) {;} # Okay
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeDumb.pm
index 647447503ed..33030903430 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.16';
+$VERSION = '3.20';
# This module basically pretends it knows how to transcode, except
# only for null-transcodings! We use this when Encode isn't
# available.
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TranscodeSmart.pm
index 5c10f02ced2..a66dedd03bc 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.16';
+$VERSION = '3.20';
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 ef05ddb6ea5..9d31db0badd 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Simple/XHTML.pm
@@ -45,7 +45,7 @@ declare the output character set as UTF-8 before parsing, like so:
package Pod::Simple::XHTML;
use strict;
use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES );
-$VERSION = '3.16';
+$VERSION = '3.20';
use Pod::Simple::Methody ();
@ISA = ('Pod::Simple::Methody');
@@ -194,6 +194,16 @@ to the empty string.
Whether to add a table-of-contents at the top of each page (called an
index for the sake of tradition).
+=head2 anchor_items
+
+Whether to anchor every definition C<=item> directive. This needs to be
+enabled if you want to be able to link to specific C<=item> directives, which
+are output as C<< <dt> >> elements. Disabled by default.
+
+=head2 backlink
+
+Whether to turn every =head1 directive into a link pointing to the top
+of the page (specifically, the opening body tag).
=cut
@@ -215,6 +225,8 @@ __PACKAGE__->_accessorize(
'html_header',
'html_footer',
'index',
+ 'anchor_items',
+ 'backlink',
'batch_mode', # whether we're in batch mode
'batch_mode_current_level',
# When in batch mode, how deep the current module is: 1 for "LWP",
@@ -244,7 +256,7 @@ sub new {
$new->{'to_index'} = [];
$new->{'output'} = [];
$new->{'saved'} = [];
- $new->{'ids'} = {};
+ $new->{'ids'} = { '_podtop_' => 1 }; # used in <body>
$new->{'in_li'} = [];
$new->{'__region_targets'} = [];
@@ -273,7 +285,7 @@ want to override this if you are adding a custom element type that does
more than just display formatted text. Perhaps adding a way to generate
HTML tables from an extended version of POD.
-So, let's say you want add a custom element called 'foo'. In your
+So, let's say you want to add a custom element called 'foo'. In your
subclass's C<new> method, after calling C<SUPER::new> you'd call:
$new->accept_targets_as_text( 'foo' );
@@ -342,11 +354,7 @@ sub start_item_bullet {
}
sub start_item_text {
- if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
- $_[0]{'scratch'} = "</dd>\n";
- $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
- }
- $_[0]{'scratch'} .= '<dt>';
+ # see end_item_text
}
sub start_over_bullet { $_[0]{'scratch'} = '<ul>'; push @{$_[0]{'in_li'}}, 0; $_[0]->emit }
@@ -402,7 +410,10 @@ sub _end_head {
my $id = $_[0]->idify($_[0]{scratch});
my $text = $_[0]{scratch};
- $_[0]{'scratch'} = qq{<h$h id="$id">$text</h$h>};
+ $_[0]{'scratch'} = $_[0]->backlink && ($h - $add == 0)
+ # backlinks enabled && =head1
+ ? qq{<a href="#_podtop_"><h$h id="$id">$text</h$h></a>}
+ : qq{<h$h id="$id">$text</h$h>};
$_[0]->emit;
push @{ $_[0]{'to_index'} }, [$h, $id, $text];
}
@@ -416,7 +427,21 @@ sub end_item_bullet { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
sub end_item_number { $_[0]{'scratch'} .= '</p>'; $_[0]->emit }
sub end_item_text {
- $_[0]{'scratch'} .= "</dt>\n<dd>";
+ # idify and anchor =item content if wanted
+ my $dt_id = $_[0]{'anchor_items'}
+ ? ' id="'. $_[0]->idify($_[0]{'scratch'}) .'"'
+ : '';
+
+ # reset scratch
+ my $text = $_[0]{scratch};
+ $_[0]{'scratch'} = '';
+
+ if ($_[0]{'in_dd'}[ $_[0]{'dl_level'} ]) {
+ $_[0]{'scratch'} = "</dd>\n";
+ $_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 0;
+ }
+
+ $_[0]{'scratch'} .= qq{<dt$dt_id>$text</dt>\n<dd>};
$_[0]{'in_dd'}[ $_[0]{'dl_level'} ] = 1;
$_[0]->emit;
}
@@ -451,18 +476,23 @@ sub start_Document {
$self->{'scratch'} .= $self->html_header;
$self->emit unless $self->html_header eq "";
} else {
- my ($doctype, $title, $metatags);
+ my ($doctype, $title, $metatags, $bodyid);
$doctype = $self->html_doctype || '';
$title = $self->force_title || $self->title || $self->default_title || '';
$metatags = $self->html_header_tags || '';
- if ($self->html_css) {
- $metatags .= "\n<link rel='stylesheet' href='" .
- $self->html_css . "' type='text/css' />";
+ if (my $css = $self->html_css) {
+ $metatags .= $css;
+ if ($css !~ /<link/) {
+ # this is required to be compatible with Pod::Simple::BatchHTML
+ $metatags .= '<link rel="stylesheet" href="'
+ . $self->encode_entities($css) . '" type="text/css" />';
+ }
}
if ($self->html_javascript) {
- $metatags .= "\n<script type='text/javascript' src='" .
+ $metatags .= qq{\n<script type="text/javascript" src="} .
$self->html_javascript . "'></script>";
}
+ $bodyid = $self->backlink ? ' id="_podtop_"' : '';
$self->{'scratch'} .= <<"HTML";
$doctype
<html>
@@ -470,7 +500,7 @@ $doctype
<title>$title</title>
$metatags
</head>
-<body>
+<body$bodyid>
HTML
$self->emit;
}
@@ -599,7 +629,7 @@ sub resolve_pod_page_link {
my ($self, $to, $section) = @_;
return undef unless defined $to || defined $section;
if (defined $section) {
- $section = '#' . $self->idify($section, 1);
+ $section = '#' . $self->idify($self->encode_entities($section), 1);
return $section unless defined $to;
} else {
$section = ''
@@ -708,6 +738,10 @@ sub batch_mode_page_object_init {
return $self;
}
+sub html_header_after_title {
+}
+
+
1;
__END__
diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm
index 69b992d01ec..bbb815a5527 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.16';
+$VERSION = '3.20';
BEGIN {
@ISA = ('Pod::Simple');
*DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG;
diff --git a/Master/tlpkg/tlperl/lib/Pod/Usage.pm b/Master/tlpkg/tlperl/lib/Pod/Usage.pm
index f463fb9c468..d060b275d1a 100644
--- a/Master/tlpkg/tlperl/lib/Pod/Usage.pm
+++ b/Master/tlpkg/tlperl/lib/Pod/Usage.pm
@@ -11,7 +11,7 @@ package Pod::Usage;
use strict;
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '1.36'; ## Current version of this package
+$VERSION = '1.51'; ## Current version of this package
require 5.005; ## requires this Perl version or later
=head1 NAME
@@ -149,6 +149,14 @@ output the POD.
=back
+=head2 Pass-through options
+
+The following options are passed through to the underlying text formatter
+(L<Pod::Text> or L<Pod::PlainText> for Perl versions E<lt> 5.005_58). See
+the manual pages of these modules for more information.
+
+ alt code indent loose margin quotes sentence stderr utf8 width
+
=head1 DESCRIPTION
B<pod2usage> will print a usage message for the invoking script (using
@@ -434,6 +442,8 @@ with re-writing this manpage.
=head1 SEE ALSO
+B<Pod::Usage> is part of the L<Pod::Parser> distribution.
+
L<Pod::Parser>, L<Getopt::Long>, L<Pod::Find>
=cut
@@ -564,7 +574,8 @@ sub pod2usage {
and $opts{'-output'} == \*STDOUT )
{
## spit out the entire PODs. Might as well invoke perldoc
- my $progpath = File::Spec->catfile($Config{scriptdir}, 'perldoc');
+ my $progpath = File::Spec->catfile($Config{scriptdirexp}
+ || $Config{scriptdir}, 'perldoc');
print { $opts{'-output'} } ($opts{'-message'}, "\n") if($opts{'-message'});
if(defined $opts{-input} && $opts{-input} =~ /^\s*(\S.*?)\s*$/) {
# the perldocs back to 5.005 should all have -F
@@ -600,7 +611,13 @@ sub new {
if ($self->can('initialize')) {
$self->initialize();
} else {
- $self = $self->SUPER::new();
+ # pass through options to Pod::Text
+ my %opts;
+ for (qw(alt code indent loose margin quotes sentence stderr utf8 width)) {
+ my $val = $params{USAGE_OPTIONS}{"-$_"};
+ $opts{$_} = $val if defined $val;
+ }
+ $self = $self->SUPER::new(%opts);
%$self = (%$self, %params);
}
return $self;