diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2021-03-03 11:04:20 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2021-03-03 11:04:20 +0000 |
commit | 13c3572d26e0868b9665513e4646ade860ae7810 (patch) | |
tree | 72f68d7c1270cc0a1d504f8eeb45d4de6b36f2d1 /Master/tlpkg/tlperl/lib/Pod | |
parent | 87d16a01498a53c4bb455d78ae7131370e47591e (diff) |
Updated tlperl
git-svn-id: svn://tug.org/texlive/trunk@58075 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Pod')
43 files changed, 1204 insertions, 6157 deletions
diff --git a/Master/tlpkg/tlperl/lib/Pod/Find.pm b/Master/tlpkg/tlperl/lib/Pod/Find.pm deleted file mode 100644 index f258f26df68..00000000000 --- a/Master/tlpkg/tlperl/lib/Pod/Find.pm +++ /dev/null @@ -1,553 +0,0 @@ -############################################################################# -# Pod/Find.pm -- finds files containing POD documentation -# -# Author: Marek Rouchal <marekr@cpan.org> -# -# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code -# from Nick Ing-Simmon's PodToHtml). All rights reserved. -# This file is part of "PodParser". Pod::Find is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Find; -use strict; - -use vars qw($VERSION); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later -use Carp; - -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} - -############################################################################# - -=head1 NAME - -Pod::Find - find POD documents in directory trees - -=head1 SYNOPSIS - - use Pod::Find qw(pod_find simplify_name); - my %pods = pod_find({ -verbose => 1, -inc => 1 }); - foreach(keys %pods) { - print "found library POD `$pods{$_}' in $_\n"; - } - - print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n"; - - $location = pod_where( { -inc => 1 }, "Pod::Find" ); - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -B<Pod::Find> provides a set of functions to locate POD files. Note that -no function is exported by default to avoid pollution of your namespace, -so be sure to specify them in the B<use> statement if you need them: - - use Pod::Find qw(pod_find); - -From this version on the typical SCM (software configuration management) -directories are ignored. These are: RCS, CVS, SCCS, .svn, .hg, .git, .sync - -=cut - -#use diagnostics; -use Exporter; -use File::Spec; -use File::Find; -use Cwd qw(abs_path cwd); - -use vars qw(@ISA @EXPORT_OK $VERSION); -@ISA = qw(Exporter); -@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod); - -# package global variables -my $SIMPLIFY_RX; - -=head2 C<pod_find( { %opts } , @directories )> - -The function B<pod_find> searches for POD documents in a given set of -files and/or directories. It returns a hash with the file names as keys -and the POD name as value. The POD name is derived from the file name -and its position in the directory tree. - -E.g. when searching in F<$HOME/perl5lib>, the file -F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>, -whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be -I<Myclass::Subclass>. The name information can be used for POD -translators. - -Only text files containing at least one valid POD command are found. - -A warning is printed if more than one POD file with the same POD name -is found, e.g. F<CPAN.pm> in different directories. This usually -indicates duplicate occurrences of modules in the I<@INC> search path. - -B<OPTIONS> The first argument for B<pod_find> may be a hash reference -with options. The rest are either directories that are searched -recursively or files. The POD names of files are the plain basenames -with any Perl-like extension (.pm, .pl, .pod) stripped. - -=over 4 - -=item C<-verbose =E<gt> 1> - -Print progress information while scanning. - -=item C<-perl =E<gt> 1> - -Apply Perl-specific heuristics to find the correct PODs. This includes -stripping Perl-like extensions, omitting subdirectories that are numeric -but do I<not> match the current Perl interpreter's version id, suppressing -F<site_perl> as a module hierarchy name etc. - -=item C<-script =E<gt> 1> - -Search for PODs in the current Perl interpreter's installation -B<scriptdir>. This is taken from the local L<Config|Config> module. - -=item C<-inc =E<gt> 1> - -Search for PODs in the current Perl interpreter's I<@INC> paths. This -automatically considers paths specified in the C<PERL5LIB> environment -as this is included in I<@INC> by the Perl interpreter itself. - -=back - -=cut - -# return a hash of the POD files found -# first argument may be a hashref (options), -# rest is a list of directories to search recursively -sub pod_find -{ - my %opts; - if(ref $_[0]) { - %opts = %{shift()}; - } - - $opts{-verbose} ||= 0; - $opts{-perl} ||= 0; - - my (@search) = @_; - - if($opts{-script}) { - require Config; - push(@search, $Config::Config{scriptdir}) - if -d $Config::Config{scriptdir}; - $opts{-perl} = 1; - } - - if($opts{-inc}) { - if ($^O eq 'MacOS') { - # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS - my @new_INC = @INC; - for (@new_INC) { - if ( $_ eq '.' ) { - $_ = ':'; - } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { - $_ = ':'. $_; - } else { - $_ =~ s{^\./}{:}; - } - } - push(@search, grep($_ ne File::Spec->curdir, @new_INC)); - } else { - 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; - } - - if($opts{-perl}) { - require Config; - # this code simplifies the POD name for Perl modules: - # * remove "site_perl" - # * remove e.g. "i586-linux" (from 'archname') - # * remove e.g. 5.00503 - # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) - - # Mac OS: - # * remove ":?site_perl:" - # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod) - - if ($^O eq 'MacOS') { - $SIMPLIFY_RX = - qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!; - } else { - $SIMPLIFY_RX = - qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!; - } - } - - my %dirs_visited; - my %pods; - my %names; - my $pwd = cwd(); - - foreach my $try (@search) { - unless(File::Spec->file_name_is_absolute($try)) { - # make path absolute - $try = File::Spec->catfile($pwd,$try); - } - # simplify path - # on VMS canonpath will vmsify:[the.path], but File::Find::find - # wants /unixy/paths - 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})) { - _check_for_duplicates($try, $name, \%names, \%pods); - } - 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) { - if($item =~ m{/(?:RCS|CVS|SCCS|\.svn|\.hg|\.git|\.sync)$}) { - $File::Find::prune = 1; - return; - } - elsif($dirs_visited{$item}) { - warn "Directory '$item' already seen, skipping.\n" - if($opts{-verbose}); - $File::Find::prune = 1; - return; - } - else { - $dirs_visited{$item} = 1; - } - if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) { - $File::Find::prune = 1; - warn "Perl $] version mismatch on $_, skipping.\n" - if($opts{-verbose}); - } - return; - } - if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { - _check_for_duplicates($item, $name, \%names, \%pods); - } - }, $try); # end of File::Find::find - } - chdir $pwd; - return %pods; -} - -sub _check_for_duplicates { - my ($file, $name, $names_ref, $pods_ref) = @_; - if($$names_ref{$name}) { - warn "Duplicate POD found (shadowing?): $name ($file)\n"; - warn ' Already seen in ', - join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; - } - else { - $$names_ref{$name} = 1; - } - return $$pods_ref{$file} = $name; -} - -sub _check_and_extract_name { - my ($file, $verbose, $root_rx) = @_; - - # check extension or executable flag - # this involves testing the .bat extension on Win32! - unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) { - return; - } - - return unless contains_pod($file,$verbose); - - # strip non-significant path components - # TODO what happens on e.g. Win32? - my $name = $file; - if(defined $root_rx) { - $name =~ s/$root_rx//is; - $name =~ s/$SIMPLIFY_RX//is if(defined $SIMPLIFY_RX); - } - else { - if ($^O eq 'MacOS') { - $name =~ s/^.*://s; - } else { - $name =~ s{^.*/}{}s; - } - } - _simplify($name); - $name =~ s{/+}{::}g; - if ($^O eq 'MacOS') { - $name =~ s{:+}{::}g; # : -> :: - } else { - $name =~ s{/+}{::}g; # / -> :: - } - return $name; -} - -=head2 C<simplify_name( $str )> - -The function B<simplify_name> is equivalent to B<basename>, but also -strips Perl-like extensions (.pm, .pl, .pod) and extensions like -F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively. - -=cut - -# basic simplification of the POD name: -# basename & strip extension -sub simplify_name { - my ($str) = @_; - # remove all path components - if ($^O eq 'MacOS') { - $str =~ s/^.*://s; - } else { - $str =~ s{^.*/}{}s; - } - _simplify($str); - return $str; -} - -# internal sub only -sub _simplify { - # strip Perl's own extensions - $_[0] =~ s/\.(pod|pm|plx?)\z//i; - # strip meaningless extensions on Win32 and OS/2 - $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i); - # strip meaningless extensions on VMS - $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS'); -} - -# contribution from Tim Jenness <t.jenness@jach.hawaii.edu> - -=head2 C<pod_where( { %opts }, $pod )> - -Returns the location of a pod document given a search directory -and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name. - -Options: - -=over 4 - -=item C<-inc =E<gt> 1> - -Search @INC for the pod and also the C<scriptdir> defined in the -L<Config|Config> module. - -=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]> - -Reference to an array of search directories. These are searched in order -before looking in C<@INC> (if B<-inc>). Current directory is used if -none are specified. - -=item C<-verbose =E<gt> 1> - -List directories as they are searched - -=back - -Returns the full path of the first occurrence to the file. -Package names (eg 'A::B') are automatically converted to directory -names in the selected directory. (eg on unix 'A::B' is converted to -'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the -search automatically if required. - -A subdirectory F<pod/> is also checked if it exists in any of the given -search directories. This ensures that e.g. L<perlfunc|perlfunc> is -found. - -It is assumed that if a module name is supplied, that that name -matches the file name. Pods are not opened to check for the 'NAME' -entry. - -A check is made to make sure that the file that is found does -contain some pod documentation. - -=cut - -sub pod_where { - - # default options - my %options = ( - '-inc' => 0, - '-verbose' => 0, - '-dirs' => [ File::Spec->curdir ], - ); - - # Check for an options hash as first argument - if (defined $_[0] && ref($_[0]) eq 'HASH') { - my $opt = shift; - - # Merge default options with supplied options - %options = (%options, %$opt); - } - - # Check usage - carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_)); - - # Read argument - my $pod = shift; - - # Split on :: and then join the name together using File::Spec - my @parts = split (/::/, $pod); - - # Get full directory list - my @search_dirs = @{ $options{'-dirs'} }; - - if ($options{'-inc'}) { - - require Config; - - # Add @INC - if ($^O eq 'MacOS' && $options{'-inc'}) { - # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS - my @new_INC = @INC; - for (@new_INC) { - if ( $_ eq '.' ) { - $_ = ':'; - } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { - $_ = ':'. $_; - } else { - $_ =~ s{^\./}{:}; - } - } - push (@search_dirs, @new_INC); - } elsif ($options{'-inc'}) { - push (@search_dirs, @INC); - } - - # Add location of pod documentation for perl man pages (eg perlfunc) - # This is a pod directory in the private install tree - #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'}, - # 'pod'); - #push (@search_dirs, $perlpoddir) - # if -d $perlpoddir; - - # Add location of binaries such as pod2text - push (@search_dirs, $Config::Config{'scriptdir'}) - if -d $Config::Config{'scriptdir'}; - } - - warn 'Search path is: '.join(' ', @search_dirs)."\n" - if $options{'-verbose'}; - - # Loop over directories - Dir: foreach my $dir ( @search_dirs ) { - - # Don't bother if can't find the directory - if (-d $dir) { - warn "Looking in directory $dir\n" - if $options{'-verbose'}; - - # 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'}; - - # Loop over possible extensions - foreach my $ext ('', '.pod', '.pm', '.pl') { - my $fullext = $fullname . $ext; - if (-f $fullext && - contains_pod($fullext, $options{'-verbose'}) ) { - warn "FOUND: $fullext\n" if $options{'-verbose'}; - return $fullext; - } - } - } else { - warn "Directory $dir does not exist\n" - if $options{'-verbose'}; - next Dir; - } - # for some strange reason the path on MacOS/darwin/cygwin is - # 'pods' not 'pod' - # this could be the case also for other systems that - # have a case-tolerant file system, but File::Spec - # does not recognize 'darwin' yet. And cygwin also has "pods", - # but is not case tolerant. Oh well... - if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i) - && -d File::Spec->catdir($dir,'pods')) { - $dir = File::Spec->catdir($dir,'pods'); - redo Dir; - } - if(-d File::Spec->catdir($dir,'pod')) { - $dir = File::Spec->catdir($dir,'pod'); - redo Dir; - } - } - # No match; - return; -} - -=head2 C<contains_pod( $file , $verbose )> - -Returns true if the supplied filename (not POD module) contains some pod -information. - -=cut - -sub contains_pod { - my $file = shift; - my $verbose = 0; - $verbose = shift if @_; - - # check for one line of POD - my $podfh; - if ($] < 5.006) { - $podfh = gensym(); - } - - unless(open($podfh,"<$file")) { - warn "Error: $file is unreadable: $!\n"; - return; - } - - local $/ = undef; - my $pod = <$podfh>; - close($podfh) || die "Error closing $file: $!\n"; - unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) { - warn "No POD in $file, skipping.\n" - if($verbose); - return 0; - } - - return 1; -} - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Marek Rouchal E<lt>marekr@cpan.orgE<gt>, -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> - -=cut - -1; - diff --git a/Master/tlpkg/tlperl/lib/Pod/Html.pm b/Master/tlpkg/tlperl/lib/Pod/Html.pm index 64cf376f3c9..71555e723ca 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Html.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Html.pm @@ -2,7 +2,7 @@ package Pod::Html; use strict; require Exporter; -our $VERSION = 1.24; +our $VERSION = 1.25; our @ISA = qw(Exporter); our @EXPORT = qw(pod2html htmlify); our @EXPORT_OK = qw(anchorify relativize_url); @@ -766,22 +766,29 @@ sub resolve_pod_page_link { push @matches, $modname if $modname =~ /::\Q$to\E\z/; } + # make it look like a path instead of a namespace + my $modloc = File::Spec->catfile(split(/::/, $to)); + if ($#matches == -1) { - warn "Cannot find \"$to\" in podpath: " . - "cannot find suitable replacement path, cannot resolve link\n" - unless $self->quiet; + warn "Cannot find file \"$modloc.*\" directly under podpath, " . + "cannot find suitable replacement: link remains unresolved.\n" + if $self->verbose; 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]}; + my $matchloc = File::Spec->catfile(split(/::/, $path)); + warn "Cannot find file \"$modloc.*\" directly under podpath, but ". + "I did find \"$matchloc.*\", so I'll assume that is what you ". + "meant to link to.\n" + if $self->verbose; } else { - 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 + # XXX currently, @matches isn't sorted so this is not true $path = $self->pages->{$matches[-1]}; + my $matchloc = File::Spec->catfile(split(/::/, $path)); + warn "Cannot find file \"$modloc.*\" directly under podpath, but ". + "I did find \"$matchloc.*\" (among others), so I'll use that " . + "to resolve the link.\n" if $self->verbose; } } else { $path = $self->pages->{$to}; diff --git a/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm b/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm deleted file mode 100644 index c4d6fc24691..00000000000 --- a/Master/tlpkg/tlperl/lib/Pod/InputObjects.pm +++ /dev/null @@ -1,946 +0,0 @@ -############################################################################# -# Pod/InputObjects.pm -- package which defines objects for input streams -# and paragraphs and commands when parsing POD docs. -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::InputObjects; -use strict; - -use vars qw($VERSION); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::InputObjects - objects representing POD input paragraphs, commands, etc. - -=head1 SYNOPSIS - - use Pod::InputObjects; - -=head1 REQUIRES - -perl5.004, Carp - -=head1 EXPORTS - -Nothing. - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -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: - -=begin __PRIVATE__ - -=over 4 - -=item package B<Pod::InputSource> - -An object corresponding to a source of POD input text. It is mostly a -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 -plain paragraph, a verbatim paragraph, or a command paragraph (see -L<perlpod>). - -=item package B<Pod::InteriorSequence> - -An object corresponding to an interior sequence command from the POD -input text (see L<perlpod>). - -=item package B<Pod::ParseTree> - -An object corresponding to a tree of parsed POD text. Each "node" in -a parse-tree (or I<ptree>) is either a text-string or a reference to -a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree -in the order in which they were parsed from left-to-right. - -=back - -Each of these input objects are described in further detail in the -sections which follow. - -=cut - -############################################################################# - -package Pod::InputSource; - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B<Pod::InputSource> - -This object corresponds to an input source or stream of POD -documentation. When parsing PODs, it is necessary to associate and store -certain context information with each input source. All of this -information is kept together with the stream itself in one of these -C<Pod::InputSource> objects. Each such object is merely a wrapper around -an C<IO::Handle> object of some kind (or at least something that -implements the C<getline()> method). They have the following -methods/attributes: - -=end __PRIVATE__ - -=cut - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B<new()> - - my $pod_input1 = Pod::InputSource->new(-handle => $filehandle); - my $pod_input2 = new Pod::InputSource(-handle => $filehandle, - -name => $name); - my $pod_input3 = new Pod::InputSource(-handle => \*STDIN); - my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN, - -name => "(STDIN)"); - -This is a class method that constructs a C<Pod::InputSource> object and -returns a reference to the new input source object. It takes one or more -keyword arguments in the form of a hash. The keyword C<-handle> is -required and designates the corresponding input handle. The keyword -C<-name> is optional and specifies the name associated with the input -handle (typically a file name). - -=end __PRIVATE__ - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { -name => '(unknown)', - -handle => undef, - -was_cutting => 0, - @_ }; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B<name()> - - my $filename = $pod_input->name(); - $pod_input->name($new_filename_to_use); - -This method gets/sets the name of the input source (usually a filename). -If no argument is given, it returns a string containing the name of -the input source; otherwise it sets the name of the input source to the -contents of the given argument. - -=end __PRIVATE__ - -=cut - -sub name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## allow 'filename' as an alias for 'name' -*filename = \&name; - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B<handle()> - - my $handle = $pod_input->handle(); - -Returns a reference to the handle object from which input is read (the -one used to contructed this input source object). - -=end __PRIVATE__ - -=cut - -sub handle { - return $_[0]->{'-handle'}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B<was_cutting()> - - print "Yes.\n" if ($pod_input->was_cutting()); - -The value of the C<cutting> state (that the B<cutting()> method would -have returned) immediately before any input was read from this input -stream. After all input from this stream has been read, the C<cutting> -state is restored to this value. - -=end __PRIVATE__ - -=cut - -sub was_cutting { - (@_ > 1) and $_[0]->{-was_cutting} = $_[1]; - return $_[0]->{-was_cutting}; -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::Paragraph; - -##--------------------------------------------------------------------------- - -=head1 B<Pod::Paragraph> - -An object representing a paragraph of POD input text. -It has the following methods/attributes: - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::Paragraph-E<gt>B<new()> - - my $pod_para1 = Pod::Paragraph->new(-text => $text); - my $pod_para2 = Pod::Paragraph->new(-name => $cmd, - -text => $text); - my $pod_para3 = new Pod::Paragraph(-text => $text); - my $pod_para4 = new Pod::Paragraph(-name => $cmd, - -text => $text); - my $pod_para5 = Pod::Paragraph->new(-name => $cmd, - -text => $text, - -file => $filename, - -line => $line_number); - -This is a class method that constructs a C<Pod::Paragraph> object and -returns a reference to the new paragraph object. It may be given one or -two keyword arguments. The C<-text> keyword indicates the corresponding -text of the POD paragraph. The C<-name> keyword indicates the name of -the corresponding POD command, such as C<head1> or C<item> (it should -I<not> contain the C<=> prefix); this is needed only if the POD -paragraph corresponds to a command paragraph. The C<-file> and C<-line> -keywords indicate the filename and line number corresponding to the -beginning of the paragraph - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { - -name => undef, - -text => (@_ == 1) ? shift : undef, - -file => '<unknown-file>', - -line => 0, - -prefix => '=', - -separator => ' ', - -ptree => [], - @_ - }; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<cmd_name()> - - my $para_cmd = $pod_para->cmd_name(); - -If this paragraph is a command paragraph, then this method will return -the name of the command (I<without> any leading C<=> prefix). - -=cut - -sub cmd_name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## let name() be an alias for cmd_name() -*name = \&cmd_name; - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<text()> - - my $para_text = $pod_para->text(); - -This method will return the corresponding text of the paragraph. - -=cut - -sub text { - (@_ > 1) and $_[0]->{'-text'} = $_[1]; - return $_[0]->{'-text'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<raw_text()> - - my $raw_pod_para = $pod_para->raw_text(); - -This method will return the I<raw> text of the POD paragraph, exactly -as it appeared in the input. - -=cut - -sub raw_text { - return $_[0]->{'-text'} unless (defined $_[0]->{'-name'}); - return $_[0]->{'-prefix'} . $_[0]->{'-name'} . - $_[0]->{'-separator'} . $_[0]->{'-text'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<cmd_prefix()> - - my $prefix = $pod_para->cmd_prefix(); - -If this paragraph is a command paragraph, then this method will return -the prefix used to denote the command (which should be the string "=" -or "=="). - -=cut - -sub cmd_prefix { - return $_[0]->{'-prefix'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<cmd_separator()> - - my $separator = $pod_para->cmd_separator(); - -If this paragraph is a command paragraph, then this method will return -the text used to separate the command name from the rest of the -paragraph (if any). - -=cut - -sub cmd_separator { - return $_[0]->{'-separator'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<parse_tree()> - - my $ptree = $pod_parser->parse_text( $pod_para->text() ); - $pod_para->parse_tree( $ptree ); - $ptree = $pod_para->parse_tree(); - -This method will get/set the corresponding parse-tree of the paragraph's text. - -=cut - -sub parse_tree { - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; -} - -## let ptree() be an alias for parse_tree() -*ptree = \&parse_tree; - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<file_line()> - - my ($filename, $line_number) = $pod_para->file_line(); - my $position = $pod_para->file_line(); - -Returns the current filename and line number for the paragraph -object. If called in a list context, it returns a list of two -elements: first the filename, then the line number. If called in -a scalar context, it returns a string containing the filename, followed -by a colon (':'), followed by the line number. - -=cut - -sub file_line { - my @loc = ($_[0]->{'-file'} || '<unknown-file>', - $_[0]->{'-line'} || 0); - return (wantarray) ? @loc : join(':', @loc); -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::InteriorSequence; - -##--------------------------------------------------------------------------- - -=head1 B<Pod::InteriorSequence> - -An object representing a POD interior sequence command. -It has the following methods/attributes: - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::InteriorSequence-E<gt>B<new()> - - my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd - -ldelim => $delimiter); - my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd, - -ldelim => $delimiter); - my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd, - -ldelim => $delimiter, - -file => $filename, - -line => $line_number); - - my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree); - my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree); - -This is a class method that constructs a C<Pod::InteriorSequence> object -and returns a reference to the new interior sequence object. It should -be given two keyword arguments. The C<-ldelim> keyword indicates the -corresponding left-delimiter of the interior sequence (e.g. 'E<lt>'). -The C<-name> keyword indicates the name of the corresponding interior -sequence command, such as C<I> or C<B> or C<C>. The C<-file> and -C<-line> keywords indicate the filename and line number corresponding -to the beginning of the interior sequence. If the C<$ptree> argument is -given, it must be the last argument, and it must be either string, or -else an array-ref suitable for passing to B<Pod::ParseTree::new> (or -it may be a reference to a Pod::ParseTree object). - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## See if first argument has no keyword - if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) { - ## Yup - need an implicit '-name' before first parameter - unshift @_, '-name'; - } - - ## See if odd number of args - if ((@_ % 2) != 0) { - ## Yup - need an implicit '-ptree' before the last parameter - splice @_, $#_, 0, '-ptree'; - } - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { - -name => (@_ == 1) ? $_[0] : undef, - -file => '<unknown-file>', - -line => 0, - -ldelim => '<', - -rdelim => '>', - @_ - }; - - ## Initialize contents if they haven't been already - my $ptree = $self->{'-ptree'} || new Pod::ParseTree(); - if ( ref $ptree =~ /^(ARRAY)?$/ ) { - ## We have an array-ref, or a normal scalar. Pass it as an - ## an argument to the ptree-constructor - $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree); - } - $self->{'-ptree'} = $ptree; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<cmd_name()> - - my $seq_cmd = $pod_seq->cmd_name(); - -The name of the interior sequence command. - -=cut - -sub cmd_name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## let name() be an alias for cmd_name() -*name = \&cmd_name; - -##--------------------------------------------------------------------------- - -## Private subroutine to set the parent pointer of all the given -## children that are interior-sequences to be $self - -sub _set_child2parent_links { - my ($self, @children) = @_; - ## Make sure any sequences know who their parent is - for (@children) { - next unless (length and ref and ref ne 'SCALAR'); - if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or - UNIVERSAL::can($_, 'nested')) - { - $_->nested($self); - } - } -} - -## Private subroutine to unset child->parent links - -sub _unset_child2parent_links { - my $self = shift; - $self->{'-parent_sequence'} = undef; - my $ptree = $self->{'-ptree'}; - for (@$ptree) { - next unless (length and ref and ref ne 'SCALAR'); - $_->_unset_child2parent_links() - if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); - } -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<prepend()> - - $pod_seq->prepend($text); - $pod_seq1->prepend($pod_seq2); - -Prepends the given string or parse-tree or sequence object to the parse-tree -of this interior sequence. - -=cut - -sub prepend { - my $self = shift; - $self->{'-ptree'}->prepend(@_); - _set_child2parent_links($self, @_); - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<append()> - - $pod_seq->append($text); - $pod_seq1->append($pod_seq2); - -Appends the given string or parse-tree or sequence object to the parse-tree -of this interior sequence. - -=cut - -sub append { - my $self = shift; - $self->{'-ptree'}->append(@_); - _set_child2parent_links($self, @_); - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<nested()> - - $outer_seq = $pod_seq->nested || print "not nested"; - -If this interior sequence is nested inside of another interior -sequence, then the outer/parent sequence that contains it is -returned. Otherwise C<undef> is returned. - -=cut - -sub nested { - my $self = shift; - (@_ == 1) and $self->{'-parent_sequence'} = shift; - return $self->{'-parent_sequence'} || undef; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<raw_text()> - - my $seq_raw_text = $pod_seq->raw_text(); - -This method will return the I<raw> text of the POD interior sequence, -exactly as it appeared in the input. - -=cut - -sub raw_text { - my $self = shift; - my $text = $self->{'-name'} . $self->{'-ldelim'}; - for ( $self->{'-ptree'}->children ) { - $text .= (ref $_) ? $_->raw_text : $_; - } - $text .= $self->{'-rdelim'}; - return $text; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<left_delimiter()> - - my $ldelim = $pod_seq->left_delimiter(); - -The leftmost delimiter beginning the argument text to the interior -sequence (should be "<"). - -=cut - -sub left_delimiter { - (@_ > 1) and $_[0]->{'-ldelim'} = $_[1]; - return $_[0]->{'-ldelim'}; -} - -## let ldelim() be an alias for left_delimiter() -*ldelim = \&left_delimiter; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<right_delimiter()> - -The rightmost delimiter beginning the argument text to the interior -sequence (should be ">"). - -=cut - -sub right_delimiter { - (@_ > 1) and $_[0]->{'-rdelim'} = $_[1]; - return $_[0]->{'-rdelim'}; -} - -## let rdelim() be an alias for right_delimiter() -*rdelim = \&right_delimiter; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<parse_tree()> - - my $ptree = $pod_parser->parse_text($paragraph_text); - $pod_seq->parse_tree( $ptree ); - $ptree = $pod_seq->parse_tree(); - -This method will get/set the corresponding parse-tree of the interior -sequence's text. - -=cut - -sub parse_tree { - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; -} - -## let ptree() be an alias for parse_tree() -*ptree = \&parse_tree; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<file_line()> - - my ($filename, $line_number) = $pod_seq->file_line(); - my $position = $pod_seq->file_line(); - -Returns the current filename and line number for the interior sequence -object. If called in a list context, it returns a list of two -elements: first the filename, then the line number. If called in -a scalar context, it returns a string containing the filename, followed -by a colon (':'), followed by the line number. - -=cut - -sub file_line { - my @loc = ($_[0]->{'-file'} || '<unknown-file>', - $_[0]->{'-line'} || 0); - return (wantarray) ? @loc : join(':', @loc); -} - -##--------------------------------------------------------------------------- - -=head2 Pod::InteriorSequence::B<DESTROY()> - -This method performs any necessary cleanup for the interior-sequence. -If you override this method then it is B<imperative> that you invoke -the parent method from within your own method, otherwise -I<interior-sequence storage will not be reclaimed upon destruction!> - -=cut - -sub DESTROY { - ## We need to get rid of all child->parent pointers throughout the - ## tree so their reference counts will go to zero and they can be - ## garbage-collected - _unset_child2parent_links(@_); -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::ParseTree; - -##--------------------------------------------------------------------------- - -=head1 B<Pod::ParseTree> - -This object corresponds to a tree of parsed POD text. As POD text is -scanned from left to right, it is parsed into an ordered list of -text-strings and B<Pod::InteriorSequence> objects (in order of -appearance). A B<Pod::ParseTree> object corresponds to this list of -strings and sequences. Each interior sequence in the parse-tree may -itself contain a parse-tree (since interior sequences may be nested). - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::ParseTree-E<gt>B<new()> - - my $ptree1 = Pod::ParseTree->new; - my $ptree2 = new Pod::ParseTree; - my $ptree4 = Pod::ParseTree->new($array_ref); - my $ptree3 = new Pod::ParseTree($array_ref); - -This is a class method that constructs a C<Pod::Parse_tree> object and -returns a reference to the new parse-tree. If a single-argument is given, -it must be a reference to an array, and is used to initialize the root -(top) of the parse tree. - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - my $self = (@_ == 1 and ref $_[0]) ? $_[0] : []; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-E<gt>B<top()> - - my $top_node = $ptree->top(); - $ptree->top( $top_node ); - $ptree->top( @children ); - -This method gets/sets the top node of the parse-tree. If no arguments are -given, it returns the topmost node in the tree (the root), which is also -a B<Pod::ParseTree>. If it is given a single argument that is a reference, -then the reference is assumed to a parse-tree and becomes the new top node. -Otherwise, if arguments are given, they are treated as the new list of -children for the top node. - -=cut - -sub top { - my $self = shift; - if (@_ > 0) { - @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; - } - return $self; -} - -## let parse_tree() & ptree() be aliases for the 'top' method -*parse_tree = *ptree = \⊤ - -##--------------------------------------------------------------------------- - -=head2 $ptree-E<gt>B<children()> - -This method gets/sets the children of the top node in the parse-tree. -If no arguments are given, it returns the list (array) of children -(each of which should be either a string or a B<Pod::InteriorSequence>. -Otherwise, if arguments are given, they are treated as the new list of -children for the top node. - -=cut - -sub children { - my $self = shift; - if (@_ > 0) { - @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; - } - return @{ $self }; -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-E<gt>B<prepend()> - -This method prepends the given text or parse-tree to the current parse-tree. -If the first item on the parse-tree is text and the argument is also text, -then the text is prepended to the first item (not added as a separate string). -Otherwise the argument is added as a new string or parse-tree I<before> -the current one. - -=cut - -use vars qw(@ptree); ## an alias used for performance reasons - -sub prepend { - my $self = shift; - local *ptree = $self; - for (@_) { - next unless length; - if (@ptree && !(ref $ptree[0]) && !(ref $_)) { - $ptree[0] = $_ . $ptree[0]; - } - else { - unshift @ptree, $_; - } - } -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-E<gt>B<append()> - -This method appends the given text or parse-tree to the current parse-tree. -If the last item on the parse-tree is text and the argument is also text, -then the text is appended to the last item (not added as a separate string). -Otherwise the argument is added as a new string or parse-tree I<after> -the current one. - -=cut - -sub append { - my $self = shift; - local *ptree = $self; - my $can_append = @ptree && !(ref $ptree[-1]); - for (@_) { - if (ref) { - push @ptree, $_; - } - elsif(!length) { - next; - } - elsif ($can_append) { - $ptree[-1] .= $_; - } - else { - push @ptree, $_; - } - } -} - -=head2 $ptree-E<gt>B<raw_text()> - - my $ptree_raw_text = $ptree->raw_text(); - -This method will return the I<raw> text of the POD parse-tree -exactly as it appeared in the input. - -=cut - -sub raw_text { - my $self = shift; - my $text = ''; - for ( @$self ) { - $text .= (ref $_) ? $_->raw_text : $_; - } - return $text; -} - -##--------------------------------------------------------------------------- - -## Private routines to set/unset child->parent links - -sub _unset_child2parent_links { - my $self = shift; - local *ptree = $self; - for (@ptree) { - next unless (defined and length and ref and ref ne 'SCALAR'); - $_->_unset_child2parent_links() - if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); - } -} - -sub _set_child2parent_links { - ## nothing to do, Pod::ParseTrees cant have parent pointers -} - -=head2 Pod::ParseTree::B<DESTROY()> - -This method performs any necessary cleanup for the parse-tree. -If you override this method then it is B<imperative> -that you invoke the parent method from within your own method, -otherwise I<parse-tree storage will not be reclaimed upon destruction!> - -=cut - -sub DESTROY { - ## We need to get rid of all child->parent pointers throughout the - ## tree so their reference counts will go to zero and they can be - ## garbage-collected - _unset_child2parent_links(@_); -} - -############################################################################# - -=head1 SEE ALSO - -B<Pod::InputObjects> is part of the L<Pod::Parser> distribution. - -See L<Pod::Parser>, L<Pod::Select> - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Brad Appleton E<lt>bradapp@enteract.comE<gt> - -=cut - -1; diff --git a/Master/tlpkg/tlperl/lib/Pod/Man.pm b/Master/tlpkg/tlperl/lib/Pod/Man.pm index 6ebab1e0e5c..d7c029357a2 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Man.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Man.pm @@ -14,7 +14,7 @@ package Pod::Man; -use 5.006; +use 5.008; use strict; use warnings; @@ -24,7 +24,9 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); use Carp qw(carp croak); use Pod::Simple (); -# Conditionally import Encode and set $HAS_ENCODE if it is available. +# Conditionally import Encode and set $HAS_ENCODE if it is available. This is +# required to support building as part of Perl core, since podlators is built +# before Encode is. our $HAS_ENCODE; BEGIN { $HAS_ENCODE = eval { require Encode }; @@ -32,7 +34,7 @@ BEGIN { @ISA = qw(Pod::Simple); -$VERSION = '4.11'; +$VERSION = '4.14'; # Set the debugging level. If someone has inserted a debug function into this # class already, use that. Otherwise, use any Pod::Simple debug function @@ -245,13 +247,8 @@ sub init_quotes { sub init_page { my ($self) = @_; - # We used to try first to get the version number from a local binary, but - # we shouldn't need that any more. Get the version from the running Perl. - # Work a little magic to handle subversions correctly under both the - # pre-5.6 and the post-5.6 version numbering schemes. - my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/); - $version[2] ||= 0; - $version[2] *= 10 ** (3 - length $version[2]); + # Get the version from the running Perl. + my @version = ($] =~ /^(\d+)\.(\d{3})(\d+)$/); for (@version) { $_ += 0 } my $version = join ('.', @version); @@ -799,7 +796,7 @@ sub start_document { eval { my @options = (output => 1, details => 1); my @layers = PerlIO::get_layers (*{$$self{output_fh}}, @options); - if ($layers[-1] & PerlIO::F_UTF8 ()) { + if ($layers[-1] && ($layers[-1] & PerlIO::F_UTF8 ())) { $$self{ENCODE} = 0; } } @@ -1881,7 +1878,9 @@ being the file to write the formatted output to. You can also call parse_lines() to parse an array of lines or parse_string_document() to parse a document already in memory. As with parse_file(), parse_lines() and parse_string_document() default to sending -their output to C<STDOUT> unless changed with the output_fh() method. +their output to C<STDOUT> unless changed with the output_fh() method. Be +aware that parse_lines() and parse_string_document() both expect raw bytes, +not decoded characters. To put the output from any parse method into a string instead of a file handle, call the output_string() method instead of output_fh(). @@ -2012,7 +2011,7 @@ are mine). =head1 COPYRIGHT AND LICENSE -Copyright 1999-2010, 2012-2018 Russ Allbery <rra@cpan.org> +Copyright 1999-2010, 2012-2019 Russ Allbery <rra@cpan.org> Substantial contributions by Sean Burke <sburke@cpan.org>. diff --git a/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm b/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm index 0be5323973b..273c95847ac 100644 --- a/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm +++ b/Master/tlpkg/tlperl/lib/Pod/ParseLink.pm @@ -13,7 +13,7 @@ package Pod::ParseLink; -use 5.006; +use 5.008; use strict; use warnings; @@ -23,7 +23,7 @@ use Exporter; @ISA = qw(Exporter); @EXPORT = qw(parselink); -$VERSION = '4.11'; +$VERSION = '4.14'; ############################################################################## # Implementation @@ -167,11 +167,11 @@ L<perlpodspec> for more information. =head1 AUTHOR -Russ Allbery <rra@cpan.org>. +Russ Allbery <rra@cpan.org> =head1 COPYRIGHT AND LICENSE -Copyright 2001, 2008, 2009, 2014, 2018 Russ Allbery <rra@cpan.org> +Copyright 2001, 2008, 2009, 2014, 2018-2019 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm b/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm deleted file mode 100644 index 2afd0cd420e..00000000000 --- a/Master/tlpkg/tlperl/lib/Pod/ParseUtils.pm +++ /dev/null @@ -1,861 +0,0 @@ -############################################################################# -# Pod/ParseUtils.pm -- helpers for POD parsing and conversion -# -# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::ParseUtils; -use strict; - -use vars qw($VERSION); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -=head1 NAME - -Pod::ParseUtils - helpers for POD parsing and conversion - -=head1 SYNOPSIS - - use Pod::ParseUtils; - - my $list = new Pod::List; - my $link = Pod::Hyperlink->new('Pod::Parser'); - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -B<Pod::ParseUtils> contains a few object-oriented helper packages for -POD parsing and processing (i.e. in POD formatters and translators). - -=cut - -#----------------------------------------------------------------------------- -# Pod::List -# -# class to hold POD list info (=over, =item, =back) -#----------------------------------------------------------------------------- - -package Pod::List; - -use Carp; - -=head2 Pod::List - -B<Pod::List> can be used to hold information about POD lists -(written as =over ... =item ... =back) for further processing. -The following methods are available: - -=over 4 - -=item Pod::List-E<gt>new() - -Create a new list object. Properties may be specified through a hash -reference like this: - - my $list = Pod::List->new({ -start => $., -indent => 4 }); - -See the individual methods/properties for details. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->{-file} ||= 'unknown'; - $self->{-start} ||= 'unknown'; - $self->{-indent} ||= 4; # perlpod: "should be the default" - $self->{_items} = []; - $self->{-type} ||= ''; -} - -=item $list-E<gt>file() - -Without argument, retrieves the file name the list is in. This must -have been set before by either specifying B<-file> in the B<new()> -method or by calling the B<file()> method with a scalar argument. - -=cut - -# The POD file name the list appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $list-E<gt>start() - -Without argument, retrieves the line number where the list started. -This must have been set before by either specifying B<-start> in the -B<new()> method or by calling the B<start()> method with a scalar -argument. - -=cut - -# The line in the file the node appears -sub start { - return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; -} - -=item $list-E<gt>indent() - -Without argument, retrieves the indent level of the list as specified -in C<=over n>. This must have been set before by either specifying -B<-indent> in the B<new()> method or by calling the B<indent()> method -with a scalar argument. - -=cut - -# indent level -sub indent { - return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; -} - -=item $list-E<gt>type() - -Without argument, retrieves the list type, which can be an arbitrary value, -e.g. C<OL>, C<UL>, ... when thinking the HTML way. -This must have been set before by either specifying -B<-type> in the B<new()> method or by calling the B<type()> method -with a scalar argument. - -=cut - -# The type of the list (UL, OL, ...) -sub type { - return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; -} - -=item $list-E<gt>rx() - -Without argument, retrieves a regular expression for simplifying the -individual item strings once the list type has been determined. Usage: -E.g. when converting to HTML, one might strip the leading number in -an ordered list as C<E<lt>OLE<gt>> already prints numbers itself. -This must have been set before by either specifying -B<-rx> in the B<new()> method or by calling the B<rx()> method -with a scalar argument. - -=cut - -# The regular expression to simplify the items -sub rx { - return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; -} - -=item $list-E<gt>item() - -Without argument, retrieves the array of the items in this list. -The items may be represented by any scalar. -If an argument has been given, it is pushed on the list of items. - -=cut - -# The individual =items of this list -sub item { - my ($self,$item) = @_; - if(defined $item) { - push(@{$self->{_items}}, $item); - return $item; - } - else { - return @{$self->{_items}}; - } -} - -=item $list-E<gt>parent() - -Without argument, retrieves information about the parent holding this -list, which is represented as an arbitrary scalar. -This must have been set before by either specifying -B<-parent> in the B<new()> method or by calling the B<parent()> method -with a scalar argument. - -=cut - -# possibility for parsers/translators to store information about the -# lists's parent object -sub parent { - return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; -} - -=item $list-E<gt>tag() - -Without argument, retrieves information about the list tag, which can be -any scalar. -This must have been set before by either specifying -B<-tag> in the B<new()> method or by calling the B<tag()> method -with a scalar argument. - -=back - -=cut - -# possibility for parsers/translators to store information about the -# list's object -sub tag { - return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag}; -} - -#----------------------------------------------------------------------------- -# Pod::Hyperlink -# -# class to manipulate POD hyperlinks (L<>) -#----------------------------------------------------------------------------- - -package Pod::Hyperlink; - -=head2 Pod::Hyperlink - -B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage: - - my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); - -The B<Pod::Hyperlink> class is mainly designed to parse the contents of the -C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the -different parts of a POD hyperlink for further processing. It can also be -used to construct hyperlinks. - -=over 4 - -=item Pod::Hyperlink-E<gt>new() - -The B<new()> method can either be passed a set of key/value pairs or a single -scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object -of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a -failure, the error message is stored in C<$@>. - -=cut - -use Carp; - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = +{}; - bless $self, $class; - $self->initialize(); - if(defined $_[0]) { - if(ref($_[0])) { - # called with a list of parameters - %$self = %{$_[0]}; - $self->_construct_text(); - } - else { - # called with L<> contents - return unless($self->parse($_[0])); - } - } - return $self; -} - -sub initialize { - my $self = shift; - $self->{-line} ||= 'undef'; - $self->{-file} ||= 'undef'; - $self->{-page} ||= ''; - $self->{-node} ||= ''; - $self->{-alttext} ||= ''; - $self->{-type} ||= 'undef'; - $self->{_warnings} = []; -} - -=item $link-E<gt>parse($string) - -This method can be used to (re)parse a (new) hyperlink, i.e. the contents -of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object. -Warnings are stored in the B<warnings> property. -E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point -to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage -section can simply be dropped. - -=cut - -sub parse { - my $self = shift; - local($_) = $_[0]; - # syntax check the link and extract destination - my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0); - - $self->{_warnings} = []; - - # collapse newlines with whitespace - s/\s*\n+\s*/ /g; - - # strip leading/trailing whitespace - if(s/^[\s\n]+//) { - $self->warning('ignoring leading whitespace in link'); - } - if(s/[\s\n]+$//) { - $self->warning('ignoring trailing whitespace in link'); - } - unless(length($_)) { - _invalid_link('empty link'); - return; - } - - ## Check for different possibilities. This is tedious and error-prone - # we match all possibilities (alttext, page, section/item) - #warn "DEBUG: link=$_\n"; - - # only page - # problem: a lot of people use (), or (1) or the like to indicate - # man page sections. But this collides with L<func()> that is supposed - # to point to an internal function... - my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)'; - # page name only - if(/^($page_rx)$/o) { - $page = $1; - $type = 'page'; - } - # alttext, page and "section" - elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) { - ($alttext, $page, $node) = ($1, $2, $3); - $type = 'section'; - $quoted = 1; #... therefore | and / are allowed - } - # alttext and page - elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) { - ($alttext, $page) = ($1, $2); - $type = 'page'; - } - # alttext and "section" - elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) { - ($alttext, $node) = ($1,$2); - $type = 'section'; - $quoted = 1; - } - # page and "section" - elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) { - ($page, $node) = ($1, $2); - $type = 'section'; - $quoted = 1; - } - # page and item - elsif(m{^($page_rx)\s*/\s*(.+)$}o) { - ($page, $node) = ($1, $2); - $type = 'item'; - } - # only "section" - elsif(m{^/?"(.+)"$}) { - $node = $1; - $type = 'section'; - $quoted = 1; - } - # only item - elsif(m{^\s*/(.+)$}) { - $node = $1; - $type = 'item'; - } - - # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should? - elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) { - ($alttext,$node) = ($1,$2); - $type = 'hyperlink'; - } - - # non-standard: Hyperlink - elsif(/^(\w+:[^:\s]\S*)$/i) { - $node = $1; - $type = 'hyperlink'; - } - # alttext, page and item - elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) { - ($alttext, $page, $node) = ($1, $2, $3); - $type = 'item'; - } - # alttext and item - elsif(m{^(.*?)\s*[|]\s*/(.+)$}) { - ($alttext, $node) = ($1,$2); - } - # must be an item or a "malformed" section (without "") - else { - $node = $_; - $type = 'item'; - } - # collapse whitespace in nodes - $node =~ s/\s+/ /gs; - - # empty alternative text expands to node name - if(defined $alttext) { - if(!length($alttext)) { - $alttext = $node || $page; - } - } - else { - $alttext = ''; - } - - if($page =~ /[(]\w*[)]$/) { - $self->warning("(section) in '$page' deprecated"); - } - if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') { - $self->warning("node '$node' contains non-escaped | or /"); - } - if($alttext =~ m{[|/]}) { - $self->warning("alternative text '$node' contains non-escaped | or /"); - } - $self->{-page} = $page; - $self->{-node} = $node; - $self->{-alttext} = $alttext; - #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n"; - $self->{-type} = $type; - $self->_construct_text(); - 1; -} - -sub _construct_text { - my $self = shift; - my $alttext = $self->alttext(); - my $type = $self->type(); - my $section = $self->node(); - my $page = $self->page(); - my $page_ext = ''; - $page =~ s/([(]\w*[)])$// && ($page_ext = $1); - if($alttext) { - $self->{_text} = $alttext; - } - elsif($type eq 'hyperlink') { - $self->{_text} = $section; - } - else { - $self->{_text} = ($section || '') . - (($page && $section) ? ' in ' : '') . - "$page$page_ext"; - } - # for being marked up later - # use the non-standard markers P<> and Q<>, so that the resulting - # text can be parsed by the translators. It's their job to put - # the correct hypertext around the linktext - if($alttext) { - $self->{_markup} = "Q<$alttext>"; - } - elsif($type eq 'hyperlink') { - $self->{_markup} = "Q<$section>"; - } - else { - $self->{_markup} = (!$section ? '' : "Q<$section>") . - ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : ''); - } -} - -=item $link-E<gt>markup($string) - -Set/retrieve the textual value of the link. This string contains special -markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the -translator's interior sequence expansion engine to the -formatter-specific code to highlight/activate the hyperlink. The details -have to be implemented in the translator. - -=cut - -#' retrieve/set markuped text -sub markup { - return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; -} - -=item $link-E<gt>text() - -This method returns the textual representation of the hyperlink as above, -but without markers (read only). Depending on the link type this is one of -the following alternatives (the + and * denote the portions of the text -that are marked up): - - +perl+ L<perl> - *$|* in +perlvar+ L<perlvar/$|> - *OPTIONS* in +perldoc+ L<perldoc/"OPTIONS"> - *DESCRIPTION* L<"DESCRIPTION"> - -=cut - -# The complete link's text -sub text { - return $_[0]->{_text}; -} - -=item $link-E<gt>warning() - -After parsing, this method returns any warnings encountered during the -parsing process. - -=cut - -# Set/retrieve warnings -sub warning { - my $self = shift; - if(@_) { - push(@{$self->{_warnings}}, @_); - return @_; - } - return @{$self->{_warnings}}; -} - -=item $link-E<gt>file() - -=item $link-E<gt>line() - -Just simple slots for storing information about the line and the file -the link was encountered in. Has to be filled in manually. - -=cut - -# The line in the file the link appears -sub line { - return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; -} - -# The POD file name the link appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $link-E<gt>page() - -This method sets or returns the POD page this link points to. - -=cut - -# The POD page the link appears on -sub page { - if (@_ > 1) { - $_[0]->{-page} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-page}; -} - -=item $link-E<gt>node() - -As above, but the destination node text of the link. - -=cut - -# The link destination -sub node { - if (@_ > 1) { - $_[0]->{-node} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-node}; -} - -=item $link-E<gt>alttext() - -Sets or returns an alternative text specified in the link. - -=cut - -# Potential alternative text -sub alttext { - if (@_ > 1) { - $_[0]->{-alttext} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-alttext}; -} - -=item $link-E<gt>type() - -The node type, either C<section> or C<item>. As an unofficial type, -there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>> - -=cut - -# The type: item or headn -sub type { - return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; -} - -=item $link-E<gt>link() - -Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>. - -=back - -=cut - -# The link itself -sub link { - my $self = shift; - my $link = $self->page() || ''; - if($self->node()) { - my $node = $self->node(); - $node =~ s/\|/E<verbar>/g; - $node =~ s{/}{E<sol>}g; - if($self->type() eq 'section') { - $link .= ($link ? '/' : '') . '"' . $node . '"'; - } - elsif($self->type() eq 'hyperlink') { - $link = $self->node(); - } - else { # item - $link .= '/' . $node; - } - } - if($self->alttext()) { - my $text = $self->alttext(); - $text =~ s/\|/E<verbar>/g; - $text =~ s{/}{E<sol>}g; - $link = "$text|$link"; - } - return $link; -} - -sub _invalid_link { - my ($msg) = @_; - # this sets @_ - #eval { die "$msg\n" }; - #chomp $@; - $@ = $msg; # this seems to work, too! - return; -} - -#----------------------------------------------------------------------------- -# Pod::Cache -# -# class to hold POD page details -#----------------------------------------------------------------------------- - -package Pod::Cache; - -=head2 Pod::Cache - -B<Pod::Cache> holds information about a set of POD documents, -especially the nodes for hyperlinks. -The following methods are available: - -=over 4 - -=item Pod::Cache-E<gt>new() - -Create a new cache object. This object can hold an arbitrary number of -POD documents of class Pod::Cache::Item. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = []; - bless $self, $class; - return $self; -} - -=item $cache-E<gt>item() - -Add a new item to the cache. Without arguments, this method returns a -list of all cache elements. - -=cut - -sub item { - my ($self,%param) = @_; - if(%param) { - my $item = Pod::Cache::Item->new(%param); - push(@$self, $item); - return $item; - } - else { - return @{$self}; - } -} - -=item $cache-E<gt>find_page($name) - -Look for a POD document named C<$name> in the cache. Returns the -reference to the corresponding Pod::Cache::Item object or undef if -not found. - -=back - -=cut - -sub find_page { - my ($self,$page) = @_; - foreach(@$self) { - if($_->page() eq $page) { - return $_; - } - } - return; -} - -package Pod::Cache::Item; - -=head2 Pod::Cache::Item - -B<Pod::Cache::Item> holds information about individual POD documents, -that can be grouped in a Pod::Cache object. -It is intended to hold information about the hyperlink nodes of POD -documents. -The following methods are available: - -=over 4 - -=item Pod::Cache::Item-E<gt>new() - -Create a new object. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->{-nodes} = [] unless(defined $self->{-nodes}); -} - -=item $cacheitem-E<gt>page() - -Set/retrieve the POD document name (e.g. "Pod::Parser"). - -=cut - -# The POD page -sub page { - return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; -} - -=item $cacheitem-E<gt>description() - -Set/retrieve the POD short description as found in the C<=head1 NAME> -section. - -=cut - -# The POD description, taken out of NAME if present -sub description { - return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; -} - -=item $cacheitem-E<gt>path() - -Set/retrieve the POD file storage path. - -=cut - -# The file path -sub path { - return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; -} - -=item $cacheitem-E<gt>file() - -Set/retrieve the POD file name. - -=cut - -# The POD file name -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $cacheitem-E<gt>nodes() - -Add a node (or a list of nodes) to the document's node list. Note that -the order is kept, i.e. start with the first node and end with the last. -If no argument is given, the current list of nodes is returned in the -same order the nodes have been added. -A node can be any scalar, but usually is a pair of node string and -unique id for the C<find_node> method to work correctly. - -=cut - -# The POD nodes -sub nodes { - my ($self,@nodes) = @_; - if(@nodes) { - push(@{$self->{-nodes}}, @nodes); - return @nodes; - } - else { - return @{$self->{-nodes}}; - } -} - -=item $cacheitem-E<gt>find_node($name) - -Look for a node or index entry named C<$name> in the object. -Returns the unique id of the node (i.e. the second element of the array -stored in the node array) or undef if not found. - -=cut - -sub find_node { - my ($self,$node) = @_; - my @search; - push(@search, @{$self->{-nodes}}) if($self->{-nodes}); - push(@search, @{$self->{-idx}}) if($self->{-idx}); - foreach(@search) { - if($_->[0] eq $node) { - return $_->[1]; # id - } - } - return; -} - -=item $cacheitem-E<gt>idx() - -Add an index entry (or a list of them) to the document's index list. Note that -the order is kept, i.e. start with the first node and end with the last. -If no argument is given, the current list of index entries is returned in the -same order the entries have been added. -An index entry can be any scalar, but usually is a pair of string and -unique id. - -=back - -=cut - -# The POD index entries -sub idx { - my ($self,@idx) = @_; - if(@idx) { - push(@{$self->{-idx}}, @idx); - return @idx; - } - else { - return @{$self->{-idx}}; - } -} - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -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>, -L<pod2html> - -=cut - -1; diff --git a/Master/tlpkg/tlperl/lib/Pod/Parser.pm b/Master/tlpkg/tlperl/lib/Pod/Parser.pm deleted file mode 100644 index 63edcd2e197..00000000000 --- a/Master/tlpkg/tlperl/lib/Pod/Parser.pm +++ /dev/null @@ -1,1836 +0,0 @@ -############################################################################# -# Pod/Parser.pm -- package which defines a base class for parsing POD docs. -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Parser; -use strict; - -## These "variables" are used as local "glob aliases" for performance -use vars qw($VERSION @ISA %myData %myOpts @input_stack); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::Parser - base class for creating POD filters and translators - -=head1 SYNOPSIS - - use Pod::Parser; - - package MyParser; - @ISA = qw(Pod::Parser); - - sub command { - my ($parser, $command, $paragraph, $line_num) = @_; - ## Interpret the command and its text; sample actions might be: - if ($command eq 'head1') { ... } - elsif ($command eq 'head2') { ... } - ## ... other commands and their actions - my $out_fh = $parser->output_handle(); - my $expansion = $parser->interpolate($paragraph, $line_num); - print $out_fh $expansion; - } - - sub verbatim { - my ($parser, $paragraph, $line_num) = @_; - ## Format verbatim paragraph; sample actions might be: - my $out_fh = $parser->output_handle(); - print $out_fh $paragraph; - } - - sub textblock { - my ($parser, $paragraph, $line_num) = @_; - ## Translate/Format this block of text; sample actions might be: - my $out_fh = $parser->output_handle(); - my $expansion = $parser->interpolate($paragraph, $line_num); - print $out_fh $expansion; - } - - sub interior_sequence { - my ($parser, $seq_command, $seq_argument) = @_; - ## Expand an interior sequence; sample actions might be: - return "*$seq_argument*" if ($seq_command eq 'B'); - return "`$seq_argument'" if ($seq_command eq 'C'); - return "_${seq_argument}_'" if ($seq_command eq 'I'); - ## ... other sequence commands and their resulting text - } - - package main; - - ## Create a parser object and have it parse file whose name was - ## given on the command-line (use STDIN if no files were given). - $parser = new MyParser(); - $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0); - for (@ARGV) { $parser->parse_from_file($_); } - -=head1 REQUIRES - -perl5.005, Pod::InputObjects, Exporter, Symbol, Carp - -=head1 EXPORTS - -Nothing. - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -B<Pod::Parser> is a base class for creating POD filters and translators. -It handles most of the effort involved with parsing the POD sections -from an input stream, leaving subclasses free to be concerned only with -performing the actual translation of text. - -B<Pod::Parser> parses PODs, and makes method calls to handle the various -components of the POD. Subclasses of B<Pod::Parser> override these methods -to translate the POD into whatever output format they desire. - -=head1 QUICK OVERVIEW - -To create a POD filter for translating POD documentation into some other -format, you create a subclass of B<Pod::Parser> which typically overrides -just the base class implementation for the following methods: - -=over 2 - -=item * - -B<command()> - -=item * - -B<verbatim()> - -=item * - -B<textblock()> - -=item * - -B<interior_sequence()> - -=back - -You may also want to override the B<begin_input()> and B<end_input()> -methods for your subclass (to perform any needed per-file and/or -per-document initialization or cleanup). - -If you need to perform any preprocessing of input before it is parsed -you may want to override one or more of B<preprocess_line()> and/or -B<preprocess_paragraph()>. - -Sometimes it may be necessary to make more than one pass over the input -files. If this is the case you have several options. You can make the -first pass using B<Pod::Parser> and override your methods to store the -intermediate results in memory somewhere for the B<end_pod()> method to -process. You could use B<Pod::Parser> for several passes with an -appropriate state variable to control the operation for each pass. If -your input source can't be reset to start at the beginning, you can -store it in some other structure as a string or an array and have that -structure implement a B<getline()> method (which is all that -B<parse_from_filehandle()> uses to read input). - -Feel free to add any member data fields you need to keep track of things -like current font, indentation, horizontal or vertical position, or -whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA"> -to avoid name collisions. - -For the most part, the B<Pod::Parser> base class should be able to -do most of the input parsing for you and leave you free to worry about -how to interpret the commands and translate the result. - -Note that all we have described here in this quick overview is the -simplest most straightforward use of B<Pod::Parser> to do stream-based -parsing. It is also possible to use the B<Pod::Parser::parse_text> function -to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">. - -=head1 PARSING OPTIONS - -A I<parse-option> is simply a named option of B<Pod::Parser> with a -value that corresponds to a certain specified behavior. These various -behaviors of B<Pod::Parser> may be enabled/disabled by setting -or unsetting one or more I<parse-options> using the B<parseopts()> method. -The set of currently accepted parse-options is as follows: - -=over 3 - -=item B<-want_nonPODs> (default: unset) - -Normally (by default) B<Pod::Parser> will only provide access to -the POD sections of the input. Input paragraphs that are not part -of the POD-format documentation are not made available to the caller -(not even using B<preprocess_paragraph()>). Setting this option to a -non-empty, non-zero value will allow B<preprocess_paragraph()> to see -non-POD sections of the input as well as POD sections. The B<cutting()> -method can be used to determine if the corresponding paragraph is a POD -paragraph, or some other input paragraph. - -=item B<-process_cut_cmd> (default: unset) - -Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive -by itself and does not pass it on to the caller for processing. Setting -this option to a non-empty, non-zero value will cause B<Pod::Parser> to -pass the C<=cut> directive to the caller just like any other POD command -(and hence it may be processed by the B<command()> method). - -B<Pod::Parser> will still interpret the C<=cut> directive to mean that -"cutting mode" has been (re)entered, but the caller will get a chance -to capture the actual C<=cut> paragraph itself for whatever purpose -it desires. - -=item B<-warnings> (default: unset) - -Normally (by default) B<Pod::Parser> recognizes a bare minimum of -pod syntax errors and warnings and issues diagnostic messages -for errors, but not for warnings. (Use B<Pod::Checker> to do more -thorough checking of POD syntax.) Setting this option to a non-empty, -non-zero value will cause B<Pod::Parser> to issue diagnostics for -the few warnings it recognizes as well as the errors. - -=back - -Please see L<"parseopts()"> for a complete description of the interface -for the setting and unsetting of parse-options. - -=cut - -############################################################################# - -#use diagnostics; -use Pod::InputObjects; -use Carp; -use Exporter; -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} -@ISA = qw(Exporter); - -############################################################################# - -=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES - -B<Pod::Parser> provides several methods which most subclasses will probably -want to override. These methods are as follows: - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<command()> - - $parser->command($cmd,$text,$line_num,$pod_para); - -This method should be overridden by subclasses to take the appropriate -action when a POD command paragraph (denoted by a line beginning with -"=") is encountered. When such a POD directive is seen in the input, -this method is called and is passed: - -=over 3 - -=item C<$cmd> - -the name of the command for this POD paragraph - -=item C<$text> - -the paragraph text for the given POD paragraph command. - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C<Pod::Paragraph> object which contains further -information about the paragraph command (see L<Pod::InputObjects> -for details). - -=back - -B<Note> that this method I<is> called for C<=pod> paragraphs. - -The base class implementation of this method simply treats the raw POD -command as normal block of paragraph text (invoking the B<textblock()> -method with the command paragraph). - -=cut - -sub command { - my ($self, $cmd, $text, $line_num, $pod_para) = @_; - ## Just treat this like a textblock - $self->textblock($pod_para->raw_text(), $line_num, $pod_para); -} - -##--------------------------------------------------------------------------- - -=head1 B<verbatim()> - - $parser->verbatim($text,$line_num,$pod_para); - -This method may be overridden by subclasses to take the appropriate -action when a block of verbatim text is encountered. It is passed the -following parameters: - -=over 3 - -=item C<$text> - -the block of text for the verbatim paragraph - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C<Pod::Paragraph> object which contains further -information about the paragraph (see L<Pod::InputObjects> -for details). - -=back - -The base class implementation of this method simply prints the textblock -(unmodified) to the output filehandle. - -=cut - -sub verbatim { - my ($self, $text, $line_num, $pod_para) = @_; - my $out_fh = $self->{_OUTPUT}; - print $out_fh $text; -} - -##--------------------------------------------------------------------------- - -=head1 B<textblock()> - - $parser->textblock($text,$line_num,$pod_para); - -This method may be overridden by subclasses to take the appropriate -action when a normal block of POD text is encountered (although the base -class method will usually do what you want). It is passed the following -parameters: - -=over 3 - -=item C<$text> - -the block of text for the a POD paragraph - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C<Pod::Paragraph> object which contains further -information about the paragraph (see L<Pod::InputObjects> -for details). - -=back - -In order to process interior sequences, subclasses implementations of -this method will probably want to invoke either B<interpolate()> or -B<parse_text()>, passing it the text block C<$text>, and the corresponding -line number in C<$line_num>, and then perform any desired processing upon -the returned result. - -The base class implementation of this method simply prints the text block -as it occurred in the input stream). - -=cut - -sub textblock { - my ($self, $text, $line_num, $pod_para) = @_; - my $out_fh = $self->{_OUTPUT}; - print $out_fh $self->interpolate($text, $line_num); -} - -##--------------------------------------------------------------------------- - -=head1 B<interior_sequence()> - - $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq); - -This method should be overridden by subclasses to take the appropriate -action when an interior sequence is encountered. An interior sequence is -an embedded command within a block of text which appears as a command -name (usually a single uppercase character) followed immediately by a -string of text which is enclosed in angle brackets. This method is -passed the sequence command C<$seq_cmd> and the corresponding text -C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior -sequence that occurs in the string that it is passed. It should return -the desired text string to be used in place of the interior sequence. -The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence> -object which contains further information about the interior sequence. -Please see L<Pod::InputObjects> for details if you need to access this -additional information. - -Subclass implementations of this method may wish to invoke the -B<nested()> method of C<$pod_seq> to see if it is nested inside -some other interior-sequence (and if so, which kind). - -The base class implementation of the B<interior_sequence()> method -simply returns the raw text of the interior sequence (as it occurred -in the input) to the caller. - -=cut - -sub interior_sequence { - my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_; - ## Just return the raw text of the interior sequence - return $pod_seq->raw_text(); -} - -############################################################################# - -=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES - -B<Pod::Parser> provides several methods which subclasses may want to override -to perform any special pre/post-processing. These methods do I<not> have to -be overridden, but it may be useful for subclasses to take advantage of them. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<new()> - - my $parser = Pod::Parser->new(); - -This is the constructor for B<Pod::Parser> and its subclasses. You -I<do not> need to override this method! It is capable of constructing -subclass objects as well as base class objects, provided you use -any of the following constructor invocation styles: - - my $parser1 = MyParser->new(); - my $parser2 = new MyParser(); - my $parser3 = $parser2->new(); - -where C<MyParser> is some subclass of B<Pod::Parser>. - -Using the syntax C<MyParser::new()> to invoke the constructor is I<not> -recommended, but if you insist on being able to do this, then the -subclass I<will> need to override the B<new()> constructor method. If -you do override the constructor, you I<must> be sure to invoke the -B<initialize()> method of the newly blessed object. - -Using any of the above invocations, the first argument to the -constructor is always the corresponding package name (or object -reference). No other arguments are required, but if desired, an -associative array (or hash-table) my be passed to the B<new()> -constructor, as in: - - my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 ); - my $parser2 = new MyParser( -myflag => 1 ); - -All arguments passed to the B<new()> constructor will be treated as -key/value pairs in a hash-table. The newly constructed object will be -initialized by copying the contents of the given hash-table (which may -have been empty). The B<new()> constructor for this class and all of its -subclasses returns a blessed reference to the initialized object (hash-table). - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my ($this,%params) = @_; - my $class = ref($this) || $this; - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. - my $self = { %params }; - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - $self->initialize(); - return $self; -} - -##--------------------------------------------------------------------------- - -=head1 B<initialize()> - - $parser->initialize(); - -This method performs any necessary object initialization. It takes no -arguments (other than the object instance of course, which is typically -copied to a local variable named C<$self>). If subclasses override this -method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>. - -=cut - -sub initialize { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<begin_pod()> - - $parser->begin_pod(); - -This method is invoked at the beginning of processing for each POD -document that is encountered in the input. Subclasses should override -this method to perform any per-document initialization. - -=cut - -sub begin_pod { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<begin_input()> - - $parser->begin_input(); - -This method is invoked by B<parse_from_filehandle()> immediately I<before> -processing input from a filehandle. The base class implementation does -nothing, however, subclasses may override it to perform any per-file -initializations. - -Note that if multiple files are parsed for a single POD document -(perhaps the result of some future C<=include> directive) this method -is invoked for every file that is parsed. If you wish to perform certain -initializations once per document, then you should use B<begin_pod()>. - -=cut - -sub begin_input { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<end_input()> - - $parser->end_input(); - -This method is invoked by B<parse_from_filehandle()> immediately I<after> -processing input from a filehandle. The base class implementation does -nothing, however, subclasses may override it to perform any per-file -cleanup actions. - -Please note that if multiple files are parsed for a single POD document -(perhaps the result of some kind of C<=include> directive) this method -is invoked for every file that is parsed. If you wish to perform certain -cleanup actions once per document, then you should use B<end_pod()>. - -=cut - -sub end_input { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<end_pod()> - - $parser->end_pod(); - -This method is invoked at the end of processing for each POD document -that is encountered in the input. Subclasses should override this method -to perform any per-document finalization. - -=cut - -sub end_pod { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<preprocess_line()> - - $textline = $parser->preprocess_line($text, $line_num); - -This method should be overridden by subclasses that wish to perform -any kind of preprocessing for each I<line> of input (I<before> it has -been determined whether or not it is part of a POD paragraph). The -parameter C<$text> is the input line; and the parameter C<$line_num> is -the line number of the corresponding text line. - -The value returned should correspond to the new text to use in its -place. If the empty string or an undefined value is returned then no -further processing will be performed for this line. - -Please note that the B<preprocess_line()> method is invoked I<before> -the B<preprocess_paragraph()> method. After all (possibly preprocessed) -lines in a paragraph have been assembled together and it has been -determined that the paragraph is part of the POD documentation from one -of the selected sections, then B<preprocess_paragraph()> is invoked. - -The base class implementation of this method returns the given text. - -=cut - -sub preprocess_line { - my ($self, $text, $line_num) = @_; - return $text; -} - -##--------------------------------------------------------------------------- - -=head1 B<preprocess_paragraph()> - - $textblock = $parser->preprocess_paragraph($text, $line_num); - -This method should be overridden by subclasses that wish to perform any -kind of preprocessing for each block (paragraph) of POD documentation -that appears in the input stream. The parameter C<$text> is the POD -paragraph from the input file; and the parameter C<$line_num> is the -line number for the beginning of the corresponding paragraph. - -The value returned should correspond to the new text to use in its -place If the empty string is returned or an undefined value is -returned, then the given C<$text> is ignored (not processed). - -This method is invoked after gathering up all the lines in a paragraph -and after determining the cutting state of the paragraph, -but before trying to further parse or interpret them. After -B<preprocess_paragraph()> returns, the current cutting state (which -is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates -to true then input text (including the given C<$text>) is cut (not -processed) until the next POD directive is encountered. - -Please note that the B<preprocess_line()> method is invoked I<before> -the B<preprocess_paragraph()> method. After all (possibly preprocessed) -lines in a paragraph have been assembled together and either it has been -determined that the paragraph is part of the POD documentation from one -of the selected sections or the C<-want_nonPODs> option is true, -then B<preprocess_paragraph()> is invoked. - -The base class implementation of this method returns the given text. - -=cut - -sub preprocess_paragraph { - my ($self, $text, $line_num) = @_; - return $text; -} - -############################################################################# - -=head1 METHODS FOR PARSING AND PROCESSING - -B<Pod::Parser> provides several methods to process input text. These -methods typically won't need to be overridden (and in some cases they -can't be overridden), but subclasses may want to invoke them to exploit -their functionality. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<parse_text()> - - $ptree1 = $parser->parse_text($text, $line_num); - $ptree2 = $parser->parse_text({%opts}, $text, $line_num); - $ptree3 = $parser->parse_text(\%opts, $text, $line_num); - -This method is useful if you need to perform your own interpolation -of interior sequences and can't rely upon B<interpolate> to expand -them in simple bottom-up order. - -The parameter C<$text> is a string or block of text to be parsed -for interior sequences; and the parameter C<$line_num> is the -line number corresponding to the beginning of C<$text>. - -B<parse_text()> will parse the given text into a parse-tree of "nodes." -and interior-sequences. Each "node" in the parse tree is either a -text-string, or a B<Pod::InteriorSequence>. The result returned is a -parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects> -for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>. - -If desired, an optional hash-ref may be specified as the first argument -to customize certain aspects of the parse-tree that is created and -returned. The set of recognized option keywords are: - -=over 3 - -=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name> - -Normally, the parse-tree returned by B<parse_text()> will contain an -unexpanded C<Pod::InteriorSequence> object for each interior-sequence -encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand" -every interior-sequence it sees by invoking the referenced function -(or named method of the parser object) and using the return value as the -expanded result. - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $sequence ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $sequence ) - -where C<$parser> is a reference to the parser object, and C<$sequence> -is a reference to the interior-sequence object. -[I<NOTE>: If the B<interior_sequence()> method is specified, then it is -invoked according to the interface specified in L<"interior_sequence()">]. - -=item B<-expand_text> =E<gt> I<code-ref>|I<method-name> - -Normally, the parse-tree returned by B<parse_text()> will contain a -text-string for each contiguous sequence of characters outside of an -interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to -"preprocess" every such text-string it sees by invoking the referenced -function (or named method of the parser object) and using the return value -as the preprocessed (or "expanded") result. [Note that if the result is -an interior-sequence, then it will I<not> be expanded as specified by the -B<-expand_seq> option; Any such recursive expansion needs to be handled by -the specified callback routine.] - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $text, $ptree_node ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $text, $ptree_node ) - -where C<$parser> is a reference to the parser object, C<$text> is the -text-string encountered, and C<$ptree_node> is a reference to the current -node in the parse-tree (usually an interior-sequence object or else the -top-level node of the parse-tree). - -=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name> - -Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an -argument to the referenced subroutine (or named method of the parser -object) and return the result instead of the parse-tree object. - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $ptree ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $ptree ) - -where C<$parser> is a reference to the parser object, and C<$ptree> -is a reference to the parse-tree object. - -=back - -=cut - -sub parse_text { - my $self = shift; - local $_ = ''; - - ## Get options and set any defaults - my %opts = (ref $_[0]) ? %{ shift() } : (); - my $expand_seq = $opts{'-expand_seq'} || undef; - my $expand_text = $opts{'-expand_text'} || undef; - my $expand_ptree = $opts{'-expand_ptree'} || undef; - - my $text = shift; - my $line = shift; - my $file = $self->input_file(); - my $cmd = ""; - - ## Convert method calls into closures, for our convenience - my $xseq_sub = $expand_seq; - my $xtext_sub = $expand_text; - my $xptree_sub = $expand_ptree; - if (defined $expand_seq and $expand_seq eq 'interior_sequence') { - ## If 'interior_sequence' is the method to use, we have to pass - ## more than just the sequence object, we also need to pass the - ## sequence name and text. - $xseq_sub = sub { - my ($sself, $iseq) = @_; - my $args = join('', $iseq->parse_tree->children); - return $sself->interior_sequence($iseq->name, $args, $iseq); - }; - } - ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) }; - ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) }; - ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) }; - - ## Keep track of the "current" interior sequence, and maintain a stack - ## of "in progress" sequences. - ## - ## NOTE that we push our own "accumulator" at the very beginning of the - ## stack. It's really a parse-tree, not a sequence; but it implements - ## the methods we need so we can use it to gather-up all the sequences - ## and strings we parse. Thus, by the end of our parsing, it should be - ## the only thing left on our stack and all we have to do is return it! - ## - my $seq = Pod::ParseTree->new(); - my @seq_stack = ($seq); - my ($ldelim, $rdelim) = ('', ''); - - ## Iterate over all sequence starts text (NOTE: split with - ## capturing parens keeps the delimiters) - $_ = $text; - my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/; - while ( @tokens ) { - $_ = shift @tokens; - ## Look for the beginning of a sequence - 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); - ($ldelim = $ldelim_orig) =~ s/\s+$//; - ($rdelim = $ldelim) =~ tr/</>/; - $seq = Pod::InteriorSequence->new( - -name => $cmd, - -ldelim => $ldelim_orig, -rdelim => $rdelim, - -file => $file, -line => $line - ); - (@seq_stack > 1) and $seq->nested($seq_stack[-1]); - push @seq_stack, $seq; - } - ## Look for sequence ending - elsif ( @seq_stack > 1 ) { - ## Make sure we match the right kind of closing delimiter - my ($seq_end, $post_seq) = ('', ''); - if ( ($ldelim eq '<' and /\A(.*?)(>)/s) - or /\A(.*?)(\s+$rdelim)/s ) - { - ## Found end-of-sequence, capture the interior and the - ## closing the delimiter, and put the rest back on the - ## token-list - $post_seq = substr($_, length($1) + length($2)); - ($_, $seq_end) = ($1, $2); - (length $post_seq) and unshift @tokens, $post_seq; - } - if (length) { - ## In the middle of a sequence, append this text to it, and - ## don't forget to "expand" it if that's what the caller wanted - $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); - $_ .= $seq_end; - } - if (length $seq_end) { - ## End of current sequence, record terminating delimiter - $seq->rdelim($seq_end); - ## Pop it off the stack of "in progress" sequences - pop @seq_stack; - ## Append result to its parent in current parse tree - $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) - : $seq); - ## Remember the current cmd-name and left-delimiter - if(@seq_stack > 1) { - $cmd = $seq_stack[-1]->name; - $ldelim = $seq_stack[-1]->ldelim; - $rdelim = $seq_stack[-1]->rdelim; - } else { - $cmd = $ldelim = $rdelim = ''; - } - } - } - elsif (length) { - ## In the middle of a sequence, append this text to it, and - ## don't forget to "expand" it if that's what the caller wanted - $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); - } - ## Keep track of line count - $line += /\n/; - ## Remember the "current" sequence - $seq = $seq_stack[-1]; - } - - ## Handle unterminated sequences - my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef; - while (@seq_stack > 1) { - ($cmd, $file, $line) = ($seq->name, $seq->file_line); - $ldelim = $seq->ldelim; - ($rdelim = $ldelim) =~ tr/</>/; - $rdelim =~ s/^(\S+)(\s*)$/$2$1/; - pop @seq_stack; - my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}". - " at line $line in file $file\n"; - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $self->$errorsub($errmsg) - or carp($errmsg); - $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); - $seq = $seq_stack[-1]; - } - - ## Return the resulting parse-tree - my $ptree = (pop @seq_stack)->parse_tree; - return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree; -} - -##--------------------------------------------------------------------------- - -=head1 B<interpolate()> - - $textblock = $parser->interpolate($text, $line_num); - -This method translates all text (including any embedded interior sequences) -in the given text string C<$text> and returns the interpolated result. The -parameter C<$line_num> is the line number corresponding to the beginning -of C<$text>. - -B<interpolate()> merely invokes a private method to recursively expand -nested interior sequences in bottom-up order (innermost sequences are -expanded first). If there is a need to expand nested sequences in -some alternate order, use B<parse_text> instead. - -=cut - -sub interpolate { - my($self, $text, $line_num) = @_; - my %parse_opts = ( -expand_seq => 'interior_sequence' ); - my $ptree = $self->parse_text( \%parse_opts, $text, $line_num ); - return join '', $ptree->children(); -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B<parse_paragraph()> - - $parser->parse_paragraph($text, $line_num); - -This method takes the text of a POD paragraph to be processed, along -with its corresponding line number, and invokes the appropriate method -(one of B<command()>, B<verbatim()>, or B<textblock()>). - -For performance reasons, this method is invoked directly without any -dynamic lookup; Hence subclasses may I<not> override it! - -=end __PRIVATE__ - -=cut - -sub parse_paragraph { - my ($self, $text, $line_num) = @_; - local *myData = $self; ## alias to avoid deref-ing overhead - local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options - local $_; - - ## See if we want to preprocess nonPOD paragraphs as well as POD ones. - my $wantNonPods = $myOpts{'-want_nonPODs'}; - - ## Update cutting status - $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/; - - ## Perform any desired preprocessing if we wanted it this early - $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num); - - ## Ignore up until next POD directive if we are cutting - return if $myData{_CUTTING}; - - ## Now we know this is block of text in a POD section! - - ##----------------------------------------------------------------- - ## This is a hook (hack ;-) for Pod::Select to do its thing without - ## having to override methods, but also without Pod::Parser assuming - ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS - ## field exists then we assume there is an is_selected() method for - ## us to invoke (calling $self->can('is_selected') could verify this - ## but that is more overhead than I want to incur) - ##----------------------------------------------------------------- - - ## Ignore this block if it isn't in one of the selected sections - if (exists $myData{_SELECTED_SECTIONS}) { - $self->is_selected($text) or return ($myData{_CUTTING} = 1); - } - - ## If we haven't already, perform any desired preprocessing and - ## then re-check the "cutting" state - unless ($wantNonPods) { - $text = $self->preprocess_paragraph($text, $line_num); - return 1 unless ((defined $text) and (length $text)); - return 1 if ($myData{_CUTTING}); - } - - ## Look for one of the three types of paragraphs - my ($pfx, $cmd, $arg, $sep) = ('', '', '', ''); - my $pod_para = undef; - if ($text =~ /^(={1,2})(?=\S)/) { - ## Looks like a command paragraph. Capture the command prefix used - ## ("=" or "=="), as well as the command-name, its paragraph text, - ## and whatever sequence of characters was used to separate them - $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 don't need to do anything - ## except return to "cutting" mode. - if ($cmd eq 'cut') { - $myData{_CUTTING} = 1; - return unless $myOpts{'-process_cut_cmd'}; - } - } - ## Save the attributes indicating how the command was specified. - $pod_para = new Pod::Paragraph( - -name => $cmd, - -text => $text, - -prefix => $pfx, - -separator => $sep, - -file => $myData{_INFILE}, - -line => $line_num - ); - # ## Invoke appropriate callbacks - # if (exists $myData{_CALLBACKS}) { - # ## Look through the callback list, invoke callbacks, - # ## then see if we need to do the default actions - # ## (invoke_callbacks will return true if we do). - # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para); - # } - - # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp - if ($myData{_WHITESPACE} and $myOpts{'-warnings'} - and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) { - my $errorsub = $self->errorsub(); - my $line = $line_num - 1; - my $errmsg = "*** WARNING: line containing nothing but whitespace". - " in paragraph at line $line in file $myData{_INFILE}\n"; - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $self->$errorsub($errmsg) - or carp($errmsg); - } - - if (length $cmd) { - ## A command paragraph - $self->command($cmd, $text, $line_num, $pod_para); - $myData{_PREVIOUS} = $cmd; - } - elsif ($text =~ /^\s+/) { - ## Indented text - must be a verbatim paragraph - $self->verbatim($text, $line_num, $pod_para); - $myData{_PREVIOUS} = "verbatim"; - } - else { - ## Looks like an ordinary block of text - $self->textblock($text, $line_num, $pod_para); - $myData{_PREVIOUS} = "textblock"; - } - - # Update the whitespace for the next time around - #$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0; - $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0; - - return 1; -} - -##--------------------------------------------------------------------------- - -=head1 B<parse_from_filehandle()> - - $parser->parse_from_filehandle($in_fh,$out_fh); - -This method takes an input filehandle (which is assumed to already be -opened for reading) and reads the entire input stream looking for blocks -(paragraphs) of POD documentation to be processed. If no first argument -is given the default input filehandle C<STDIN> is used. - -The C<$in_fh> parameter may be any object that provides a B<getline()> -method to retrieve a single line of input text (hence, an appropriate -wrapper object could be used to parse PODs from a single string or an -array of strings). - -Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled -into paragraphs or "blocks" (which are separated by lines containing -nothing but whitespace). For each block of POD documentation -encountered it will invoke a method to parse the given paragraph. - -If a second argument is given then it should correspond to a filehandle where -output should be sent (otherwise the default output filehandle is -C<STDOUT> if no output filehandle is currently in use). - -B<NOTE:> For performance reasons, this method caches the input stream at -the top of the stack in a local variable. Any attempts by clients to -change the stack contents during processing when in the midst executing -of this method I<will not affect> the input stream used by the current -invocation of this method. - -This method does I<not> usually need to be overridden by subclasses. - -=cut - -sub parse_from_filehandle { - my $self = shift; - my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); - my ($in_fh, $out_fh) = @_; - $in_fh = \*STDIN unless ($in_fh); - local *myData = $self; ## alias to avoid deref-ing overhead - local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options - local $_; - - ## Put this stream at the top of the stack and do beginning-of-input - ## processing. NOTE that $in_fh might be reset during this process. - my $topstream = $self->_push_input_stream($in_fh, $out_fh); - (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} ); - - ## Initialize line/paragraph - my ($textline, $paragraph) = ('', ''); - my ($nlines, $plines) = (0, 0); - - ## Use <$fh> instead of $fh->getline where possible (for speed) - $_ = ref $in_fh; - my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh); - - ## Read paragraphs line-by-line - while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) { - $textline = $self->preprocess_line($textline, ++$nlines); - next unless ((defined $textline) && (length $textline)); - - if ((! length $paragraph) && ($textline =~ /^==/)) { - ## '==' denotes a one-line command paragraph - $paragraph = $textline; - $plines = 1; - $textline = ''; - } else { - ## Append this line to the current paragraph - $paragraph .= $textline; - ++$plines; - } - - ## See if this line is blank and ends the current paragraph. - ## If it isn't, then keep iterating until it is. - next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/) - && (length $paragraph)); - - ## Now process the paragraph - parse_paragraph($self, $paragraph, ($nlines - $plines) + 1); - $paragraph = ''; - $plines = 0; - } - ## Don't forget about the last paragraph in the file - if (length $paragraph) { - parse_paragraph($self, $paragraph, ($nlines - $plines) + 1) - } - - ## Now pop the input stream off the top of the input stack. - $self->_pop_input_stream(); -} - -##--------------------------------------------------------------------------- - -=head1 B<parse_from_file()> - - $parser->parse_from_file($filename,$outfile); - -This method takes a filename and does the following: - -=over 2 - -=item * - -opens the input and output files for reading -(creating the appropriate filehandles) - -=item * - -invokes the B<parse_from_filehandle()> method passing it the -corresponding input and output filehandles. - -=item * - -closes the input and output files. - -=back - -If the special input filename "", "-" or "<&STDIN" is given then the STDIN -filehandle is used for input (and no open or close is performed). If no -input filename is specified then "-" is implied. Filehandle references, -or objects that support the regular IO operations (like C<E<lt>$fhE<gt>> -or C<$fh-<Egt>getline>) are also accepted; the handles must already be -opened. - -If a second argument is given then it should be the name of the desired -output file. If the special output filename "-" or ">&STDOUT" is given -then the STDOUT filehandle is used for output (and no open or close is -performed). If the special output filename ">&STDERR" is given then the -STDERR filehandle is used for output (and no open or close is -performed). If no output filehandle is currently in use and no output -filename is specified, then "-" is implied. -Alternatively, filehandle references or objects that support the regular -IO operations (like C<print>, e.g. L<IO::String>) are also accepted; -the object must already be opened. - -This method does I<not> usually need to be overridden by subclasses. - -=cut - -sub parse_from_file { - my $self = shift; - my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); - my ($infile, $outfile) = @_; - my ($in_fh, $out_fh); - if ($] < 5.006) { - ($in_fh, $out_fh) = (gensym(), gensym()); - } - my ($close_input, $close_output) = (0, 0); - local *myData = $self; - local *_; - - ## Is $infile a filename or a (possibly implied) filehandle - if (defined $infile && ref $infile) { - if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) { - croak "Input from $1 reference not supported!\n"; - } - ## Must be a filehandle-ref (or else assume its a ref to an object - ## that supports the common IO read operations). - $myData{_INFILE} = ${$infile}; - $in_fh = $infile; - } - elsif (!defined($infile) || !length($infile) || ($infile eq '-') - || ($infile =~ /^<&(?:STDIN|0)$/i)) - { - ## Not a filename, just a string implying STDIN - $infile ||= '-'; - $myData{_INFILE} = '<standard input>'; - $in_fh = \*STDIN; - } - else { - ## We have a filename, open it for reading - $myData{_INFILE} = $infile; - open($in_fh, "< $infile") or - croak "Can't open $infile for reading: $!\n"; - $close_input = 1; - } - - ## NOTE: we need to be *very* careful when "defaulting" the output - ## file. We only want to use a default if this is the beginning of - ## the entire document (but *not* if this is an included file). We - ## determine this by seeing if the input stream stack has been set-up - ## already - - ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref? - if (ref $outfile) { - ## we need to check for ref() first, as other checks involve reading - if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) { - croak "Output to $1 reference not supported!\n"; - } - elsif (ref($outfile) eq 'SCALAR') { -# # NOTE: IO::String isn't a part of the perl distribution, -# # so probably we shouldn't support this case... -# require IO::String; -# $myData{_OUTFILE} = "$outfile"; -# $out_fh = IO::String->new($outfile); - croak "Output to SCALAR reference not supported!\n"; - } - else { - ## Must be a filehandle-ref (or else assume its a ref to an - ## object that supports the common IO write operations). - $myData{_OUTFILE} = ${$outfile}; - $out_fh = $outfile; - } - } - elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-') - || ($outfile =~ /^>&?(?:STDOUT|1)$/i)) - { - if (defined $myData{_TOP_STREAM}) { - $out_fh = $myData{_OUTPUT}; - } - else { - ## Not a filename, just a string implying STDOUT - $outfile ||= '-'; - $myData{_OUTFILE} = '<standard output>'; - $out_fh = \*STDOUT; - } - } - elsif ($outfile =~ /^>&(STDERR|2)$/i) { - ## Not a filename, just a string implying STDERR - $myData{_OUTFILE} = '<standard error>'; - $out_fh = \*STDERR; - } - else { - ## We have a filename, open it for writing - $myData{_OUTFILE} = $outfile; - (-d $outfile) and croak "$outfile is a directory, not POD input!\n"; - open($out_fh, "> $outfile") or - croak "Can't open $outfile for writing: $!\n"; - $close_output = 1; - } - - ## Whew! That was a lot of work to set up reasonably/robust behavior - ## in the case of a non-filename for reading and writing. Now we just - ## have to parse the input and close the handles when we're finished. - $self->parse_from_filehandle(\%opts, $in_fh, $out_fh); - - $close_input and - close($in_fh) || croak "Can't close $infile after reading: $!\n"; - $close_output and - close($out_fh) || croak "Can't close $outfile after writing: $!\n"; -} - -############################################################################# - -=head1 ACCESSOR METHODS - -Clients of B<Pod::Parser> should use the following methods to access -instance data fields: - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<errorsub()> - - $parser->errorsub("method_name"); - $parser->errorsub(\&warn_user); - $parser->errorsub(sub { print STDERR, @_ }); - -Specifies the method or subroutine to use when printing error messages -about POD syntax. The supplied method/subroutine I<must> return TRUE upon -successful printing of the message. If C<undef> is given, then the B<carp> -builtin is used to issue error messages (this is the default behavior). - - my $errorsub = $parser->errorsub() - my $errmsg = "This is an error message!\n" - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $parser->$errorsub($errmsg) - or carp($errmsg); - -Returns a method name, or else a reference to the user-supplied subroutine -used to print error messages. Returns C<undef> if the B<carp> builtin -is used to issue error messages (this is the default behavior). - -=cut - -sub errorsub { - return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB}; -} - -##--------------------------------------------------------------------------- - -=head1 B<cutting()> - - $boolean = $parser->cutting(); - -Returns the current C<cutting> state: a boolean-valued scalar which -evaluates to true if text from the input file is currently being "cut" -(meaning it is I<not> considered part of the POD document). - - $parser->cutting($boolean); - -Sets the current C<cutting> state to the given value and returns the -result. - -=cut - -sub cutting { - return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING}; -} - -##--------------------------------------------------------------------------- - -##--------------------------------------------------------------------------- - -=head1 B<parseopts()> - -When invoked with no additional arguments, B<parseopts> returns a hashtable -of all the current parsing options. - - ## See if we are parsing non-POD sections as well as POD ones - my %opts = $parser->parseopts(); - $opts{'-want_nonPODs}' and print "-want_nonPODs\n"; - -When invoked using a single string, B<parseopts> treats the string as the -name of a parse-option and returns its corresponding value if it exists -(returns C<undef> if it doesn't). - - ## Did we ask to see '=cut' paragraphs? - my $want_cut = $parser->parseopts('-process_cut_cmd'); - $want_cut and print "-process_cut_cmd\n"; - -When invoked with multiple arguments, B<parseopts> treats them as -key/value pairs and the specified parse-option names are set to the -given values. Any unspecified parse-options are unaffected. - - ## Set them back to the default - $parser->parseopts(-warnings => 0); - -When passed a single hash-ref, B<parseopts> uses that hash to completely -reset the existing parse-options, all previous parse-option values -are lost. - - ## Reset all options to default - $parser->parseopts( { } ); - -See L<"PARSING OPTIONS"> for more information on the name and meaning of each -parse-option currently recognized. - -=cut - -sub parseopts { - local *myData = shift; - local *myOpts = ($myData{_PARSEOPTS} ||= {}); - return %myOpts if (@_ == 0); - if (@_ == 1) { - local $_ = shift; - return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_}; - } - my @newOpts = (%myOpts, @_); - $myData{_PARSEOPTS} = { @newOpts }; -} - -##--------------------------------------------------------------------------- - -=head1 B<output_file()> - - $fname = $parser->output_file(); - -Returns the name of the output file being written. - -=cut - -sub output_file { - return $_[0]->{_OUTFILE}; -} - -##--------------------------------------------------------------------------- - -=head1 B<output_handle()> - - $fhandle = $parser->output_handle(); - -Returns the output filehandle object. - -=cut - -sub output_handle { - return $_[0]->{_OUTPUT}; -} - -##--------------------------------------------------------------------------- - -=head1 B<input_file()> - - $fname = $parser->input_file(); - -Returns the name of the input file being read. - -=cut - -sub input_file { - return $_[0]->{_INFILE}; -} - -##--------------------------------------------------------------------------- - -=head1 B<input_handle()> - - $fhandle = $parser->input_handle(); - -Returns the current input filehandle object. - -=cut - -sub input_handle { - return $_[0]->{_INPUT}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B<input_streams()> - - $listref = $parser->input_streams(); - -Returns a reference to an array which corresponds to the stack of all -the input streams that are currently in the middle of being parsed. - -While parsing an input stream, it is possible to invoke -B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input -stream and then return to parsing the previous input stream. Each input -stream to be parsed is pushed onto the end of this input stack -before any of its input is read. The input stream that is currently -being parsed is always at the end (or top) of the input stack. When an -input stream has been exhausted, it is popped off the end of the -input stack. - -Each element on this input stack is a reference to C<Pod::InputSource> -object. Please see L<Pod::InputObjects> for more details. - -This method might be invoked when printing diagnostic messages, for example, -to obtain the name and line number of the all input files that are currently -being processed. - -=end __PRIVATE__ - -=cut - -sub input_streams { - return $_[0]->{_INPUT_STREAMS}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B<top_stream()> - - $hashref = $parser->top_stream(); - -Returns a reference to the hash-table that represents the element -that is currently at the top (end) of the input stream stack -(see L<"input_streams()">). The return value will be the C<undef> -if the input stack is empty. - -This method might be used when printing diagnostic messages, for example, -to obtain the name and line number of the current input file. - -=end __PRIVATE__ - -=cut - -sub top_stream { - return $_[0]->{_TOP_STREAM} || undef; -} - -############################################################################# - -=head1 PRIVATE METHODS AND DATA - -B<Pod::Parser> makes use of several internal methods and data fields -which clients should not need to see or use. For the sake of avoiding -name collisions for client data and methods, these methods and fields -are briefly discussed here. Determined hackers may obtain further -information about them by reading the B<Pod::Parser> source code. - -Private data fields are stored in the hash-object whose reference is -returned by the B<new()> constructor for this class. The names of all -private methods and data-fields used by B<Pod::Parser> begin with a -prefix of "_" and match the regular expression C</^_\w+$/>. - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_push_input_stream()> - - $hashref = $parser->_push_input_stream($in_fh,$out_fh); - -This method will push the given input stream on the input stack and -perform any necessary beginning-of-document or beginning-of-file -processing. The argument C<$in_fh> is the input stream filehandle to -push, and C<$out_fh> is the corresponding output filehandle to use (if -it is not given or is undefined, then the current output stream is used, -which defaults to standard output if it doesnt exist yet). - -The value returned will be reference to the hash-table that represents -the new top of the input stream stack. I<Please Note> that it is -possible for this method to use default values for the input and output -file handles. If this happens, you will need to look at the C<INPUT> -and C<OUTPUT> instance data members to determine their new values. - -=end _PRIVATE_ - -=cut - -sub _push_input_stream { - my ($self, $in_fh, $out_fh) = @_; - local *myData = $self; - - ## Initialize stuff for the entire document if this is *not* - ## an included file. - ## - ## NOTE: we need to be *very* careful when "defaulting" the output - ## filehandle. We only want to use a default value if this is the - ## beginning of the entire document (but *not* if this is an included - ## file). - unless (defined $myData{_TOP_STREAM}) { - $out_fh = \*STDOUT unless (defined $out_fh); - $myData{_CUTTING} = 1; ## current "cutting" state - $myData{_INPUT_STREAMS} = []; ## stack of all input streams - } - - ## Initialize input indicators - $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE}); - $myData{_OUTPUT} = $out_fh if (defined $out_fh); - $in_fh = \*STDIN unless (defined $in_fh); - $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE}); - $myData{_INPUT} = $in_fh; - my $input_top = $myData{_TOP_STREAM} - = new Pod::InputSource( - -name => $myData{_INFILE}, - -handle => $in_fh, - -was_cutting => $myData{_CUTTING} - ); - local *input_stack = $myData{_INPUT_STREAMS}; - push(@input_stack, $input_top); - - ## Perform beginning-of-document and/or beginning-of-input processing - $self->begin_pod() if (@input_stack == 1); - $self->begin_input(); - - return $input_top; -} - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_pop_input_stream()> - - $hashref = $parser->_pop_input_stream(); - -This takes no arguments. It will perform any necessary end-of-file or -end-of-document processing and then pop the current input stream from -the top of the input stack. - -The value returned will be reference to the hash-table that represents -the new top of the input stream stack. - -=end _PRIVATE_ - -=cut - -sub _pop_input_stream { - my ($self) = @_; - local *myData = $self; - local *input_stack = $myData{_INPUT_STREAMS}; - - ## Perform end-of-input and/or end-of-document processing - $self->end_input() if (@input_stack > 0); - $self->end_pod() if (@input_stack == 1); - - ## Restore cutting state to whatever it was before we started - ## parsing this file. - my $old_top = pop(@input_stack); - $myData{_CUTTING} = $old_top->was_cutting(); - - ## Don't forget to reset the input indicators - my $input_top = undef; - if (@input_stack > 0) { - $input_top = $myData{_TOP_STREAM} = $input_stack[-1]; - $myData{_INFILE} = $input_top->name(); - $myData{_INPUT} = $input_top->handle(); - } else { - delete $myData{_TOP_STREAM}; - delete $myData{_INPUT_STREAMS}; - } - - return $input_top; -} - -############################################################################# - -=head1 TREE-BASED PARSING - -If straightforward stream-based parsing wont meet your needs (as is -likely the case for tasks such as translating PODs into structured -markup languages like HTML and XML) then you may need to take the -tree-based approach. Rather than doing everything in one pass and -calling the B<interpolate()> method to expand sequences into text, it -may be desirable to instead create a parse-tree using the B<parse_text()> -method to return a tree-like structure which may contain an ordered -list of children (each of which may be a text-string, or a similar -tree-like structure). - -Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and -to the objects described in L<Pod::InputObjects>. The former describes -the gory details and parameters for how to customize and extend the -parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides -several objects that may all be used interchangeably as parse-trees. The -most obvious one is the B<Pod::ParseTree> object. It defines the basic -interface and functionality that all things trying to be a POD parse-tree -should do. A B<Pod::ParseTree> is defined such that each "node" may be a -text-string, or a reference to another parse-tree. Each B<Pod::Paragraph> -object and each B<Pod::InteriorSequence> object also supports the basic -parse-tree interface. - -The B<parse_text()> method takes a given paragraph of text, and -returns a parse-tree that contains one or more children, each of which -may be a text-string, or an InteriorSequence object. There are also -callback-options that may be passed to B<parse_text()> to customize -the way it expands or transforms interior-sequences, as well as the -returned result. These callbacks can be used to create a parse-tree -with custom-made objects (which may or may not support the parse-tree -interface, depending on how you choose to do it). - -If you wish to turn an entire POD document into a parse-tree, that process -is fairly straightforward. The B<parse_text()> method is the key to doing -this successfully. Every paragraph-callback (i.e. the polymorphic methods -for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes -a B<Pod::Paragraph> object as an argument. Each paragraph object has a -B<parse_tree()> method that can be used to get or set a corresponding -parse-tree. So for each of those paragraph-callback methods, simply call -B<parse_text()> with the options you desire, and then use the returned -parse-tree to assign to the given paragraph object. - -That gives you a parse-tree for each paragraph - so now all you need is -an ordered list of paragraphs. You can maintain that yourself as a data -element in the object/hash. The most straightforward way would be simply -to use an array-ref, with the desired set of custom "options" for each -invocation of B<parse_text>. Let's assume the desired option-set is -given by the hash C<%options>. Then we might do something like the -following: - - package MyPodParserTree; - - @ISA = qw( Pod::Parser ); - - ... - - sub begin_pod { - my $self = shift; - $self->{'-paragraphs'} = []; ## initialize paragraph list - } - - sub command { - my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({%options}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - sub verbatim { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - sub textblock { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({%options}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - ... - - package main; - ... - my $parser = new MyPodParserTree(...); - $parser->parse_from_file(...); - my $paragraphs_ref = $parser->{'-paragraphs'}; - -Of course, in this module-author's humble opinion, I'd be more inclined to -use the existing B<Pod::ParseTree> object than a simple array. That way -everything in it, paragraphs and sequences, all respond to the same core -interface for all parse-tree nodes. The result would look something like: - - package MyPodParserTree2; - - ... - - sub begin_pod { - my $self = shift; - $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree - } - - sub parse_tree { - ## convenience method to get/set the parse-tree for the entire POD - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; - } - - sub command { - my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - $parser->parse_tree()->append( $pod_para ); - } - - sub verbatim { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - $parser->parse_tree()->append( $pod_para ); - } - - sub textblock { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - $parser->parse_tree()->append( $pod_para ); - } - - ... - - package main; - ... - my $parser = new MyPodParserTree2(...); - $parser->parse_from_file(...); - my $ptree = $parser->parse_tree; - ... - -Now you have the entire POD document as one great big parse-tree. You -can even use the B<-expand_seq> option to B<parse_text> to insert -whole different kinds of objects. Just don't expect B<Pod::Parser> -to know what to do with them after that. That will need to be in your -code. Or, alternatively, you can insert any object you like so long as -it conforms to the B<Pod::ParseTree> interface. - -One could use this to create subclasses of B<Pod::Paragraphs> and -B<Pod::InteriorSequences> for specific commands (or to create your own -custom node-types in the parse-tree) and add some kind of B<emit()> -method to each custom node/subclass object in the tree. Then all you'd -need to do is recursively walk the tree in the desired order, processing -the children (most likely from left to right) by formatting them if -they are text-strings, or by calling their B<emit()> method if they -are objects/references. - -=head1 CAVEATS - -Please note that POD has the notion of "paragraphs": this is something -starting I<after> a blank (read: empty) line, with the single exception -of the file start, which is also starting a paragraph. That means that -especially a command (e.g. C<=head1>) I<must> be preceded with a blank -line; C<__END__> is I<not> a blank line. - -=head1 SEE ALSO - -L<Pod::InputObjects>, L<Pod::Select> - -B<Pod::InputObjects> defines POD input objects corresponding to -command paragraphs, parse-trees, and interior-sequences. - -B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability -to selectively include and/or exclude sections of a POD document from being -translated based upon the current heading, subheading, subsubheading, etc. - -=for __PRIVATE__ -B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users -the ability the employ I<callback functions> instead of, or in addition -to, overriding methods of the base class. - -=for __PRIVATE__ -B<Pod::Select> and B<Pod::Callbacks> do not override any -methods nor do they define any new methods with the same name. Because -of this, they may I<both> be used (in combination) as a base class of -the same subclass in order to combine their functionality without -causing any namespace clashes due to multiple inheritance. - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Brad Appleton E<lt>bradapp@enteract.comE<gt> - -Based on code for B<Pod::Text> written by -Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> - -=head1 LICENSE - -Pod-Parser is free software; you can redistribute it and/or modify it -under the terms of the Artistic License distributed with Perl version -5.000 or (at your option) any later version. Please refer to the -Artistic License that came with your Perl distribution for more -details. If your version of Perl was not distributed under the -terms of the Artistic License, than you may distribute PodParser -under the same terms as Perl itself. - -=cut - -1; -# vim: ts=4 sw=4 et diff --git a/Master/tlpkg/tlperl/lib/Pod/PlainText.pm b/Master/tlpkg/tlperl/lib/Pod/PlainText.pm deleted file mode 100644 index 3db4d903cd6..00000000000 --- a/Master/tlpkg/tlperl/lib/Pod/PlainText.pm +++ /dev/null @@ -1,748 +0,0 @@ -# Pod::PlainText -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $ -# -# Copyright 1999-2000 by Russ Allbery <rra@stanford.edu> -# -# This program is free software; you can redistribute it and/or modify it -# under the same terms as Perl itself. -# -# This module is intended to be a replacement for Pod::Text, and attempts to -# match its output except for some specific circumstances where other -# decisions seemed to produce better output. It uses Pod::Parser and is -# designed to be very easy to subclass. - -############################################################################ -# Modules and declarations -############################################################################ - -package Pod::PlainText; -use strict; - -require 5.005; - -use Carp qw(carp croak); -use Pod::Select (); - -use vars qw(@ISA %ESCAPES $VERSION); - -# We inherit from Pod::Select instead of Pod::Parser so that we can be used -# by Pod::Usage. -@ISA = qw(Pod::Select); - -$VERSION = '2.07'; - -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} - -############################################################################ -# Table of supported E<> escapes -############################################################################ - -# This table is taken near verbatim from Pod::PlainText in Pod::Parser, -# which got it near verbatim from the original Pod::Text. It is therefore -# credited to Tom Christiansen, and I'm glad I didn't have to write it. :) -%ESCAPES = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "\xC1", # capital A, acute accent - "aacute" => "\xE1", # small a, acute accent - "Acirc" => "\xC2", # capital A, circumflex accent - "acirc" => "\xE2", # small a, circumflex accent - "AElig" => "\xC6", # capital AE diphthong (ligature) - "aelig" => "\xE6", # small ae diphthong (ligature) - "Agrave" => "\xC0", # capital A, grave accent - "agrave" => "\xE0", # small a, grave accent - "Aring" => "\xC5", # capital A, ring - "aring" => "\xE5", # small a, ring - "Atilde" => "\xC3", # capital A, tilde - "atilde" => "\xE3", # small a, tilde - "Auml" => "\xC4", # capital A, dieresis or umlaut mark - "auml" => "\xE4", # small a, dieresis or umlaut mark - "Ccedil" => "\xC7", # capital C, cedilla - "ccedil" => "\xE7", # small c, cedilla - "Eacute" => "\xC9", # capital E, acute accent - "eacute" => "\xE9", # small e, acute accent - "Ecirc" => "\xCA", # capital E, circumflex accent - "ecirc" => "\xEA", # small e, circumflex accent - "Egrave" => "\xC8", # capital E, grave accent - "egrave" => "\xE8", # small e, grave accent - "ETH" => "\xD0", # capital Eth, Icelandic - "eth" => "\xF0", # small eth, Icelandic - "Euml" => "\xCB", # capital E, dieresis or umlaut mark - "euml" => "\xEB", # small e, dieresis or umlaut mark - "Iacute" => "\xCD", # capital I, acute accent - "iacute" => "\xED", # small i, acute accent - "Icirc" => "\xCE", # capital I, circumflex accent - "icirc" => "\xEE", # small i, circumflex accent - "Igrave" => "\xCD", # capital I, grave accent - "igrave" => "\xED", # small i, grave accent - "Iuml" => "\xCF", # capital I, dieresis or umlaut mark - "iuml" => "\xEF", # small i, dieresis or umlaut mark - "Ntilde" => "\xD1", # capital N, tilde - "ntilde" => "\xF1", # small n, tilde - "Oacute" => "\xD3", # capital O, acute accent - "oacute" => "\xF3", # small o, acute accent - "Ocirc" => "\xD4", # capital O, circumflex accent - "ocirc" => "\xF4", # small o, circumflex accent - "Ograve" => "\xD2", # capital O, grave accent - "ograve" => "\xF2", # small o, grave accent - "Oslash" => "\xD8", # capital O, slash - "oslash" => "\xF8", # small o, slash - "Otilde" => "\xD5", # capital O, tilde - "otilde" => "\xF5", # small o, tilde - "Ouml" => "\xD6", # capital O, dieresis or umlaut mark - "ouml" => "\xF6", # small o, dieresis or umlaut mark - "szlig" => "\xDF", # small sharp s, German (sz ligature) - "THORN" => "\xDE", # capital THORN, Icelandic - "thorn" => "\xFE", # small thorn, Icelandic - "Uacute" => "\xDA", # capital U, acute accent - "uacute" => "\xFA", # small u, acute accent - "Ucirc" => "\xDB", # capital U, circumflex accent - "ucirc" => "\xFB", # small u, circumflex accent - "Ugrave" => "\xD9", # capital U, grave accent - "ugrave" => "\xF9", # small u, grave accent - "Uuml" => "\xDC", # capital U, dieresis or umlaut mark - "uuml" => "\xFC", # small u, dieresis or umlaut mark - "Yacute" => "\xDD", # capital Y, acute accent - "yacute" => "\xFD", # small y, acute accent - "yuml" => "\xFF", # small y, dieresis or umlaut mark - - "lchevron" => "\xAB", # left chevron (double less than) - "rchevron" => "\xBB", # right chevron (double greater than) -); - - -############################################################################ -# Initialization -############################################################################ - -# Initialize the object. Must be sure to call our parent initializer. -sub initialize { - my $self = shift; - - $$self{alt} = 0 unless defined $$self{alt}; - $$self{indent} = 4 unless defined $$self{indent}; - $$self{loose} = 0 unless defined $$self{loose}; - $$self{sentence} = 0 unless defined $$self{sentence}; - $$self{width} = 76 unless defined $$self{width}; - - $$self{INDENTS} = []; # Stack of indentations. - $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. - - return $self->SUPER::initialize; -} - - -############################################################################ -# Core overrides -############################################################################ - -# Called for each command paragraph. Gets the command, the associated -# paragraph, the line number, and a Pod::Paragraph object. Just dispatches -# the command to a method named the same as the command. =cut is handled -# internally by Pod::Parser. -sub command { - my $self = shift; - my $command = shift; - return if $command eq 'pod'; - return if ($$self{EXCLUDE} && $command ne 'end'); - if (defined $$self{ITEM}) { - $self->item ("\n"); - local $_ = "\n"; - $self->output($_) if($command eq 'back'); - } - $command = 'cmd_' . $command; - return $self->$command (@_); -} - -# Called for a verbatim paragraph. Gets the paragraph, the line number, and -# a Pod::Paragraph object. Just output it verbatim, but with tabs converted -# to spaces. -sub verbatim { - my $self = shift; - return if $$self{EXCLUDE}; - $self->item if defined $$self{ITEM}; - local $_ = shift; - return if /^\s*$/; - s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme; - return $self->output($_); -} - -# Called for a regular text block. Gets the paragraph, the line number, and -# a Pod::Paragraph object. Perform interpolation and output the results. -sub textblock { - my $self = shift; - return if $$self{EXCLUDE}; - if($$self{VERBATIM}) { - $self->output($_[0]); - return; - } - local $_ = shift; - my $line = shift; - - # Perform a little magic to collapse multiple L<> references. This is - # here mostly for backwards-compatibility. We'll just rewrite the whole - # thing into actual text at this part, bypassing the whole internal - # sequence parsing thing. - s{ - ( - L< # A link of the form L</something>. - / - ( - [:\w]+ # The item has to be a simple word... - (\(\))? # ...or simple function. - ) - > - ( - ,?\s+(and\s+)? # Allow lots of them, conjuncted. - L< - / - ( - [:\w]+ - (\(\))? - ) - > - )+ - ) - } { - local $_ = $1; - s%L</([^>]+)>%$1%g; - my @items = split /(?:,?\s+(?:and\s+)?)/; - my $string = "the "; - my $i; - for ($i = 0; $i < @items; $i++) { - $string .= $items[$i]; - $string .= ", " if @items > 2 && $i != $#items; - $string .= " and " if ($i == $#items - 1); - } - $string .= " entries elsewhere in this document"; - $string; - }gex; - - # Now actually interpolate and output the paragraph. - $_ = $self->interpolate ($_, $line); - s/\s*$/\n/s; - if (defined $$self{ITEM}) { - $self->item ($_ . "\n"); - } else { - $self->output ($self->reformat ($_ . "\n")); - } -} - -# Called for an interior sequence. Gets the command, argument, and a -# Pod::InteriorSequence object and is expected to return the resulting text. -# Calls code, bold, italic, file, and link to handle those types of -# sequences, and handles S<>, E<>, X<>, and Z<> directly. -sub interior_sequence { - my $self = shift; - my $command = shift; - local $_ = shift; - return '' if ($command eq 'X' || $command eq 'Z'); - - # Expand escapes into the actual character now, carping if invalid. - if ($command eq 'E') { - return $ESCAPES{$_} if defined $ESCAPES{$_}; - carp "Unknown escape: E<$_>"; - return "E<$_>"; - } - - # For all the other sequences, empty content produces no output. - return if $_ eq ''; - - # For S<>, compress all internal whitespace and then map spaces to \01. - # When we output the text, we'll map this back. - if ($command eq 'S') { - s/\s{2,}/ /g; - tr/ /\01/; - return $_; - } - - # Anything else needs to get dispatched to another method. - if ($command eq 'B') { return $self->seq_b ($_) } - elsif ($command eq 'C') { return $self->seq_c ($_) } - elsif ($command eq 'F') { return $self->seq_f ($_) } - elsif ($command eq 'I') { return $self->seq_i ($_) } - elsif ($command eq 'L') { return $self->seq_l ($_) } - else { carp "Unknown sequence $command<$_>" } -} - -# Called for each paragraph that's actually part of the POD. We take -# advantage of this opportunity to untabify the input. -sub preprocess_paragraph { - my $self = shift; - local $_ = shift; - 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; - return $_; -} - - -############################################################################ -# Command paragraphs -############################################################################ - -# All command paragraphs take the paragraph and the line number. - -# First level heading. -sub cmd_head1 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n==== $_ ====\n\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output ($_ . "\n"); - } -} - -# Second level heading. -sub cmd_head2 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n== $_ ==\n\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output (' ' x ($$self{indent} / 2) . $_ . "\n"); - } -} - -# third level heading - not strictly perlpodspec compliant -sub cmd_head3 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n= $_ =\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output (' ' x ($$self{indent}) . $_ . "\n"); - } -} - -# fourth level heading - not strictly perlpodspec compliant -# just like head3 -*cmd_head4 = \&cmd_head3; - -# Start a list. -sub cmd_over { - my $self = shift; - local $_ = shift; - unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } - push (@{ $$self{INDENTS} }, $$self{MARGIN}); - $$self{MARGIN} += ($_ + 0); -} - -# End a list. -sub cmd_back { - my $self = shift; - $$self{MARGIN} = pop @{ $$self{INDENTS} }; - unless (defined $$self{MARGIN}) { - carp 'Unmatched =back'; - $$self{MARGIN} = $$self{indent}; - } -} - -# An individual list item. -sub cmd_item { - my $self = shift; - if (defined $$self{ITEM}) { $self->item } - local $_ = shift; - s/\s+$//s; - $$self{ITEM} = $self->interpolate ($_); -} - -# Begin a block for a particular translator. Setting VERBATIM triggers -# special handling in textblock(). -sub cmd_begin { - my $self = shift; - local $_ = shift; - my ($kind) = /^(\S+)/ or return; - if ($kind eq 'text') { - $$self{VERBATIM} = 1; - } else { - $$self{EXCLUDE} = 1; - } -} - -# End a block for a particular translator. We assume that all =begin/=end -# pairs are properly closed. -sub cmd_end { - my $self = shift; - $$self{EXCLUDE} = 0; - $$self{VERBATIM} = 0; -} - -# One paragraph for a particular translator. Ignore it unless it's intended -# for text, in which case we treat it as a verbatim text block. -sub cmd_for { - my $self = shift; - local $_ = shift; - my $line = shift; - return unless s/^text\b[ \t]*\r?\n?//; - $self->verbatim ($_, $line); -} - -# just a dummy method for the time being -sub cmd_encoding { - return; -} - -############################################################################ -# Interior sequences -############################################################################ - -# The simple formatting ones. These are here mostly so that subclasses can -# override them and do more complicated things. -sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] } -sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" } -sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } -sub seq_i { return '*' . $_[1] . '*' } - -# The complicated one. Handle links. Since this is plain text, we can't -# actually make any real links, so this is all to figure out what text we -# print out. -sub seq_l { - my $self = shift; - local $_ = shift; - - # Smash whitespace in case we were split across multiple lines. - s/\s+/ /g; - - # If we were given any explicit text, just output it. - if (/^([^|]+)\|/) { return $1 } - - # Okay, leading and trailing whitespace isn't important; get rid of it. - s/^\s+//; - s/\s+$//; - - # Default to using the whole content of the link entry as a section - # name. Note that L<manpage/> forces a manpage interpretation, as does - # something looking like L<manpage(section)>. The latter is an - # enhancement over the original Pod::Text. - my ($manpage, $section) = ('', $_); - if (/^(?:https?|ftp|news):/) { - # a URL - return $_; - } elsif (/^"\s*(.*?)\s*"$/) { - $section = '"' . $1 . '"'; - } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) { - ($manpage, $section) = ($_, ''); - } elsif (m{/}) { - ($manpage, $section) = split (/\s*\/\s*/, $_, 2); - } - - my $text = ''; - # Now build the actual output text. - if (!length $section) { - $text = "the $manpage manpage" if length $manpage; - } elsif ($section =~ /^[:\w]+(?:\(\))?/) { - $text .= 'the ' . $section . ' entry'; - $text .= (length $manpage) ? " in the $manpage manpage" - : ' elsewhere in this document'; - } else { - $section =~ s/^\"\s*//; - $section =~ s/\s*\"$//; - $text .= 'the section on "' . $section . '"'; - $text .= " in the $manpage manpage" if length $manpage; - } - return $text; -} - - -############################################################################ -# List handling -############################################################################ - -# This method is called whenever an =item command is complete (in other -# words, we've seen its associated paragraph or know for certain that it -# doesn't have one). It gets the paragraph associated with the item as an -# argument. If that argument is empty, just output the item tag; if it -# contains a newline, output the item tag followed by the newline. -# Otherwise, see if there's enough room for us to output the item tag in the -# margin of the text or if we have to put it on a separate line. -sub item { - my $self = shift; - local $_ = shift; - my $tag = $$self{ITEM}; - unless (defined $tag) { - carp 'item called without tag'; - return; - } - undef $$self{ITEM}; - my $indent = $$self{INDENTS}[-1]; - unless (defined $indent) { $indent = $$self{indent} } - my $space = ' ' x $indent; - $space =~ s/^ /:/ if $$self{alt}; - if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) { - my $margin = $$self{MARGIN}; - $$self{MARGIN} = $indent; - my $output = $self->reformat ($tag); - $output =~ s/[\r\n]*$/\n/; - $self->output ($output); - $$self{MARGIN} = $margin; - $self->output ($self->reformat ($_)) if /\S/; - } else { - $_ = $self->reformat ($_); - s/^ /:/ if ($$self{alt} && $indent > 0); - my $tagspace = ' ' x length $tag; - s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item'; - $self->output ($_); - } -} - - -############################################################################ -# Output formatting -############################################################################ - -# Wrap a line, indenting by the current left margin. We can't use -# Text::Wrap because it plays games with tabs. We can't use formline, even -# though we'd really like to, because it screws up non-printing characters. -# So we have to do the wrapping ourselves. -sub wrap { - my $self = shift; - local $_ = shift; - my $output = ''; - my $spaces = ' ' x $$self{MARGIN}; - my $width = $$self{width} - $$self{MARGIN}; - while (length > $width) { - if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) { - $output .= $spaces . $1 . "\n"; - } else { - last; - } - } - $output .= $spaces . $_; - $output =~ s/\s+$/\n\n/; - return $output; -} - -# Reformat a paragraph of text for the current margin. Takes the text to -# reformat and returns the formatted text. -sub reformat { - my $self = shift; - local $_ = shift; - - # If we're trying to preserve two spaces after sentences, do some - # munging to support that. Otherwise, smash all repeated whitespace. - if ($$self{sentence}) { - s/ +$//mg; - s/\.\r?\n/. \n/g; - s/[\r\n]+/ /g; - s/ +/ /g; - } else { - s/\s+/ /g; - } - return $self->wrap($_); -} - -# Output text to the output device. -sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } - - -############################################################################ -# Backwards compatibility -############################################################################ - -# The old Pod::Text module did everything in a pod2text() function. This -# tries to provide the same interface for legacy applications. -sub pod2text { - my @args; - - # This is really ugly; I hate doing option parsing in the middle of a - # module. But the old Pod::Text module supported passing flags to its - # entry function, so handle -a and -<number>. - while ($_[0] =~ /^-/) { - my $flag = shift; - if ($flag eq '-a') { push (@args, alt => 1) } - elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) } - else { - unshift (@_, $flag); - last; - } - } - - # Now that we know what arguments we're using, create the parser. - my $parser = Pod::PlainText->new (@args); - - # If two arguments were given, the second argument is going to be a file - # handle. That means we want to call parse_from_filehandle(), which - # means we need to turn the first argument into a file handle. Magic - # open will handle the <&STDIN case automagically. - if (defined $_[1]) { - my $infh; - if ($] < 5.006) { - $infh = gensym(); - } - unless (open ($infh, $_[0])) { - croak ("Can't open $_[0] for reading: $!\n"); - } - $_[0] = $infh; - return $parser->parse_from_filehandle (@_); - } else { - return $parser->parse_from_file (@_); - } -} - - -############################################################################ -# Module return value and documentation -############################################################################ - -1; -__END__ - -=head1 NAME - -Pod::PlainText - Convert POD data to formatted ASCII text - -=head1 SYNOPSIS - - use Pod::PlainText; - my $parser = Pod::PlainText->new (sentence => 0, width => 78); - - # Read POD from STDIN and write to STDOUT. - $parser->parse_from_filehandle; - - # Read POD from file.pod and write to file.txt. - $parser->parse_from_file ('file.pod', 'file.txt'); - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -Pod::PlainText is a module that can convert documentation in the POD format (the -preferred language for documenting Perl) into formatted ASCII. It uses no -special formatting controls or codes whatsoever, and its output is therefore -suitable for nearly any device. - -As a derived class from Pod::Parser, Pod::PlainText supports the same methods and -interfaces. See L<Pod::Parser> for all the details; briefly, one creates a -new parser with C<Pod::PlainText-E<gt>new()> and then calls either -parse_from_filehandle() or parse_from_file(). - -new() can take options, in the form of key/value pairs, that control the -behavior of the parser. The currently recognized options are: - -=over 4 - -=item alt - -If set to a true value, selects an alternate output format that, among other -things, uses a different heading style and marks C<=item> entries with a -colon in the left margin. Defaults to false. - -=item indent - -The number of spaces to indent regular text, and the default indentation for -C<=over> blocks. Defaults to 4. - -=item loose - -If set to a true value, a blank line is printed after a C<=headN> headings. -If set to false (the default), no blank line is printed after C<=headN>. -This is the default because it's the expected formatting for manual pages; -if you're formatting arbitrary text documents, setting this to true may -result in more pleasing output. - -=item sentence - -If set to a true value, Pod::PlainText will assume that each sentence ends in two -spaces, and will try to preserve that spacing. If set to false, all -consecutive whitespace in non-verbatim paragraphs is compressed into a -single space. Defaults to true. - -=item width - -The column at which to wrap text on the right-hand side. Defaults to 76. - -=back - -The standard Pod::Parser method parse_from_filehandle() takes up to two -arguments, the first being the file handle to read POD from and the second -being the file handle to write the formatted output to. The first defaults -to STDIN if not given, and the second defaults to STDOUT. The method -parse_from_file() is almost identical, except that its two arguments are the -input and output disk files instead. See L<Pod::Parser> for the specific -details. - -=head1 DIAGNOSTICS - -=over 4 - -=item Bizarre space in item - -(W) Something has gone wrong in internal C<=item> processing. This message -indicates a bug in Pod::PlainText; you should never see it. - -=item Can't open %s for reading: %s - -(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface -and the input file it was given could not be opened. - -=item Unknown escape: %s - -(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't -know about. - -=item Unknown sequence: %s - -(W) The POD source contained a non-standard internal sequence (something of -the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about. - -=item Unmatched =back - -(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an -C<=over> command. - -=back - -=head1 RESTRICTIONS - -Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on -output, due to an internal implementation detail. - -=head1 NOTES - -This is a replacement for an earlier Pod::Text module written by Tom -Christiansen. It has a revamped interface, since it now uses Pod::Parser, -but an interface roughly compatible with the old Pod::Text::pod2text() -function is still available. Please change to the new calling convention, -though. - -The original Pod::Text contained code to do formatting via termcap -sequences, although it wasn't turned on by default and it was problematic to -get it to work at all. This rewrite doesn't even try to do that, but a -subclass of it does. Look for L<Pod::Text::Termcap|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) - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the -original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and -its conversion to Pod::Parser by Brad Appleton -E<lt>bradapp@enteract.comE<gt>. - -=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Select.pm b/Master/tlpkg/tlperl/lib/Pod/Select.pm deleted file mode 100644 index 70267e94ec0..00000000000 --- a/Master/tlpkg/tlperl/lib/Pod/Select.pm +++ /dev/null @@ -1,756 +0,0 @@ -############################################################################# -# Pod/Select.pm -- function to select portions of POD docs -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Select; -use strict; - -use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::Select, podselect() - extract selected sections of POD from input - -=head1 SYNOPSIS - - use Pod::Select; - - ## Select all the POD sections for each file in @filelist - ## and print the result on standard output. - podselect(@filelist); - - ## Same as above, but write to tmp.out - podselect({-output => "tmp.out"}, @filelist): - - ## Select from the given filelist, only those POD sections that are - ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. - podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist): - - ## Select the "DESCRIPTION" section of the PODs from STDIN and write - ## the result to STDERR. - podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN); - -or - - use Pod::Select; - - ## Create a parser object for selecting POD sections from the input - $parser = new Pod::Select(); - - ## Select all the POD sections for each file in @filelist - ## and print the result to tmp.out. - $parser->parse_from_file("<&STDIN", "tmp.out"); - - ## Select from the given filelist, only those POD sections that are - ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. - $parser->select("NAME|SYNOPSIS", "OPTIONS"); - for (@filelist) { $parser->parse_from_file($_); } - - ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from - ## STDIN and write the result to STDERR. - $parser->select("DESCRIPTION"); - $parser->add_selection("SEE ALSO"); - $parser->parse_from_filehandle(\*STDIN, \*STDERR); - -=head1 REQUIRES - -perl5.005, Pod::Parser, Exporter, Carp - -=head1 EXPORTS - -podselect() - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -B<podselect()> is a function which will extract specified sections of -pod documentation from an input stream. This ability is provided by the -B<Pod::Select> module which is a subclass of B<Pod::Parser>. -B<Pod::Select> provides a method named B<select()> to specify the set of -POD sections to select for processing/printing. B<podselect()> merely -creates a B<Pod::Select> object and then invokes the B<podselect()> -followed by B<parse_from_file()>. - -=head1 SECTION SPECIFICATIONS - -B<podselect()> and B<Pod::Select::select()> may be given one or more -"section specifications" to restrict the text processed to only the -desired set of sections and their corresponding subsections. A section -specification is a string containing one or more Perl-style regular -expressions separated by forward slashes ("/"). If you need to use a -forward slash literally within a section title you can escape it with a -backslash ("\/"). - -The formal syntax of a section specification is: - -=over 4 - -=item * - -I<head1-title-regex>/I<head2-title-regex>/... - -=back - -Any omitted or empty regular expressions will default to ".*". -Please note that each regular expression given is implicitly -anchored by adding "^" and "$" to the beginning and end. Also, if a -given regular expression starts with a "!" character, then the -expression is I<negated> (so C<!foo> would match anything I<except> -C<foo>). - -Some example section specifications follow. - -=over 4 - -=item * - -Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections: - -C<NAME|SYNOPSIS> - -=item * - -Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION> -section: - -C<DESCRIPTION/Question|Answer> - -=item * - -Match the C<Comments> subsection of I<all> sections: - -C</Comments> - -=item * - -Match all subsections of C<DESCRIPTION> I<except> for C<Comments>: - -C<DESCRIPTION/!Comments> - -=item * - -Match the C<DESCRIPTION> section but do I<not> match any of its subsections: - -C<DESCRIPTION/!.+> - -=item * - -Match all top level sections but none of their subsections: - -C</!.+> - -=back - -=begin _NOT_IMPLEMENTED_ - -=head1 RANGE SPECIFICATIONS - -B<podselect()> and B<Pod::Select::select()> may be given one or more -"range specifications" to restrict the text processed to only the -desired ranges of paragraphs in the desired set of sections. A range -specification is a string containing a single Perl-style regular -expression (a regex), or else two Perl-style regular expressions -(regexs) separated by a ".." (Perl's "range" operator is ".."). -The regexs in a range specification are delimited by forward slashes -("/"). If you need to use a forward slash literally within a regex you -can escape it with a backslash ("\/"). - -The formal syntax of a range specification is: - -=over 4 - -=item * - -/I<start-range-regex>/[../I<end-range-regex>/] - -=back - -Where each the item inside square brackets (the ".." followed by the -end-range-regex) is optional. Each "range-regex" is of the form: - - =cmd-expr text-expr - -Where I<cmd-expr> is intended to match the name of one or more POD -commands, and I<text-expr> is intended to match the paragraph text for -the command. If a range-regex is supposed to match a POD command, then -the first character of the regex (the one after the initial '/') -absolutely I<must> be a single '=' character; it may not be anything -else (not even a regex meta-character) if it is supposed to match -against the name of a POD command. - -If no I<=cmd-expr> is given then the text-expr will be matched against -plain textblocks unless it is preceded by a space, in which case it is -matched against verbatim text-blocks. If no I<text-expr> is given then -only the command-portion of the paragraph is matched against. - -Note that these two expressions are each implicitly anchored. This -means that when matching against the command-name, there will be an -implicit '^' and '$' around the given I<=cmd-expr>; and when matching -against the paragraph text there will be an implicit '\A' and '\Z' -around the given I<text-expr>. - -Unlike with section-specs, the '!' character does I<not> have any special -meaning (negation or otherwise) at the beginning of a range-spec! - -Some example range specifications follow. - -=over 4 - -=item -Match all C<=for html> paragraphs: - -C</=for html/> - -=item -Match all paragraphs between C<=begin html> and C<=end html> -(note that this will I<not> work correctly if such sections -are nested): - -C</=begin html/../=end html/> - -=item -Match all paragraphs between the given C<=item> name until the end of the -current section: - -C</=item mine/../=head\d/> - -=item -Match all paragraphs between the given C<=item> until the next item, or -until the end of the itemized list (note that this will I<not> work as -desired if the item contains an itemized list nested within it): - -C</=item mine/../=(item|back)/> - -=back - -=end _NOT_IMPLEMENTED_ - -=cut - -############################################################################# - -#use diagnostics; -use Carp; -use Pod::Parser 1.04; - -@ISA = qw(Pod::Parser); -@EXPORT = qw(&podselect); - -## Maximum number of heading levels supported for '=headN' directives -*MAX_HEADING_LEVEL = \3; - -############################################################################# - -=head1 OBJECT METHODS - -The following methods are provided in this module. Each one takes a -reference to the object itself as an implicit first parameter. - -=cut - -##--------------------------------------------------------------------------- - -## =begin _PRIVATE_ -## -## =head1 B<_init_headings()> -## -## Initialize the current set of active section headings. -## -## =cut -## -## =end _PRIVATE_ - -sub _init_headings { - my $self = shift; - local *myData = $self; - - ## Initialize current section heading titles if necessary - unless (defined $myData{_SECTION_HEADINGS}) { - local *section_headings = $myData{_SECTION_HEADINGS} = []; - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - $section_headings[$i] = ''; - } - } -} - -##--------------------------------------------------------------------------- - -=head1 B<curr_headings()> - - ($head1, $head2, $head3, ...) = $parser->curr_headings(); - $head1 = $parser->curr_headings(1); - -This method returns a list of the currently active section headings and -subheadings in the document being parsed. The list of headings returned -corresponds to the most recently parsed paragraph of the input. - -If an argument is given, it must correspond to the desired section -heading number, in which case only the specified section heading is -returned. If there is no current section heading at the specified -level, then C<undef> is returned. - -=cut - -sub curr_headings { - my $self = shift; - $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS}); - my @headings = @{ $self->{_SECTION_HEADINGS} }; - return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings; -} - -##--------------------------------------------------------------------------- - -=head1 B<select()> - - $parser->select($section_spec1,$section_spec2,...); - -This method is used to select the particular sections and subsections of -POD documentation that are to be printed and/or processed. The existing -set of selected sections is I<replaced> with the given set of sections. -See B<add_selection()> for adding to the current set of selected -sections. - -Each of the C<$section_spec> arguments should be a section specification -as described in L<"SECTION SPECIFICATIONS">. The section specifications -are parsed by this method and the resulting regular expressions are -stored in the invoking object. - -If no C<$section_spec> arguments are given, then the existing set of -selected sections is cleared out (which means C<all> sections will be -processed). - -This method should I<not> normally be overridden by subclasses. - -=cut - -sub select { - my ($self, @sections) = @_; - local *myData = $self; - local $_; - -### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?) - - ##--------------------------------------------------------------------- - ## The following is a blatant hack for backward compatibility, and for - ## implementing add_selection(). If the *first* *argument* is the - ## string "+", then the remaining section specifications are *added* - ## to the current set of selections; otherwise the given section - ## specifications will *replace* the current set of selections. - ## - ## This should probably be fixed someday, but for the present time, - ## it seems incredibly unlikely that "+" would ever correspond to - ## a legitimate section heading - ##--------------------------------------------------------------------- - my $add = ($sections[0] eq '+') ? shift(@sections) : ''; - - ## Reset the set of sections to use - unless (@sections) { - delete $myData{_SELECTED_SECTIONS} unless ($add); - return; - } - $myData{_SELECTED_SECTIONS} = [] - unless ($add && exists $myData{_SELECTED_SECTIONS}); - local *selected_sections = $myData{_SELECTED_SECTIONS}; - - ## Compile each spec - for my $spec (@sections) { - if ( defined($_ = _compile_section_spec($spec)) ) { - ## Store them in our sections array - push(@selected_sections, $_); - } - else { - carp qq{Ignoring section spec "$spec"!\n}; - } - } -} - -##--------------------------------------------------------------------------- - -=head1 B<add_selection()> - - $parser->add_selection($section_spec1,$section_spec2,...); - -This method is used to add to the currently selected sections and -subsections of POD documentation that are to be printed and/or -processed. See <select()> for replacing the currently selected sections. - -Each of the C<$section_spec> arguments should be a section specification -as described in L<"SECTION SPECIFICATIONS">. The section specifications -are parsed by this method and the resulting regular expressions are -stored in the invoking object. - -This method should I<not> normally be overridden by subclasses. - -=cut - -sub add_selection { - my $self = shift; - return $self->select('+', @_); -} - -##--------------------------------------------------------------------------- - -=head1 B<clear_selections()> - - $parser->clear_selections(); - -This method takes no arguments, it has the exact same effect as invoking -<select()> with no arguments. - -=cut - -sub clear_selections { - my $self = shift; - return $self->select(); -} - -##--------------------------------------------------------------------------- - -=head1 B<match_section()> - - $boolean = $parser->match_section($heading1,$heading2,...); - -Returns a value of true if the given section and subsection heading -titles match any of the currently selected section specifications in -effect from prior calls to B<select()> and B<add_selection()> (or if -there are no explicitly selected/deselected sections). - -The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of -the corresponding sections, subsections, etc. to try and match. If -C<$headingN> is omitted then it defaults to the current corresponding -section heading title in the input. - -This method should I<not> normally be overridden by subclasses. - -=cut - -sub match_section { - my $self = shift; - my (@headings) = @_; - local *myData = $self; - - ## Return true if no restrictions were explicitly specified - my $selections = (exists $myData{_SELECTED_SECTIONS}) - ? $myData{_SELECTED_SECTIONS} : undef; - return 1 unless ((defined $selections) && @{$selections}); - - ## Default any unspecified sections to the current one - my @current_headings = $self->curr_headings(); - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - (defined $headings[$i]) or $headings[$i] = $current_headings[$i]; - } - - ## Look for a match against the specified section expressions - for my $section_spec ( @{$selections} ) { - ##------------------------------------------------------ - ## Each portion of this spec must match in order for - ## the spec to be matched. So we will start with a - ## match-value of 'true' and logically 'and' it with - ## the results of matching a given element of the spec. - ##------------------------------------------------------ - my $match = 1; - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - my $regex = $section_spec->[$i]; - my $negated = ($regex =~ s/^\!//); - $match &= ($negated ? ($headings[$i] !~ /${regex}/) - : ($headings[$i] =~ /${regex}/)); - last unless ($match); - } - return 1 if ($match); - } - return 0; ## no match -} - -##--------------------------------------------------------------------------- - -=head1 B<is_selected()> - - $boolean = $parser->is_selected($paragraph); - -This method is used to determine if the block of text given in -C<$paragraph> falls within the currently selected set of POD sections -and subsections to be printed or processed. This method is also -responsible for keeping track of the current input section and -subsections. It is assumed that C<$paragraph> is the most recently read -(but not yet processed) input paragraph. - -The value returned will be true if the C<$paragraph> and the rest of the -text in the same section as C<$paragraph> should be selected (included) -for processing; otherwise a false value is returned. - -=cut - -sub is_selected { - my ($self, $paragraph) = @_; - local $_; - local *myData = $self; - - $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS}); - - ## Keep track of current sections levels and headings - $_ = $paragraph; - if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/) - { - ## This is a section heading command - my ($level, $heading) = ($2, $3); - $level = 1 + (length($1) / 3) if ((! length $level) || (length $1)); - ## Reset the current section heading at this level - $myData{_SECTION_HEADINGS}->[$level - 1] = $heading; - ## Reset subsection headings of this one to empty - for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) { - $myData{_SECTION_HEADINGS}->[$i] = ''; - } - } - - return $self->match_section(); -} - -############################################################################# - -=head1 EXPORTED FUNCTIONS - -The following functions are exported by this module. Please note that -these are functions (not methods) and therefore C<do not> take an -implicit first argument. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<podselect()> - - podselect(\%options,@filelist); - -B<podselect> will print the raw (untranslated) POD paragraphs of all -POD sections in the given input files specified by C<@filelist> -according to the options given in C<\%options>. - -If any argument to B<podselect> is a reference to a hash -(associative array) then the values with the following keys are -processed as follows: - -=over 4 - -=item B<-output> - -A string corresponding to the desired output file (or ">&STDOUT" -or ">&STDERR"), or a filehandle to write on. The default is to use -standard output. - -=item B<-sections> - -A reference to an array of sections specifications (as described in -L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD -sections and subsections to be selected from input. If no section -specifications are given, then all sections of the PODs are used. - -=begin _NOT_IMPLEMENTED_ - -=item B<-ranges> - -A reference to an array of range specifications (as described in -L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD -paragraphs to be selected from the desired input sections. If no range -specifications are given, then all paragraphs of the desired sections -are used. - -=end _NOT_IMPLEMENTED_ - -=back - -All other arguments are optional and should correspond to filehandles to -read from or the names of input files containing POD sections. A file name -of "", "-" or "<&STDIN" will be interpreted to mean standard input (which -is the default if no arguments are given). - -=cut - -sub podselect { - my(@argv) = @_; - my %defaults = (); - my $pod_parser = new Pod::Select(%defaults); - my $num_inputs = 0; - my $output = '>&STDOUT'; - my %opts; - local $_; - for (@argv) { - my $ref = ref($_); - if ($ref && $ref eq 'HASH') { - %opts = (%defaults, %{$_}); - - ##------------------------------------------------------------- - ## Need this for backward compatibility since we formerly used - ## options that were all uppercase words rather than ones that - ## looked like Unix command-line options. - ## to be uppercase keywords) - ##------------------------------------------------------------- - %opts = map { - my ($key, $val) = (lc $_, $opts{$_}); - $key =~ s/^(?=\w)/-/; - $key =~ /^-se[cl]/ and $key = '-sections'; - #! $key eq '-range' and $key .= 's'; - ($key => $val); - } (keys %opts); - - ## Process the options - (exists $opts{'-output'}) and $output = $opts{'-output'}; - - ## Select the desired sections - $pod_parser->select(@{ $opts{'-sections'} }) - if ( (defined $opts{'-sections'}) - && ((ref $opts{'-sections'}) eq 'ARRAY') ); - - #! ## Select the desired paragraph ranges - #! $pod_parser->select(@{ $opts{'-ranges'} }) - #! if ( (defined $opts{'-ranges'}) - #! && ((ref $opts{'-ranges'}) eq 'ARRAY') ); - } - elsif(!$ref || $ref eq 'GLOB') { - $pod_parser->parse_from_file($_, $output); - ++$num_inputs; - } - else { - croak "Input from $ref reference not supported!\n"; - } - } - $pod_parser->parse_from_file('-') unless ($num_inputs > 0); -} - -############################################################################# - -=head1 PRIVATE METHODS AND DATA - -B<Pod::Select> makes uses a number of internal methods and data fields -which clients should not need to see or use. For the sake of avoiding -name collisions with client data and methods, these methods and fields -are briefly discussed here. Determined hackers may obtain further -information about them by reading the B<Pod::Select> source code. - -Private data fields are stored in the hash-object whose reference is -returned by the B<new()> constructor for this class. The names of all -private methods and data-fields used by B<Pod::Select> begin with a -prefix of "_" and match the regular expression C</^_\w+$/>. - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_compile_section_spec()> - - $listref = $parser->_compile_section_spec($section_spec); - -This function (note it is a function and I<not> a method) takes a -section specification (as described in L<"SECTION SPECIFICATIONS">) -given in C<$section_sepc>, and compiles it into a list of regular -expressions. If C<$section_spec> has no syntax errors, then a reference -to the list (array) of corresponding regular expressions is returned; -otherwise C<undef> is returned and an error message is printed (using -B<carp>) for each invalid regex. - -=end _PRIVATE_ - -=cut - -sub _compile_section_spec { - my ($section_spec) = @_; - my (@regexs, $negated); - - ## Compile the spec into a list of regexs - local $_ = $section_spec; - s{\\\\}{\001}g; ## handle escaped backward slashes - s{\\/}{\002}g; ## handle escaped forward slashes - - ## Parse the regexs for the heading titles - @regexs = split(/\//, $_, $MAX_HEADING_LEVEL); - - ## Set default regex for omitted levels - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - $regexs[$i] = '.*' unless ((defined $regexs[$i]) - && (length $regexs[$i])); - } - ## Modify the regexs as needed and validate their syntax - my $bad_regexs = 0; - for (@regexs) { - $_ .= '.+' if ($_ eq '!'); - s{\001}{\\\\}g; ## restore escaped backward slashes - s{\002}{\\/}g; ## restore escaped forward slashes - $negated = s/^\!//; ## check for negation - eval "m{$_}"; ## check regex syntax - if ($@) { - ++$bad_regexs; - carp qq{Bad regular expression /$_/ in "$section_spec": $@\n}; - } - else { - ## Add the forward and rear anchors (and put the negator back) - $_ = '^' . $_ unless (/^\^/); - $_ = $_ . '$' unless (/\$$/); - $_ = '!' . $_ if ($negated); - } - } - return (! $bad_regexs) ? [ @regexs ] : undef; -} - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head2 $self->{_SECTION_HEADINGS} - -A reference to an array of the current section heading titles for each -heading level (note that the first heading level title is at index 0). - -=end _PRIVATE_ - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head2 $self->{_SELECTED_SECTIONS} - -A reference to an array of references to arrays. Each subarray is a list -of anchored regular expressions (preceded by a "!" if the expression is to -be negated). The index of the expression in the subarray should correspond -to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}> -that it is to be matched against. - -=end _PRIVATE_ - -=cut - -############################################################################# - -=head1 SEE ALSO - -L<Pod::Parser> - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -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; -# vim: ts=4 sw=4 et diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple.pm b/Master/tlpkg/tlperl/lib/Pod/Simple.pm index 20924153b65..6c91b8ac1fb 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.35'; +$VERSION = '3.40'; @Known_formatting_codes = qw(I B C L E F S X Z); %Known_formatting_codes = map(($_=>1), @Known_formatting_codes); @@ -74,6 +74,9 @@ else { # EBCDIC on early Perl. We know what the values are for the code #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ __PACKAGE__->_accessorize( + '_output_is_for_JustPod', # For use only by Pod::Simple::JustPod, + # If non-zero, don't expand Z<> E<> S<> L<>, + # and count how many brackets in format codes 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters 'source_filename', # Filename of the source, for use in warnings 'source_dead', # Whether to consider this parser's source dead @@ -103,6 +106,8 @@ __PACKAGE__->_accessorize( 'preserve_whitespace', # whether to try to keep whitespace as-is 'strip_verbatim_indent', # What indent to strip from verbatim + 'expand_verbatim_tabs', # 0: preserve tabs in verbatim blocks + # n: expand tabs to stops every n columns 'parse_characters', # Whether parser should expect chars rather than octets @@ -168,6 +173,7 @@ sub encoding { BEGIN { *pretty = \&Pod::Simple::BlackBox::pretty; *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol; + *my_qr = \&Pod::Simple::BlackBox::my_qr; } #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @@ -219,11 +225,14 @@ sub new { my $class = ref($_[0]) || $_[0]; #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc " # . __PACKAGE__ ); - return bless { + my $obj = bless { 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) }, 'accept_directives' => { %Known_directives }, 'accept_targets' => {}, }, $class; + + $obj->expand_verbatim_tabs(8); + return $obj; } @@ -339,10 +348,9 @@ sub unaccept_targets { # XXX Probably it is an error that the digit '9' is excluded from these re's. # Broken for early Perls on EBCDIC -my $xml_name_re = eval "qr/[^-.0-8:A-Z_a-z[:^ascii:]]/"; -if (! defined $xml_name_re) { - $xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/; -} +my $xml_name_re = my_qr('[^-.0-8:A-Z_a-z[:^ascii:]]', '9'); +$xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ + unless $xml_name_re; sub accept_code { shift->accept_codes(@_) } # alias @@ -652,12 +660,13 @@ sub _make_treelet { $treelet = $self->_treelet_from_formatting_codes(@_); } - if( $self->_remap_sequences($treelet) ) { + if( ! $self->{'_output_is_for_JustPod'} # Retain these as-is for pod output + && $self->_remap_sequences($treelet) ) + { $self->_treat_Zs($treelet); # Might as well nix these first $self->_treat_Ls($treelet); # L has to precede E and S $self->_treat_Es($treelet); $self->_treat_Ss($treelet); # S has to come after E - $self->_wrap_up($treelet); # Nix X's and merge texties } else { @@ -1080,9 +1089,14 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences # By here, $treelet->[$i] is definitely an L node my $ell = $treelet->[$i]; - DEBUG > 1 and print STDERR "Ogling L node $ell\n"; + DEBUG > 1 and print STDERR "Ogling L node " . pretty($ell) . "\n"; - # bitch if it's empty + # bitch if it's empty or is just '/' + if (@{$ell} == 3 and $ell->[2] =~ m!\A\s*/\s*\z!) { + $self->whine( $start_line, "L<> contains only '/'" ); + $treelet->[$i] = 'L</>'; # just make it a text node + next; # and move on + } if( @{$ell} == 2 or (@{$ell} == 3 and $ell->[2] eq '') ) { @@ -1289,6 +1303,7 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences $section_name = [splice @ell_content]; $section_name->[ 0] =~ s/^\"//s; $section_name->[-1] =~ s/\"$//s; + $ell->[1]{'~tolerated'} = 1; } # Turn L<Foo Bar> into L</Foo Bar>. @@ -1296,8 +1311,8 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences and grep !ref($_) && m/ /s, @ell_content ) { $section_name = [splice @ell_content]; + $ell->[1]{'~deprecated'} = 1; # That's support for the now-deprecated syntax. - # (Maybe generate a warning eventually?) # Note that it deliberately won't work on L<...|Foo Bar> } @@ -1347,7 +1362,7 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences # And update children to be the link-text: @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : ''); - DEBUG > 2 and print STDERR "End of L-parsing for this node $treelet->[$i]\n"; + DEBUG > 2 and print STDERR "End of L-parsing for this node " . pretty($treelet->[$i]) . "\n"; unshift @stack, $treelet->[$i]; # might as well recurse } @@ -1507,6 +1522,7 @@ sub _accessorize { # A simple-minded method-maker $Carp::CarpLevel = 1, Carp::croak( "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)" ) unless (@_ == 1 or @_ == 2) and ref $_[0]; + (@_ == 1) ? $_[0]->{$attrname} : ($_[0]->{$attrname} = $_[1]); }; diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple.pod b/Master/tlpkg/tlperl/lib/Pod/Simple.pod index 67a18df0d64..c569e979ae9 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple.pod +++ b/Master/tlpkg/tlperl/lib/Pod/Simple.pod @@ -19,7 +19,11 @@ Be sure to read L</ENCODING> if your Pod contains non-ASCII characters. Pod formatters can use Pod::Simple to parse Pod documents and render them into plain text, HTML, or any number of other formats. Typically, such formatters will be subclasses of Pod::Simple, and so they will inherit its methods, like -C<parse_file>. +C<parse_file>. But note that Pod::Simple doesn't understand and +properly parse Perl itself, so if you have a file which contains a Perl +program that has a multi-line quoted string which has lines that look +like pod, Pod::Simple will treat them as pod. This can be avoided if +the file makes these into indented here documents instead. If you're reading this document just because you have a Pod-processing subclass that you want to use, this document (plus the documentation for the @@ -219,6 +223,21 @@ that you don't want I<any> lines indented. You can do something like this: return undef; }); +=item C<< $parser->expand_verbatim_tabs( I<n> ) >> + +Default: 8 + +If after any stripping of indentation in verbatim blocks, there remain +tabs, this method call indicates what to do with them. C<0> +means leave them as tabs, any other number indicates that each tab is to +be translated so as to have tab stops every C<n> columns. + +This is independent of other methods (except that it operates after any +verbatim input stripping is done). + +Like the other methods, the input parameter is not checked for validity. +C<undef> or containing non-digits has the same effect as 8. + =back =head1 TERTIARY METHODS @@ -390,8 +409,8 @@ This module is managed in an open GitHub repository, L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! -Patches against Pod::Simple are welcome. Please send bug reports to -<bug-pod-simple@rt.cpan.org>. +Please use L<https://github.com/perl-pod/pod-simple/issues/new> to file a bug +report. =head1 COPYRIGHT AND DISCLAIMERS @@ -419,6 +438,8 @@ Pod::Simple is maintained by: =item * David E. Wheeler C<dwheeler@cpan.org> +=item * Karl Williamson C<khw@cpan.org> + =back Documentation has been contributed by: diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm index 9fe3f702ef9..d115aee7e3e 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/BlackBox.pm @@ -22,8 +22,36 @@ use integer; # vroom! use strict; use Carp (); use vars qw($VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; #use constant DEBUG => 7; + +sub my_qr ($$) { + + # $1 is a pattern to compile and return. Older perls compile any + # syntactically valid property, even if it isn't legal. To cope with + # this, return an empty string unless the compiled pattern also + # successfully matches $2, which the caller furnishes. + + my ($input_re, $should_match) = @_; + # XXX could have a third parameter $shouldnt_match for extra safety + + my $use_utf8 = ($] le 5.006002) ? 'use utf8;' : ""; + + my $re = eval "no warnings; $use_utf8 qr/$input_re/"; + #print STDERR __LINE__, ": $input_re: $@\n" if $@; + return "" if $@; + + my $matches = eval "no warnings; $use_utf8 '$should_match' =~ /$re/"; + #print STDERR __LINE__, ": $input_re: $@\n" if $@; + return "" if $@; + + #print STDERR __LINE__, ": SUCCESS: $re\n" if $matches; + return $re if $matches; + + #print STDERR __LINE__, ": $re: didn't match\n"; + return ""; +} + BEGIN { require Pod::Simple; *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG @@ -32,8 +60,37 @@ BEGIN { # Matches a character iff the character will have a different meaning # if we choose CP1252 vs UTF-8 if there is no =encoding line. # This is broken for early Perls on non-ASCII platforms. -my $non_ascii_re = eval "qr/[[:^ascii:]]/"; -$non_ascii_re = qr/[\x80-\xFF]/ if ! defined $non_ascii_re; +my $non_ascii_re = my_qr('[[:^ascii:]]', "\xB6"); +$non_ascii_re = qr/[\x80-\xFF]/ unless $non_ascii_re; + +# Use patterns understandable by Perl 5.6, if possible +my $cs_re = my_qr('\p{IsCs}', "\x{D800}"); +my $cn_re = my_qr('\p{IsCn}', "\x{09E4}"); # <reserved> code point unlikely + # to get assigned +my $rare_blocks_re = my_qr('[\p{InIPAExtensions}\p{InSpacingModifierLetters}]', + "\x{250}"); +$rare_blocks_re = my_qr('[\x{0250}-\x{02FF}]', "\x{250}") unless $rare_blocks_re; + +my $script_run_re = eval 'no warnings "experimental::script_run"; + qr/(*script_run: ^ .* $ )/x'; +my $latin_re = my_qr('[\p{IsLatin}\p{IsInherited}\p{IsCommon}]', "\x{100}"); +unless ($latin_re) { + # This was machine generated to be the ranges of the union of the above + # three properties, with things that were undefined by Unicode 4.1 filling + # gaps. That is the version in use when Perl advanced enough to + # successfully compile and execute the above pattern. + $latin_re = my_qr('[\x00-\x{02E9}\x{02EC}-\x{0374}\x{037E}\x{0385}\x{0387}\x{0485}\x{0486}\x{0589}\x{060C}\x{061B}\x{061F}\x{0640}\x{064B}-\x{0655}\x{0670}\x{06DD}\x{0951}-\x{0954}\x{0964}\x{0965}\x{0E3F}\x{10FB}\x{16EB}-\x{16ED}\x{1735}\x{1736}\x{1802}\x{1803}\x{1805}\x{1D00}-\x{1D25}\x{1D2C}-\x{1D5C}\x{1D62}-\x{1D65}\x{1D6B}-\x{1D77}\x{1D79}-\x{1DBE}\x{1DC0}-\x{1EF9}\x{2000}-\x{2125}\x{2127}-\x{27FF}\x{2900}-\x{2B13}\x{2E00}-\x{2E1D}\x{2FF0}-\x{3004}\x{3006}\x{3008}-\x{3020}\x{302A}-\x{302D}\x{3030}-\x{3037}\x{303C}-\x{303F}\x{3099}-\x{309C}\x{30A0}\x{30FB}\x{30FC}\x{3190}-\x{319F}\x{31C0}-\x{31CF}\x{3220}-\x{325F}\x{327F}-\x{32CF}\x{3358}-\x{33FF}\x{4DC0}-\x{4DFF}\x{A700}-\x{A716}\x{FB00}-\x{FB06}\x{FD3E}\x{FD3F}\x{FE00}-\x{FE6B}\x{FEFF}-\x{FF65}\x{FF70}\x{FF9E}\x{FF9F}\x{FFE0}-\x{FFFD}\x{10100}-\x{1013F}\x{1D000}-\x{1D1DD}\x{1D300}-\x{1D7FF}]', "\x{100}"); +} + +my $every_char_is_latin_re = my_qr("^(?:$latin_re)*\\z", "A"); + +# Latin script code points not in the first release of Unicode +my $later_latin_re = my_qr('[^\P{IsLatin}\p{IsAge=1.1}]', "\x{1F6}"); + +# If this perl doesn't have the Deprecated property, there's only one code +# point in it that we need be concerned with. +my $deprecated_re = my_qr('\p{IsDeprecated}', "\x{149}"); +$deprecated_re = qr/\x{149}/ unless $deprecated_re; my $utf8_bom; if (($] ge 5.007_003)) { @@ -43,6 +100,11 @@ if (($] ge 5.007_003)) { $utf8_bom = "\xEF\xBB\xBF"; # No EBCDIC BOM detection for early Perls. } +# This is used so that the 'content_seen' method doesn't return true on a +# file that just happens to have a line that matches /^=[a-zA-z]/. Only if +# there is a valid =foo line will we return that content was seen. +my $seen_legal_directive = 0; + #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ sub parse_line { shift->parse_lines(@_) } # alias @@ -57,10 +119,10 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) my $cut_handler = $self->{'cut_handler'}; my $wl_handler = $self->{'whiteline_handler'}; $self->{'line_count'} ||= 0; - + my $scratch; - DEBUG > 4 and + DEBUG > 4 and print STDERR "# Parsing starting at line ", $self->{'line_count'}, ".\n"; DEBUG > 5 and @@ -71,9 +133,17 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # paragraph buffer. Because we need to defer processing of =over # directives and verbatim paragraphs. We call _ponder_paragraph_buffer # to process this. - + $self->{'pod_para_count'} ||= 0; + # An attempt to match the pod portions of a line. This is not fool proof, + # but is good enough to serve as part of the heuristic for guessing the pod + # encoding if not specified. + my $format_codes = join "", '[', grep { / ^ [A-Za-z] $/x } + keys %{$self->{accept_codes}}; + $format_codes .= ']'; + my $pod_chars_re = qr/ ^ = [A-Za-z]+ | $format_codes < /x; + my $line; foreach my $source_line (@_) { if( $self->{'source_dead'} ) { @@ -97,7 +167,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) ($line = $source_line) =~ tr/\n\r//d; # If we don't have two vars, we'll end up with that there # tr/// modding the (potentially read-only) original source line! - + } else { DEBUG > 2 and print STDERR "First line: [$source_line]\n"; @@ -106,7 +176,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) $self->_handle_encoding_line( "=encoding utf8" ); delete $self->{'_processed_encoding'}; $line =~ tr/\n\r//d; - + } elsif( $line =~ s/^\xFE\xFF//s ) { DEBUG and print STDERR "Big-endian UTF-16 BOM seen. Aborting parsing.\n"; $self->scream( @@ -130,7 +200,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) next; # TODO: implement somehow? - + } else { DEBUG > 2 and print STDERR "First line is BOM-less.\n"; ($line = $source_line) =~ tr/\n\r//d; @@ -144,8 +214,8 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) my $encoding; - # No =encoding line, and we are at the first line in the input that - # contains a non-ascii byte, that is one whose meaning varies depending + # No =encoding line, and we are at the first pod line in the input that + # contains a non-ascii byte, that is, one whose meaning varies depending # on whether the file is encoded in UTF-8 or CP1252, which are the two # possibilities permitted by the pod spec. (ASCII is assumed if the # file only contains ASCII bytes.) In order to process this line, we @@ -162,22 +232,28 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # without conflict. CP 1252 uses most of them for graphic characters. # # Note that all ASCII-range bytes represent their corresponding code - # points in CP1252 and UTF-8. In ASCII platform UTF-8 all other code - # points require multiple (non-ASCII) bytes to represent. (A separate - # paragraph for EBCDIC is below.) The multi-byte representation is - # quite structured. If we find an isolated byte that requires multiple - # bytes to represent in UTF-8, we know that the encoding is not UTF-8. - # If we find a sequence of bytes that violates the UTF-8 structure, we - # also can presume the encoding isn't UTF-8, and hence must be 1252. + # points in both CP1252 and UTF-8. In ASCII platform UTF-8, all other + # code points require multiple (non-ASCII) bytes to represent. (A + # separate paragraph for EBCDIC is below.) The multi-byte + # representation is quite structured. If we find an isolated byte that + # would require multiple bytes to represent in UTF-8, we know that the + # encoding is not UTF-8. If we find a sequence of bytes that violates + # the UTF-8 structure, we also can presume the encoding isn't UTF-8, and + # hence must be 1252. # # But there are ambiguous cases where we could guess wrong. If so, the # user will end up having to supply an =encoding line. We use all # readily available information to improve our chances of guessing # right. The odds of something not being UTF-8, but still passing a # UTF-8 validity test go down very rapidly with increasing length of the - # sequence. Therefore we look at all the maximal length non-ascii - # sequences on the line. If any of the sequences can't be UTF-8, we - # quit there and choose CP1252. If all could be UTF-8, we guess UTF-8. + # sequence. Therefore we look at all non-ascii sequences on the line. + # If any of the sequences can't be UTF-8, we quit there and choose + # CP1252. If all could be UTF-8, we see if any of the code points + # represented are unlikely to be in pod. If so, we guess CP1252. If + # not, we check if the line is all in the same script; if not guess + # CP1252; otherwise UTF-8. For perls that don't have convenient script + # run testing, see if there is both Latin and non-Latin. If so, CP1252, + # otherwise UTF-8. # # On EBCDIC platforms, the situation is somewhat different. In # UTF-EBCDIC, not only do ASCII-range bytes represent their code points, @@ -188,51 +264,188 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # very unlikely to be in pod text. So if we encounter one of them, it # means that it is quite likely CP1252 and not UTF-8. The net result is # the same code below is used for both platforms. - while ($line =~ m/($non_ascii_re+)/g) { - my $non_ascii_seq = $1; - - if (length $non_ascii_seq == 1) { - $encoding = 'CP1252'; - goto guessed; - } elsif ($] ge 5.007_003) { - - # On Perls that have this function, we can see if the sequence is - # valid UTF-8 or not. - my $is_utf8; - { - no warnings 'utf8'; - $is_utf8 = utf8::decode($non_ascii_seq); + # + # XXX probably if the line has E<foo> that evaluates to illegal CP1252, + # then it is UTF-8. But we haven't processed E<> yet. + + goto set_1252 if $] lt 5.006_000; # No UTF-8 on very early perls + + my $copy; + + no warnings 'utf8'; + + if ($] ge 5.007_003) { + $copy = $line; + + # On perls that have this function, we can use it to easily see if the + # sequence is valid UTF-8 or not; if valid it turns on the UTF-8 flag + # needed below for script run detection + goto set_1252 if ! utf8::decode($copy); + } + elsif (ord("A") != 65) { # Early EBCDIC, assume UTF-8. What's a windows + # code page doing here anyway? + goto set_utf8; + } + else { # ASCII, no decode(): do it ourselves using the fundamental + # characteristics of UTF-8 + use if $] le 5.006002, 'utf8'; + + my $char_ord; + my $needed; # How many continuation bytes to gobble up + + # Initialize the translated line with a dummy character that will be + # deleted after everything else is done. This dummy makes sure that + # $copy will be in UTF-8. Doing it now avoids the bugs in early perls + # with upgrading in the middle + $copy = chr(0x100); + + # Parse through the line + for (my $i = 0; $i < length $line; $i++) { + my $byte = substr($line, $i, 1); + + # ASCII bytes are trivially dealt with + if ($byte !~ $non_ascii_re) { + $copy .= $byte; + next; + } + + my $b_ord = ord $byte; + + # Now figure out what this code point would be if the input is + # actually in UTF-8. If, in the process, we discover that it isn't + # well-formed UTF-8, we guess CP1252. + # + # Start the process. If it is UTF-8, we are at the first, start + # byte, of a multi-byte sequence. We look at this byte to figure + # out how many continuation bytes are needed, and to initialize the + # code point accumulator with the data from this byte. + # + # Normally the minimum continuation byte is 0x80, but in certain + # instances the minimum is a higher number. So the code below + # overrides this for those instances. + my $min_cont = 0x80; + + if ($b_ord < 0xC2) { # A start byte < C2 is malformed + goto set_1252; + } + elsif ($b_ord <= 0xDF) { + $needed = 1; + $char_ord = $b_ord & 0x1F; } - if (! $is_utf8) { - $encoding = 'CP1252'; - goto guessed; + elsif ($b_ord <= 0xEF) { + $min_cont = 0xA0 if $b_ord == 0xE0; + $needed = 2; + $char_ord = $b_ord & (0x1F >> 1); } - } elsif (ord("A") == 65) { # An early Perl, ASCII platform - - # Without utf8::decode, it's a lot harder to do a rigorous check - # (though some early releases had a different function that - # accomplished the same thing). Since these are ancient Perls, not - # likely to be in use today, we take the easy way out, and look at - # just the first two bytes of the sequence to see if they are the - # start of a UTF-8 character. In ASCII UTF-8, continuation bytes - # must be between 0x80 and 0xBF. Start bytes can range from 0xC2 - # through 0xFF, but anything above 0xF4 is not Unicode, and hence - # extremely unlikely to be in a pod. - if ($non_ascii_seq !~ /^[\xC2-\xF4][\x80-\xBF]/) { - $encoding = 'CP1252'; - goto guessed; + elsif ($b_ord <= 0xF4) { + $min_cont = 0x90 if $b_ord == 0xF0; + $needed = 3; + $char_ord = $b_ord & (0x1F >> 2); + } + else { # F4 is the highest start byte for legal Unicode; higher is + # unlikely to be in pod. + goto set_1252; } - # We don't bother doing anything special for EBCDIC on early Perls. - # If there is a solitary variant, CP1252 will be chosen; otherwise - # UTF-8. - } - } # End of loop through all variant sequences on the line + # ? not enough continuation bytes available + goto set_1252 if $i + $needed >= length $line; + + # Accumulate the ordinal of the character from the remaining + # (continuation) bytes. + while ($needed-- > 0) { + my $cont = substr($line, ++$i, 1); + $b_ord = ord $cont; + goto set_1252 if $b_ord < $min_cont || $b_ord > 0xBF; + + # In all cases, any next continuation bytes all have the same + # minimum legal value + $min_cont = 0x80; + + # Accumulate this byte's contribution to the code point + $char_ord <<= 6; + $char_ord |= ($b_ord & 0x3F); + } + + # Here, the sequence that formed this code point was valid UTF-8, + # so add the completed character to the output + $copy .= chr $char_ord; + } # End of loop through line + + # Delete the dummy first character + $copy = substr($copy, 1); + } + + # Here, $copy is legal UTF-8. + + # If it can't be legal CP1252, no need to look further. (These bytes + # aren't valid in CP1252.) This test could have been placed higher in + # the code, but it seemed wrong to set the encoding to UTF-8 without + # making sure that the very first instance is well-formed. But what if + # it isn't legal CP1252 either? We have to choose one or the other, and + # It seems safer to favor the single-byte encoding over the multi-byte. + goto set_utf8 if ord("A") == 65 && $line =~ /[\x81\x8D\x8F\x90\x9D]/; + + # The C1 controls are not likely to appear in pod + goto set_1252 if ord("A") == 65 && $copy =~ /[\x80-\x9F]/; + + # Nor are surrogates nor unassigned, nor deprecated. + DEBUG > 8 and print STDERR __LINE__, ": $copy: surrogate\n" if $copy =~ $cs_re; + goto set_1252 if $cs_re && $copy =~ $cs_re; + DEBUG > 8 and print STDERR __LINE__, ": $copy: unassigned\n" if $cn_re && $copy =~ $cn_re; + goto set_1252 if $cn_re && $copy =~ $cn_re; + DEBUG > 8 and print STDERR __LINE__, ": $copy: deprecated\n" if $copy =~ $deprecated_re; + goto set_1252 if $copy =~ $deprecated_re; + + # Nor are rare code points. But this is hard to determine. khw + # believes that IPA characters and the modifier letters are unlikely to + # be in pod (and certainly very unlikely to be the in the first line in + # the pod containing non-ASCII) + DEBUG > 8 and print STDERR __LINE__, ": $copy: rare\n" if $copy =~ $rare_blocks_re; + goto set_1252 if $rare_blocks_re && $copy =~ $rare_blocks_re; + + # The first Unicode version included essentially every Latin character + # in modern usage. So, a Latin character not in the first release will + # unlikely be in pod. + DEBUG > 8 and print STDERR __LINE__, ": $copy: later_latin\n" if $later_latin_re && $copy =~ $later_latin_re; + goto set_1252 if $later_latin_re && $copy =~ $later_latin_re; + + # On perls that handle script runs, if the UTF-8 interpretation yields + # a single script, we guess UTF-8, otherwise just having a mixture of + # scripts is suspicious, so guess CP1252. We first strip off, as best + # we can, the ASCII characters that look like they are pod directives, + # as these would always show as mixed with non-Latin text. + $copy =~ s/$pod_chars_re//g; + + if ($script_run_re) { + goto set_utf8 if $copy =~ $script_run_re; + DEBUG > 8 and print STDERR __LINE__, ": not script run\n"; + goto set_1252; + } + + # Even without script runs, but on recent enough perls and Unicodes, we + # can check if there is a mixture of both Latin and non-Latin. Again, + # having a mixture of scripts is suspicious, so assume CP1252 + + # If it's all non-Latin, there is no CP1252, as that is Latin + # characters and punct, etc. + DEBUG > 8 and print STDERR __LINE__, ": $copy: not latin\n" if $copy !~ $latin_re; + goto set_utf8 if $copy !~ $latin_re; + + DEBUG > 8 and print STDERR __LINE__, ": $copy: all latin\n" if $copy =~ $every_char_is_latin_re; + goto set_utf8 if $copy =~ $every_char_is_latin_re; + + DEBUG > 8 and print STDERR __LINE__, ": $copy: mixed\n"; + + set_1252: + DEBUG > 9 and print STDERR __LINE__, ": $copy: is 1252\n"; + $encoding = 'CP1252'; + goto done_set; - # All sequences in the line could be UTF-8. Guess that. + set_utf8: + DEBUG > 9 and print STDERR __LINE__, ": $copy: is UTF-8\n"; $encoding = 'UTF-8'; - guessed: + done_set: $self->_handle_encoding_line( "=encoding $encoding" ); delete $self->{'_processed_encoding'}; $self->{'_transcoder'} && $self->{'_transcoder'}->($line); @@ -254,13 +467,13 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) $self->{'line_count'}, "=cut found outside a pod block. Skipping to next block." ); - + ## Before there were errata sections in the world, it was ## least-pessimal to abort processing the file. But now we can ## just barrel on thru (but still not start a pod block). #splice @_; #push @_, undef; - + next; } else { $self->{'in_pod'} = $self->{'start_of_pod_block'} @@ -273,7 +486,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) if $code_handler; # Note: this may cause code to be processed out of order relative # to pods, but in order relative to cuts. - + # Note also that we haven't yet applied the transcoding to $line # by time we call $code_handler! @@ -284,11 +497,11 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) DEBUG > 1 and print STDERR "# Setting nextline to $1\n"; $self->{'line_count'} = $1 - 1; } - + next; } } - + # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . # Else we're in pod mode: @@ -308,12 +521,13 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # ++$self->{'pod_para_count'}; $self->_ponder_paragraph_buffer(); # by now it's safe to consider the previous paragraph as done. + DEBUG > 6 and print STDERR "Processing any cut handler, line ${$self}{'line_count'}\n"; $cut_handler->(map $_, $line, $self->{'line_count'}, $self) if $cut_handler; # TODO: add to docs: Note: this may cause cuts to be processed out # of order relative to pods, but in order relative to code. - + } elsif($line =~ m/^(\s*)$/s) { # it's a blank line if (defined $1 and $1 =~ /[^\S\r\n]/) { # it's a white line $wl_handler->(map $_, $line, $self->{'line_count'}, $self) @@ -324,29 +538,30 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) DEBUG > 1 and print STDERR "Saving blank line at line ${$self}{'line_count'}\n"; push @{$paras->[-1]}, $line; } # otherwise it's not interesting - + if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) { DEBUG > 1 and print STDERR "Noting para ends with blank line at ${$self}{'line_count'}\n"; } - + $self->{'last_was_blank'} = 1; - + } elsif($self->{'last_was_blank'}) { # A non-blank line starting a new para... - - if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) { + + if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(\s+|$)(.*)/s) { # THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS - my $new = [$1, {'start_line' => $self->{'line_count'}}, $2]; + my $new = [$1, {'start_line' => $self->{'line_count'}}, $3]; + $new->[1]{'~orig_spacer'} = $2 if $2 && $2 ne " "; # Note that in "=head1 foo", the WS is lost. # Example: ['=head1', {'start_line' => 123}, ' foo'] - + ++$self->{'pod_para_count'}; - + $self->_ponder_paragraph_buffer(); # by now it's safe to consider the previous paragraph as done. - + push @$paras, $new; # the new incipient paragraph DEBUG > 1 and print STDERR "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n"; - + } elsif($line =~ m/^\s/s) { if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { @@ -379,7 +594,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) } $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; } - + } # ends the big while loop DEBUG > 1 and print STDERR (pretty(@$paras), "\n"); @@ -390,7 +605,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) sub _handle_encoding_line { my($self, $line) = @_; - + return if $self->parse_characters; # The point of this routine is to set $self->{'_transcoder'} as indicated. @@ -492,7 +707,7 @@ sub _handle_encoding_line { sub _handle_encoding_second_level { # By time this is called, the encoding (if well formed) will already - # have been acted one. + # have been acted on. my($self, $para) = @_; my @x = @$para; my $content = join ' ', splice @x, 2; @@ -500,7 +715,7 @@ sub _handle_encoding_second_level { $content =~ s/\s+$//s; DEBUG > 2 and print STDERR "Ogling encoding directive: =encoding $content\n"; - + if (defined($self->{'_processed_encoding'})) { #if($content ne $self->{'_processed_encoding'}) { # Could it happen? @@ -518,14 +733,14 @@ sub _handle_encoding_second_level { } else { DEBUG > 2 and print STDERR " (Yup, it was successfully handled already.)\n"; } - + } else { # Otherwise it's a syntax error $self->whine( $para->[1]{'start_line'}, "Invalid =encoding syntax: $content" ); } - + return; } @@ -542,7 +757,7 @@ sub _gen_errata { return() unless $self->{'errata'} and keys %{$self->{'errata'}}; my @out; - + foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) { push @out, ['=item', {'start_line' => $m}, "Around line $line:"], @@ -555,7 +770,7 @@ sub _gen_errata { ) ; } - + # TODO: report of unknown entities? unrenderable characters? unshift @out, @@ -569,7 +784,7 @@ sub _gen_errata { ['=over', {'start_line' => $m, 'errata' => 1}, ''], ; - push @out, + push @out, ['=back', {'start_line' => $m, 'errata' => 1}, ''], ; @@ -610,7 +825,7 @@ sub _ponder_paragraph_buffer { # Document, # Data, Para, Verbatim # B, C, longdirname (TODO -- wha?), etc. for all directives - # + # my $self = $_[0]; my $paras; @@ -624,11 +839,11 @@ sub _ponder_paragraph_buffer { # We have something in our buffer. So apparently the document has started. unless($self->{'doc_has_started'}) { $self->{'doc_has_started'} = 1; - + my $starting_contentless; $starting_contentless = ( - !@$curr_open + !@$curr_open and @$paras and ! grep $_->[0] ne '~end', @$paras # i.e., if the paras is all ~ends ) @@ -637,7 +852,7 @@ sub _ponder_paragraph_buffer { $starting_contentless ? 'contentless' : 'contentful', " document\n" ; - + $self->_handle_element_start( ($scratch = 'Document'), { @@ -649,15 +864,32 @@ sub _ponder_paragraph_buffer { my($para, $para_type); while(@$paras) { - last if @$paras == 1 and - ( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim' - or $paras->[0][0] eq '=item' ) - ; + + # If a directive, assume it's legal; subtract below if found not to be + $seen_legal_directive++ if $paras->[0][0] =~ /^=/; + + last if @$paras == 1 + and ( $paras->[0][0] eq '=over' + or $paras->[0][0] eq '=item' + or ($paras->[0][0] eq '~Verbatim' and $self->{'in_pod'})); # Those're the three kinds of paragraphs that require lookahead. # Actually, an "=item Foo" inside an <over type=text> region # and any =item inside an <over type=block> region (rare) # don't require any lookahead, but all others (bullets # and numbers) do. + # The verbatim is different from the other two, because those might be + # like: + # + # =item + # ... + # =cut + # ... + # =item + # + # The =cut here finishes the paragraph but doesn't terminate the =over + # they should be in. (khw apologizes that he didn't comment at the time + # why the 'in_pod' works, and no longer remembers why, and doesn't think + # it is currently worth the effort to re-figure it out.) # TODO: whinge about many kinds of directives in non-resolving =for regions? # TODO: many? like what? =head1 etc? @@ -667,7 +899,7 @@ sub _ponder_paragraph_buffer { DEBUG > 1 and print STDERR "Pondering a $para_type paragraph, given the stack: (", $self->_dump_curr_open(), ")\n"; - + if($para_type eq '=for') { next if $self->_ponder_for($para,$curr_open,$paras); @@ -704,7 +936,7 @@ sub _ponder_paragraph_buffer { } else { # All non-magical codes!!! - + # Here we start using $para_type for our own twisted purposes, to # mean how it should get treated, not as what the element name # should be. @@ -744,10 +976,10 @@ sub _ponder_paragraph_buffer { ; next; } - - + + my $over_type = $over->[1]{'~type'}; - + if(!$over_type) { # Shouldn't happen1 die "Typeless over in stack, starting at line " @@ -772,7 +1004,7 @@ sub _ponder_paragraph_buffer { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + if($item_type eq 'text') { # Nothing special needs doing for 'text' } elsif($item_type eq 'number' or $item_type eq 'bullet') { @@ -788,16 +1020,16 @@ sub _ponder_paragraph_buffer { } else { die "Unhandled item type $item_type"; # should never happen } - + # =item-text thingies don't need any assimilation, it seems. } elsif($over_type eq 'number') { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; - + if($item_type eq 'bullet') { # Hm, it's not numeric. Correct for this. $para->[1]{'number'} = $expected_value; @@ -822,7 +1054,7 @@ sub _ponder_paragraph_buffer { } elsif($expected_value == $para->[1]{'number'}) { DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n"; - + } else { DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'}, " instead of the expected value of $expected_value\n"; @@ -833,7 +1065,7 @@ sub _ponder_paragraph_buffer { ); $para->[1]{'number'} = $expected_value; # correcting!! } - + if(@$para == 2) { # For the cases where we /didn't/ push to @$para if($paras->[0][0] eq '~Para') { @@ -850,13 +1082,13 @@ sub _ponder_paragraph_buffer { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + if($item_type eq 'bullet') { # as expected! if( $para->[1]{'~_freaky_para_hack'} ) { DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n"; - push @$para, delete $para->[1]{'~_freaky_para_hack'}; + push @$para, $para->[1]{'~_freaky_para_hack'}; } } elsif($item_type eq 'number') { @@ -925,6 +1157,7 @@ sub _ponder_paragraph_buffer { DEBUG > 1 and print STDERR " Pondering known directive ${$para}[0] as $para_type\n"; } else { # An unknown directive! + $seen_legal_directive--; DEBUG > 1 and printf STDERR "Unhandled directive %s (Handled: %s)\n", $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} ) ; @@ -944,15 +1177,15 @@ sub _ponder_paragraph_buffer { my @fors = grep $_->[0] eq '=for', @$curr_open; DEBUG > 1 and print STDERR "Containing fors: ", join(',', map $_->[1]{'target'}, @fors), "\n"; - + if(! @fors) { DEBUG and print STDERR "Treating $para_type paragraph as such because stack has no =for's\n"; - + #} elsif(grep $_->[1]{'~resolve'}, @fors) { #} elsif(not grep !$_->[1]{'~resolve'}, @fors) { } elsif( $fors[-1][1]{'~resolve'} ) { # Look to the immediately containing for - + if($para_type eq 'Data') { DEBUG and print STDERR "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; $para->[0] = 'Para'; @@ -971,7 +1204,7 @@ sub _ponder_paragraph_buffer { if($para_type eq 'Plain') { $self->_ponder_Plain($para); } elsif($para_type eq 'Verbatim') { - $self->_ponder_Verbatim($para); + $self->_ponder_Verbatim($para); } elsif($para_type eq 'Data') { $self->_ponder_Data($para); } else { @@ -985,11 +1218,12 @@ sub _ponder_paragraph_buffer { DEBUG and print STDERR "\n", pretty($para), "\n"; # traverse the treelet (which might well be just one string scalar) - $self->{'content_seen'} ||= 1; + $self->{'content_seen'} ||= 1 if $seen_legal_directive + && ! $self->{'~tried_gen_errata'}; $self->_traverse_treelet_bit(@$para); } } - + return; } @@ -1024,9 +1258,9 @@ sub _ponder_for { } DEBUG > 1 and print STDERR "Faking out a =for $target as a =begin $target / =end $target\n"; - + $para->[0] = 'Data'; - + unshift @$paras, ['=begin', {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, @@ -1038,7 +1272,7 @@ sub _ponder_for { $target, ], ; - + return 1; } @@ -1055,20 +1289,20 @@ sub _ponder_begin { DEBUG and print STDERR "Ignoring targetless =begin\n"; return 1; } - + my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/; $para->[1]{'title'} = $title if ($title); $para->[1]{'target'} = $target; # without any ':' $content = $target; # strip off the title - + $content =~ s/^:!/!:/s; my $neg; # whether this is a negation-match $neg = 1 if $content =~ s/^!//s; my $to_resolve; # whether to process formatting codes $to_resolve = 1 if $content =~ s/^://s; - + my $dont_ignore; # whether this target matches us - + foreach my $target_name ( split(',', $content, -1), $neg ? () : '*' @@ -1076,7 +1310,7 @@ sub _ponder_begin { DEBUG > 2 and print STDERR " Considering whether =begin $content matches $target_name\n"; next unless $self->{'accept_targets'}{$target_name}; - + DEBUG > 2 and print STDERR " It DOES match the acceptable target $target_name!\n"; $to_resolve = 1 @@ -1113,7 +1347,7 @@ sub _ponder_begin { if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) { DEBUG > 1 and print STDERR "Ignoring ignorable =begin\n"; } else { - $self->{'content_seen'} ||= 1; + $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; $self->_handle_element_start((my $scratch='for'), $para->[1]); } @@ -1139,7 +1373,7 @@ sub _ponder_end { DEBUG and print STDERR "Ignoring targetless =end\n"; return 1; } - + unless($content =~ m/^\S+$/) { # i.e., unless it's one word $self->whine( $para->[1]{'start_line'}, @@ -1149,7 +1383,7 @@ sub _ponder_end { DEBUG and print STDERR "Ignoring mistargetted =end $content\n"; return 1; } - + unless(@$curr_open and $curr_open->[-1][0] eq '=for') { $self->whine( $para->[1]{'start_line'}, @@ -1159,11 +1393,11 @@ sub _ponder_end { DEBUG and print STDERR "Ignoring mistargetted =end $content\n"; return 1; } - + unless($content eq $curr_open->[-1][1]{'target'}) { $self->whine( $para->[1]{'start_line'}, - "=end $content doesn't match =begin " + "=end $content doesn't match =begin " . $curr_open->[-1][1]{'target'} . ". (Stack: " . $self->_dump_curr_open() . ')' @@ -1180,22 +1414,22 @@ sub _ponder_end { } else { $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'}; # what's that for? - - $self->{'content_seen'} ||= 1; + + $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; $self->_handle_element_end( my $scratch = 'for', $para->[1]); } DEBUG > 1 and print STDERR "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; pop @$curr_open; return 1; -} +} sub _ponder_doc_end { my ($self,$para,$curr_open,$paras) = @_; if(@$curr_open) { # Deal with things left open DEBUG and print STDERR "Stack is nonempty at end-document: (", $self->_dump_curr_open(), ")\n"; - + DEBUG > 9 and print STDERR "Stack: ", pretty($curr_open), "\n"; unshift @$paras, $self->_closers_for_all_curr_open; # Make sure there is exactly one ~end in the parastack, at the end: @@ -1205,11 +1439,11 @@ sub _ponder_doc_end { # generate errata, and then another to be at the end # when that loop back around to process the errata. return 1; - + } else { DEBUG and print STDERR "Okay, stack is empty now.\n"; } - + # Try generating errata section, if applicable unless($self->{'~tried_gen_errata'}) { $self->{'~tried_gen_errata'} = 1; @@ -1220,7 +1454,7 @@ sub _ponder_doc_end { return 1; # I.e., loop around again to process these fake-o paragraphs } } - + splice @$paras; # Well, that's that for this paragraph buffer. DEBUG and print STDERR "Throwing end-document event.\n"; @@ -1245,7 +1479,7 @@ sub _ponder_pod { # 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; + # $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; return; } @@ -1278,8 +1512,9 @@ sub _ponder_over { $para->[1]{'~type'} = $list_type; push @$curr_open, $para; # yes, we reuse the paragraph as a stack item - + my $content = join ' ', splice @$para, 2; + $para->[1]{'~orig_content'} = $content; my $overness; if($content =~ m/^\s*$/s) { $para->[1]{'indent'} = 4; @@ -1301,13 +1536,13 @@ sub _ponder_over { $para->[1]{'indent'} = 4; } DEBUG > 1 and print STDERR "=over found of type $list_type\n"; - - $self->{'content_seen'} ||= 1; + + $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]); return; } - + sub _ponder_back { my ($self,$para,$curr_open,$paras) = @_; # TODO: fire off </item-number> or </item-bullet> or </item-text> ?? @@ -1324,7 +1559,7 @@ sub _ponder_back { DEBUG > 1 and print STDERR "=back happily closes matching =over\n"; # Expected case: we're closing the most recently opened thing #my $over = pop @$curr_open; - $self->{'content_seen'} ||= 1; + $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; $self->_handle_element_end( my $scratch = 'over-' . ( (pop @$curr_open)->[1]{'~type'} ), $para->[1] ); @@ -1354,10 +1589,10 @@ sub _ponder_item { ; return 1; } - - + + my $over_type = $over->[1]{'~type'}; - + if(!$over_type) { # Shouldn't happen1 die "Typeless over in stack, starting at line " @@ -1382,7 +1617,7 @@ sub _ponder_item { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + if($item_type eq 'text') { # Nothing special needs doing for 'text' } elsif($item_type eq 'number' or $item_type eq 'bullet') { @@ -1398,16 +1633,16 @@ sub _ponder_item { } else { die "Unhandled item type $item_type"; # should never happen } - + # =item-text thingies don't need any assimilation, it seems. } elsif($over_type eq 'number') { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; - + if($item_type eq 'bullet') { # Hm, it's not numeric. Correct for this. $para->[1]{'number'} = $expected_value; @@ -1432,7 +1667,7 @@ sub _ponder_item { } elsif($expected_value == $para->[1]{'number'}) { DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n"; - + } else { DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'}, " instead of the expected value of $expected_value\n"; @@ -1443,7 +1678,7 @@ sub _ponder_item { ); $para->[1]{'number'} = $expected_value; # correcting!! } - + if(@$para == 2) { # For the cases where we /didn't/ push to @$para if($paras->[0][0] eq '~Para') { @@ -1460,13 +1695,13 @@ sub _ponder_item { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + if($item_type eq 'bullet') { # as expected! if( $para->[1]{'~_freaky_para_hack'} ) { DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n"; - push @$para, delete $para->[1]{'~_freaky_para_hack'}; + push @$para, $para->[1]{'~_freaky_para_hack'}; } } elsif($item_type eq 'number') { @@ -1533,30 +1768,44 @@ sub _ponder_Verbatim { $para->[1]{'xml:space'} = 'preserve'; - my $indent = $self->strip_verbatim_indent; - if ($indent && ref $indent eq 'CODE') { - my @shifted = (shift @{$para}, shift @{$para}); - $indent = $indent->($para); - unshift @{$para}, @shifted; - } - - for(my $i = 2; $i < @$para; $i++) { - foreach my $line ($para->[$i]) { # just for aliasing - # Strip indentation. - $line =~ s/^\Q$indent// if $indent - && !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted}); - while( $line =~ - # Sort of adapted from Text::Tabs -- yes, it's hardwired in that - # tabs are at every EIGHTH column. For portability, it has to be - # one setting everywhere, and 8th wins. - s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e - ) {} + unless ($self->{'_output_is_for_JustPod'}) { + # Fix illegal settings for expand_verbatim_tabs() + # This is because this module doesn't do input error checking, but khw + # doesn't want to add yet another instance of that. + $self->expand_verbatim_tabs(8) + if ! defined $self->expand_verbatim_tabs() + || $self->expand_verbatim_tabs() =~ /\D/; + + my $indent = $self->strip_verbatim_indent; + if ($indent && ref $indent eq 'CODE') { + my @shifted = (shift @{$para}, shift @{$para}); + $indent = $indent->($para); + unshift @{$para}, @shifted; + } - # TODO: whinge about (or otherwise treat) unindented or overlong lines + for(my $i = 2; $i < @$para; $i++) { + foreach my $line ($para->[$i]) { # just for aliasing + # Strip indentation. + $line =~ s/^\Q$indent// if $indent; + next unless $self->expand_verbatim_tabs; + + # This is commented out because of github issue #85, and the + # current maintainers don't know why it was there in the first + # place. + #&& !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted}); + while( $line =~ + # Sort of adapted from Text::Tabs. + s/^([^\t]*)(\t+)/$1.(" " x ((length($2) + * $self->expand_verbatim_tabs) + -(length($1)&7)))/e + ) {} + + # TODO: whinge about (or otherwise treat) unindented or overlong lines + } } } - + # Now the VerbatimFormatted hoodoo... if( $self->{'accept_codes'} and $self->{'accept_codes'}{'VerbatimFormatted'} @@ -1596,7 +1845,7 @@ sub _traverse_treelet_bit { # for use only by the routine above my $scratch; $self->_handle_element_start(($scratch=$name), shift @_); - + while (@_) { my $x = shift; if (ref($x)) { @@ -1606,7 +1855,7 @@ sub _traverse_treelet_bit { # for use only by the routine above $self->_handle_text($x); } } - + $self->_handle_element_end($scratch=$name); return; } @@ -1651,7 +1900,7 @@ sub _closers_for_all_curr_open { sub _verbatim_format { my($it, $p) = @_; - + my $formatting; for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines @@ -1659,7 +1908,7 @@ sub _verbatim_format { $p->[$i] .= "\n"; # Unlike with simple Verbatim blocks, we don't end up just doing # a join("\n", ...) on the contents, so we have to append a - # newline to ever line, and then nix the last one later. + # newline to every line, and then nix the last one later. } if( DEBUG > 4 ) { @@ -1672,7 +1921,7 @@ sub _verbatim_format { for(my $i = $#$p; $i > 2; $i--) { # work backwards over the lines, except the first (#2) - + #next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s # and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s; # look at a formatty line preceding a nonformatty one @@ -1680,7 +1929,7 @@ sub _verbatim_format { if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) { DEBUG > 5 and print STDERR " It's a formatty line. ", "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n"; - + if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) { DEBUG > 5 and print STDERR " Previous line is formatty! Skipping this one.\n"; next; @@ -1696,11 +1945,11 @@ sub _verbatim_format { # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic. # Example: # What do you want? i like pie. [or whatever] - # #:^^^^^^^^^^^^^^^^^ ///////////// - + # #:^^^^^^^^^^^^^^^^^ ///////////// + DEBUG > 4 and print STDERR "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n"; - + $formatting = ' ' . $1; $formatting =~ s/\s+$//s; # nix trailing whitespace unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op @@ -1716,7 +1965,7 @@ sub _verbatim_format { } # Make $formatting and the previous line be exactly the same length, # with $formatting having a " " as the last character. - + DEBUG > 4 and print STDERR "Formatting <$formatting> on <", $p->[$i-1], ">\n"; @@ -1741,10 +1990,10 @@ sub _verbatim_format { #print STDERR "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n"; } } - my @nixed = + my @nixed = splice @$p, $i-1, 2, @new_line; # replace myself and the next line DEBUG > 10 and print STDERR "Nixed count: ", scalar(@nixed), "\n"; - + DEBUG > 6 and print STDERR "New version of the above line is these tokens (", scalar(@new_line), "):", map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n"; @@ -1791,29 +2040,46 @@ sub _treelet_from_formatting_codes { # [ 'B', {}, "pie" ], # "!" # ] - + # This illustrates the general format of a treelet. It is an array: + # [0] is a scalar indicating its type. In the example above, the + # types are '~Top' and 'B' + # [1] is a hash of various flags about it, possibly empty + # [2] - [N] are an ordered list of the subcomponents of the treelet. + # Scalars are literal text, refs are sub-treelets, to + # arbitrary levels. Stringifying a treelet will recursively + # stringify the sub-treelets, concatentating everything + # together to form the exact text of the treelet. + my($self, $para, $start_line, $preserve_space) = @_; - + my $treelet = ['~Top', {'start_line' => $start_line},]; - + unless ($preserve_space || $self->{'preserve_whitespace'}) { $para =~ s/\s+/ /g; # collapse and trim all whitespace first. $para =~ s/ $//; $para =~ s/^ //; } - + # Only apparent problem the above code is that N<< >> turns into # N<< >>. But then, word wrapping does that too! So don't do that! - + + + # As a Start-code is encountered, the number of opening bracket '<' + # characters minus 1 is pushed onto @stack (so 0 means a single bracket, + # etc). When closing brackets are found in the text, at least this number + # (plus the 1) will be required to mean the Start-code is terminated. When + # those are found, @stack is popped. 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? + # into just 1 ' '. Is this the regex's doing or 'raw's? Answer is it's + # the 'collapse and trim all whitespace first' lines just above. my $inL = 0; DEBUG > 4 and print STDERR "Paragraph:\n$para\n\n"; - + # Here begins our frightening tokenizer RE. The following regex matches # text in four main parts: # @@ -1846,7 +2112,11 @@ sub _treelet_from_formatting_codes { | # Match multiple-bracket end codes. $3 gets the whitespace that # should be discarded before an end bracket but kept in other cases - # and $4 gets the end brackets themselves. + # and $4 gets the end brackets themselves. ($3 can be empty if the + # construct is empty, like C<< >>, and all the white-space has been + # gobbled up already, considered to be space after the opening + # bracket. In this case we use look-behind to verify that there are + # at least 2 spaces in a row before the ">".) (\s+|(?<=\s\s))(>{2,}) | (\s?>) # $5: simple end-codes @@ -1872,23 +2142,48 @@ sub _treelet_from_formatting_codes { ) { DEBUG > 4 and print STDERR "\nParagraphic tokenstack = (@stack)\n"; if(defined $1) { + my $bracket_count; # How many '<<<' in a row this has. Needed for + # Pod::Simple::JustPod if(defined $2) { DEBUG > 3 and print STDERR "Found complex start-text code \"$1\"\n"; - push @stack, length($2) + 1; - # length of the necessary complex end-code string + $bracket_count = length($2) + 1; + push @stack, $bracket_count; # length of the necessary complex + # end-code string } else { DEBUG > 3 and print STDERR "Found simple start-text code \"$1\"\n"; push @stack, 0; # signal that we're looking for simple + $bracket_count = 1; } - 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; + my $code = substr($1,0,1); + if ('L' eq $code) { + if ($inL) { + $raw .= $1; + $self->scream( $start_line, + 'Nested L<> are illegal. Pretending inner one is ' + . 'X<...> so can continue looking for other errors.'); + $code = "X"; + } + else { + $raw = ""; # reset raw content accumulator + $inL = @stack; + } } else { $raw .= $1 if $inL; } - + push @lineage, [ $code, {}, ]; # new node object + + # Tell Pod::Simple::JustPod how many brackets there were, but to save + # space, not in the most usual case of there was just 1. It can be + # inferred by the absence of this element. Similarly, if there is more + # than one bracket, extract the white space between the final bracket + # and the real beginning of the interior. Save that if it isn't just a + # single space + if ($self->{'_output_is_for_JustPod'} && $bracket_count > 1) { + $lineage[-1][1]{'~bracket_count'} = $bracket_count; + my $lspacer = substr($1, 1 + $bracket_count); + $lineage[-1][1]{'~lspacer'} = $lspacer if $lspacer ne " "; + } + push @{ $lineage[-2] }, $lineage[-1]; } elsif(defined $4) { DEBUG > 3 and print STDERR "Found apparent complex end-text code \"$3$4\"\n"; # This is where it gets messy... @@ -1917,20 +2212,35 @@ sub _treelet_from_formatting_codes { } #print STDERR "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n"; + if ($3 ne " " && $self->{'_output_is_for_JustPod'}) { + if ($3 ne "") { + $lineage[-1][1]{'~rspacer'} = $3; + } + elsif ($lineage[-1][1]{'~lspacer'} eq " ") { + + # Here we had something like C<< >> which was a false positive + delete $lineage[-1][1]{'~lspacer'}; + } + else { + $lineage[-1][1]{'~rspacer'} + = substr($lineage[-1][1]{'~lspacer'}, -1, 1); + chop $lineage[-1][1]{'~lspacer'}; + } + } + push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; # Keep the element from being childless - - pop @stack; - pop @lineage; - unless (@stack) { # not in an L if there are no open fcodes + if ($inL == @stack) { + $lineage[-1][1]{'raw'} = $raw; $inL = 0; - if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') { - $lineage[-1][-1][1]{'raw'} = $raw - } } + + pop @stack; + pop @lineage; + $raw .= $3.$4 if $inL; - + } elsif(defined $5) { DEBUG > 3 and print STDERR "Found apparent simple end-text code \"$5\"\n"; @@ -1944,6 +2254,11 @@ sub _treelet_from_formatting_codes { push @{ $lineage[-1] }, ''; # keep it from being really childless } + if ($inL == @stack) { + $lineage[-1][1]{'raw'} = $raw; + $inL = 0; + } + pop @stack; pop @lineage; } else { @@ -1951,12 +2266,6 @@ 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) { @@ -1965,6 +2274,7 @@ sub _treelet_from_formatting_codes { $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? + # Answer, because we deliberately trimmed it above } else { # should never ever ever ever happen @@ -2095,7 +2405,7 @@ sub pretty { # adopted from Class::Classless # letters, but I don't know if it has always worked without bugs. It # seemed safest just to list the characters. # s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> - s<([^ !#'()*+,\-./0123456789:;\<=\>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]^_`abcdefghijklmnopqrstuvwxyz{|}~])> + s<([^ !"#'()*+,\-./0123456789:;\<=\>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]^_`abcdefghijklmnopqrstuvwxyz{|}~])> <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg; #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg; qq{"$_"}; diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Checker.pm index 83415f8e25e..2fef0305a5c 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.35'; +$VERSION = '3.40'; @ISA = ('Pod::Simple::Methody'); BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG @@ -88,8 +88,10 @@ sub end_item_text { $_[0]->emit_par(-2) } sub emit_par { return unless $_[0]{'Errata_seen'}; my($self, $tweak_indent) = splice(@_,0,2); - my $indent = ' ' x ( 2 * $self->{'Indent'} + ($tweak_indent||0) ); + my $length = 2 * $self->{'Indent'} + ($tweak_indent||0); + my $indent = ' ' x ($length > 0 ? $length : 0); # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0 + # 'Negative repeat count does nothing' since 5.22 $self->{'Thispara'} =~ s/$Pod::Simple::shy//g; my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n"); diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm index 428cc723594..aaa5a887e6b 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Debug.pm @@ -2,7 +2,7 @@ require 5; package Pod::Simple::Debug; use strict; use vars qw($VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; 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 71bef5070be..bade6fcc472 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.35'; +$VERSION = '3.40'; 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 9d84878cb78..6f0b7b18621 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.35'; +$VERSION = '3.40'; 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 9cdbed217e5..0219b979100 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/HTML.pm @@ -9,7 +9,7 @@ use vars qw( $Doctype_decl $Content_decl ); @ISA = ('Pod::Simple::PullParser'); -$VERSION = '3.35'; +$VERSION = '3.40'; BEGIN { if(defined &DEBUG) { } # no-op elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } @@ -29,7 +29,7 @@ $LamePad = '' unless defined $LamePad; $Linearization_Limit = 120 unless defined $Linearization_Limit; # headings/items longer than that won't get an <a name="..."> -$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?' +$Perldoc_URL_Prefix = 'https://metacpan.org/pod/' unless defined $Perldoc_URL_Prefix; $Perldoc_URL_Postfix = '' unless defined $Perldoc_URL_Postfix; diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/HTMLBatch.pm index 661266d0de4..227d6d3af0d 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.35'; +$VERSION = '3.40'; @ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML! # TODO: nocontents stylesheets. Strike some of the color variations? @@ -720,22 +720,21 @@ sub _gen_css_wad { } # Now a few indexless variations: - foreach my $variation ( - 'blkbluw', # black_with_blue_on_white - 'whtpurk', # white_with_purple_on_black - 'whtgrng', # white_with_green_on_grey - 'grygrnw', # grey_with_green_on_white - ) { - my $outname = $variation; + for (my ($outfile, $variation) = each %{{ + blkbluw => 'black_with_blue_on_white', + whtpurk => 'white_with_purple_on_black', + whtgrng => 'white_with_green_on_grey', + grygrnw => 'grey_with_green_on_white', + }}) { my $this_css = join "\n", - "/* This file is autogenerated. Do not edit. $outname */\n", + "/* This file is autogenerated. Do not edit. $outfile */\n", "\@import url(\"./_$variation.css\");", ".indexgroup { display: none; }", "\n", ; - my $name = $outname; + my $name = $outfile; $name =~ tr/-_/ /; - $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); + $self->add_css( "_$outfile.css", 0, $name, 0, 0, \$this_css); } return; @@ -1110,12 +1109,15 @@ Example: =item $batchconv = Pod::Simple::HTMLBatch->new; -This TODO - +This creates a new batch converter. The method doesn't take parameters. +To change the converter's attributes, use the L<"/ACCESSOR METHODS"> +below. =item $batchconv->batch_convert( I<indirs>, I<outdir> ); -this TODO +This searches the directories given in I<indirs> and writes +HTML files for each of these to a corresponding directory +in I<outdir>. The directory I<outdir> must exist. =item $batchconv->batch_convert( undef , ...); diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/JustPod.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/JustPod.pm new file mode 100644 index 00000000000..c7ad3d69770 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/JustPod.pm @@ -0,0 +1,362 @@ +use 5; +package Pod::Simple::JustPod; +# ABSTRACT: Pod::Simple formatter that extracts POD from a file containing +# other things as well +use strict; +use warnings; + +use Pod::Simple::Methody (); +our @ISA = ('Pod::Simple::Methody'); + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + + $new->accept_targets('*'); + $new->keep_encoding_directive(1); + $new->preserve_whitespace(1); + $new->complain_stderr(1); + $new->_output_is_for_JustPod(1); + + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub check_that_all_is_closed { + + # Actually checks that the things we depend on being balanced in fact are, + # so that we can continue in spit of pod errors + + my $self = shift; + while ($self->{inL}) { + $self->end_L(@_); + } + while ($self->{fcode_end} && @{$self->{fcode_end}}) { + $self->_end_fcode(@_); + } +} + +sub handle_text { + + # Add text to the output buffer. This is skipped if within a L<>, as we use + # the 'raw' attribute of that tag instead. + + $_[0]{buffer} .= $_[1] unless $_[0]{inL} ; +} + +sub spacer { + + # Prints the white space following things like =head1. This is normally a + # blank, unless BlackBox has told us otherwise. + + my ($self, $arg) = @_; + return unless $arg; + + my $spacer = ($arg->{'~orig_spacer'}) + ? $arg->{'~orig_spacer'} + : " "; + $self->handle_text($spacer); +} + +sub _generic_start { + + # Called from tags like =head1, etc. + + my ($self, $text, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text($text); + $self->spacer($arg); +} + +sub start_Document { shift->_generic_start("=pod\n\n"); } +sub start_head1 { shift->_generic_start('=head1', @_); } +sub start_head2 { shift->_generic_start('=head2', @_); } +sub start_head3 { shift->_generic_start('=head3', @_); } +sub start_head4 { shift->_generic_start('=head4', @_); } +sub start_encoding { shift->_generic_start('=encoding', @_); } +# sub start_Para +# sub start_Verbatim + +sub start_item_bullet { # Handle =item * + my ($self, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text('=item'); + + # It can be that they said simply '=item', and it is inferred that it is to + # be a bullet. + if (! $arg->{'~orig_content'}) { + $self->handle_text("\n\n"); + } + else { + $self->spacer($arg); + if ($arg->{'~_freaky_para_hack'}) { + + # See Message Id <87y3gtcwa2.fsf@hope.eyrie.org> + my $item_text = $arg->{'~orig_content'}; + my $trailing = quotemeta $arg->{'~_freaky_para_hack'}; + $item_text =~ s/$trailing$//; + $self->handle_text($item_text); + } + else { + $self->handle_text("*\n\n"); + } + } +} + +sub start_item_number { # Handle '=item 2' + my ($self, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text("=item"); + $self->spacer($arg); + $self->handle_text("$arg->{'~orig_content'}\n\n"); +} + +sub start_item_text { # Handle '=item foo bar baz' + my ($self, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text('=item'); + $self->spacer($arg); +} + +sub _end_item { + my $self = shift; + $self->check_that_all_is_closed(); + $self->emit; +} + +*end_item_bullet = *_end_item; +*end_item_number = *_end_item; +*end_item_text = *_end_item; + +sub _start_over { # Handle =over + my ($self, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text("=over"); + + # The =over amount is optional + if ($arg->{'~orig_content'}) { + $self->spacer($arg); + $self->handle_text("$arg->{'~orig_content'}"); + } + $self->handle_text("\n\n"); +} + +*start_over_bullet = *_start_over; +*start_over_number = *_start_over; +*start_over_text = *_start_over; +*start_over_block = *_start_over; + +sub _end_over { + my $self = shift; + $self->check_that_all_is_closed(); + $self->handle_text('=back'); + $self->emit; +} + +*end_over_bullet = *_end_over; +*end_over_number = *_end_over; +*end_over_text = *_end_over; +*end_over_block = *_end_over; + +sub end_Document { + my $self = shift; + $self->emit; # Make sure buffer gets flushed + print {$self->{'output_fh'} } "=cut\n" +} + +sub _end_generic { + my $self = shift; + $self->check_that_all_is_closed(); + $self->emit; +} + +*end_head1 = *_end_generic; +*end_head2 = *_end_generic; +*end_head3 = *_end_generic; +*end_head4 = *_end_generic; +*end_encoding = *_end_generic; +*end_Para = *_end_generic; +*end_Verbatim = *_end_generic; + +sub _start_fcode { + my ($type, $self, $flags) = @_; + + # How many brackets is set by BlackBox unless the count is 1 + my $bracket_count = (exists $flags->{'~bracket_count'}) + ? $flags->{'~bracket_count'} + : 1; + $self->handle_text($type . ( "<" x $bracket_count)); + + my $rspacer = ""; + if ($bracket_count > 1) { + my $lspacer = (exists $flags->{'~lspacer'}) + ? $flags->{'~lspacer'} + : " "; + $self->handle_text($lspacer); + + $rspacer = (exists $flags->{'~rspacer'}) + ? $flags->{'~rspacer'} + : " "; + } + + # BlackBox doesn't output things for for the ending code callbacks, so save + # what we need. + push @{$self->{'fcode_end'}}, [ $bracket_count, $rspacer ]; +} + +sub start_B { _start_fcode('B', @_); } +sub start_C { _start_fcode('C', @_); } +sub start_E { _start_fcode('E', @_); } +sub start_F { _start_fcode('F', @_); } +sub start_I { _start_fcode('I', @_); } +sub start_S { _start_fcode('S', @_); } +sub start_X { _start_fcode('X', @_); } +sub start_Z { _start_fcode('Z', @_); } + +sub _end_fcode { + my $self = shift; + my $fcode_end = pop @{$self->{'fcode_end'}}; + my $bracket_count = 1; + my $rspacer = ""; + + if (! defined $fcode_end) { # If BlackBox is working, this shouldn't + # happen, but verify + $self->whine($self->{line_count}, "Extra '>'"); + } + else { + $bracket_count = $fcode_end->[0]; + $rspacer = $fcode_end->[1]; + } + + $self->handle_text($rspacer) if $bracket_count > 1; + $self->handle_text(">" x $bracket_count); +} + +*end_B = *_end_fcode; +*end_C = *_end_fcode; +*end_E = *_end_fcode; +*end_F = *_end_fcode; +*end_I = *_end_fcode; +*end_S = *_end_fcode; +*end_X = *_end_fcode; +*end_Z = *_end_fcode; + +sub start_L { + _start_fcode('L', @_); + $_[0]->handle_text($_[1]->{raw}); + $_[0]->{inL}++ +} + +sub end_L { + my $self = shift; + $self->{inL}--; + if ($self->{inL} < 0) { # If BlackBox is working, this shouldn't + # happen, but verify + $self->whine($self->{line_count}, "Extra '>' ending L<>"); + $self->{inL} = 0; + } + + $self->_end_fcode(@_); +} + +sub emit { + my $self = shift; + + if ($self->{buffer} ne "") { + print { $self->{'output_fh'} } "",$self->{buffer} ,"\n\n"; + + $self->{buffer} = ""; + } + + return; +} + +1; + +__END__ + +=head1 NAME + +Pod::Simple::JustPod -- just the Pod, the whole Pod, and nothing but the Pod + +=head1 SYNOPSIS + + my $infile = "mixed_code_and_pod.pm"; + my $outfile = "just_the_pod.pod"; + open my $fh, ">$outfile" or die "Can't write to $outfile: $!"; + + my $parser = Pod::Simple::JustPod->new(); + $parser->output_fh($fh); + $parser->parse_file($infile); + close $fh or die "Can't close $outfile: $!"; + +=head1 DESCRIPTION + +This class returns a copy of its input, translated into Perl's internal +encoding (UTF-8), and with all the non-Pod lines removed. + +This is a subclass of L<Pod::Simple::Methody> and inherits all its methods. +And since, that in turn is a subclass of L<Pod::Simple>, you can use any of +its methods. This means you can output to a string instead of a file, or +you can parse from an array. + +This class strives to return the Pod lines of the input completely unchanged, +except for any necessary translation into Perl's internal encoding, and it makes +no effort to return trailing spaces on lines; these likely will be stripped. +If the input pod is well-formed with no warnings nor errors generated, the +extracted pod should generate the same documentation when formatted by a Pod +formatter as the original file does. + +By default, warnings are output to STDERR + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::Methody> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +L<mailto:pod-people@perl.org> mail list. Send an empty email to +L<mailto:pod-people-subscribe@perl.org> to subscribe. + +This module is managed in an open GitHub repository, +L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +L<mailto:<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +Pod::Simple::JustPod was developed by John SJ Anderson +C<genehack@genehack.org>, with contributions from Karl Williamson +C<khw@cpan.org>. + +=cut diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm index 04612f202e9..b9ca19cdf93 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/LinkSection.pm @@ -2,13 +2,11 @@ require 5; package Pod::Simple::LinkSection; # Based somewhat dimly on Array::Autojoin -use vars qw($VERSION ); -$VERSION = '3.35'; use strict; use Pod::Simple::BlackBox; use vars qw($VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; 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 67b87067416..5bcee54d4f7 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.35'; +$VERSION = '3.40'; @ISA = ('Pod::Simple'); # Yes, we could use named variables, but I want this to be impose diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Progress.pm index 0c18a5b37d6..3d6f4031125 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.35'; +$VERSION = '3.40'; 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 7c326ec6aee..ceeb3f92504 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParser.pm @@ -1,6 +1,6 @@ require 5; package Pod::Simple::PullParser; -$VERSION = '3.35'; +$VERSION = '3.40'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/PullParserEndToken.pm index d3066a8e87c..d9ebdcbcf0e 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.35'; +$VERSION = '3.40'; 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 d938e0adb21..61608fb466c 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.35'; +$VERSION = '3.40'; 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 a11ce0fd92d..c8247a081e7 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.35'; +$VERSION = '3.40'; 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 c6618168e6b..f14b5637cd4 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.35'; +$VERSION = '3.40'; 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 153c3d3e287..ed0de149ae0 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/RTF.pm @@ -8,24 +8,67 @@ package Pod::Simple::RTF; use strict; use vars qw($VERSION @ISA %Escape $WRAP %Tagmap); -$VERSION = '3.35'; +$VERSION = '3.40'; use Pod::Simple::PullParser (); BEGIN {@ISA = ('Pod::Simple::PullParser')} use Carp (); BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } +sub to_uni ($) { # Convert native code point to Unicode + my $x = shift; + + # Broken for early EBCDICs + $x = chr utf8::native_to_unicode(ord $x) if $] ge 5.007_003 + && ord("A") != 65; + return $x; +} + +# We escape out 'F' so that we can send RTF files thru the mail without the +# slightest worry that paragraphs beginning with "From" will get munged. +# We also escape '\', '{', '}', and '_' +my $map_to_self = ' !"#$%&\'()*+,-./0123456789:;<=>?@ABCDEGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz|~'; + $WRAP = 1 unless defined $WRAP; +%Escape = ( + + # Start with every character mapping to its hex equivalent + map( (chr($_) => sprintf("\\'%02x", $_)), 0 .. 0xFF), + + # Override most ASCII printables with themselves (or on non-ASCII platforms, + # their ASCII values. This is because the output is UTF-16, which is always + # based on Unicode code points) + map( ( substr($map_to_self, $_, 1) + => to_uni(substr($map_to_self, $_, 1))), 0 .. length($map_to_self) - 1), + + # And some refinements: + "\r" => "\n", + "\cj" => "\n", + "\n" => "\n\\line ", + + "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay) + "\f" => "\n\\page\n", # Formfeed + "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen + $Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space + $Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen -# These are broken for early Perls on EBCDIC; they could be fixed to work -# better there, but not worth it. These are part of a larger [...] class, so -# are just the strings to substitute into it, as opposed to compiled patterns. -my $cntrl = '[:cntrl:]'; -$cntrl = '\x00-\x1F\x7F' unless eval "qr/[$cntrl]/"; + # CRAZY HACKS: + "\n" => "\\line\n", + "\r" => "\n", + "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1 + "\cc" => "}", +); -my $not_ascii = '[:^ascii:]'; -$not_ascii = '\x80-\xFF' unless eval "qr/[$not_ascii]/"; +# Generate a string of all the characters in %Escape that don't map to +# themselves. First, one without the hyphen, then one with. +my $escaped_sans_hyphen = ""; +$escaped_sans_hyphen .= $_ for grep { $_ ne $Escape{$_} && $_ ne '-' } + sort keys %Escape; +my $escaped = "-$escaped_sans_hyphen"; +# Then convert to patterns +$escaped_sans_hyphen = qr/[\Q$escaped_sans_hyphen \E]/; +$escaped= qr/[\Q$escaped\E]/; #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -158,6 +201,13 @@ sub run { #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# Match something like an identifier. Prefer XID if available, then plain ID, +# then just ASCII +my $id_re = Pod::Simple::BlackBox::my_qr('[\'_\p{XIDS}][\'\p{XIDC}]+', "ab"); +$id_re = Pod::Simple::BlackBox::my_qr('[\'_\p{IDS}][\'\p{IDC}]+', "ab") + unless $id_re; +$id_re = qr/['_a-zA-Z]['a-zA-Z0-9_]+/ unless $id_re; + sub do_middle { # the main work my $self = $_[0]; my $fh = $self->{'output_fh'}; @@ -172,7 +222,7 @@ sub do_middle { # the main work if( ($type = $token->type) eq 'text' ) { if( $self->{'rtfverbatim'} ) { DEBUG > 1 and print STDERR " $type " , $token->text, " in verbatim!\n"; - rtf_esc_codely($scratch = $token->text); + rtf_esc(0, $scratch = $token->text); # 0 => Don't escape hyphen print $fh $scratch; next; } @@ -195,13 +245,13 @@ sub do_middle { # the main work | # or starting alpha, but containing anything strange: (?: - [a-zA-Z'${not_ascii}]+[\$\@\:_<>\(\\\*]\S+ + ${id_re}[\$\@\:_<>\(\\\*]\S+ ) ) /\cb$1\cc/xsg ; - rtf_esc($scratch); + rtf_esc(1, $scratch); # 1 => escape hyphen $scratch =~ s/( [^\r\n]{65} # Snare 65 characters from a line @@ -311,7 +361,7 @@ sub do_middle { # the main work print $fh $token->attr('number'), ". \n"; } elsif ($tagname eq 'item-bullet') { print $fh "\\'", ord("_"), "\n"; - #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}"); + #for funky testing: print $fh '', rtf_esc(1, "\x{4E4B}\x{9053}"); } } elsif( $type eq 'end' ) { @@ -465,7 +515,7 @@ sub doc_start { # catches the most common case, at least DEBUG and print STDERR "Title0: <$title>\n"; - $title = rtf_esc($title); + $title = rtf_esc(1, $title); # 1 => escape hyphen DEBUG and print STDERR "Title1: <$title>\n"; $title = '\lang1024\noproof ' . $title if $is_obviously_module_name; @@ -489,90 +539,69 @@ END #------------------------------------------------------------------------- use integer; -sub rtf_esc { - my $x; # scratch - if(!defined wantarray) { # void context: alter in-place! - for(@_) { - s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; - } - return; - } elsif(wantarray) { # return an array - return map {; ($x = $_) =~ - s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; - $x; - } @_; - } else { # return a single scalar - ($x = ((@_ == 1) ? $_[0] : join '', @_) - ) =~ s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - # Escape \, {, }, -, control chars, and 7f-ff. - $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + +my $question_mark_code_points = + Pod::Simple::BlackBox::my_qr('([^\x00-\x{D7FF}\x{E000}-\x{10FFFF}])', + "\x{110000}"); +my $plane0 = + Pod::Simple::BlackBox::my_qr('([\x{100}-\x{FFFF}])', "\x{100}"); +my $other_unicode = + Pod::Simple::BlackBox::my_qr('([\x{10000}-\x{10FFFF}])', "\x{10000}"); + +sub esc_uni($) { + use if $] le 5.006002, 'utf8'; + + my $x = shift; + + # The output is expected to be UTF-16. Surrogates and above-Unicode get + # mapped to '?' + $x =~ s/$question_mark_code_points/?/g if $question_mark_code_points; + + # Non-surrogate Plane 0 characters get mapped to their code points. But + # the standard calls for a 16bit SIGNED value. + $x =~ s/$plane0/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg + if $plane0; + + # Use surrogate pairs for the rest + $x =~ s/$other_unicode/'\\uc1\\u' . ((ord($1) >> 10) + 0xD7C0 - 65536) . '\\u' . (((ord$1) & 0x03FF) + 0xDC00 - 65536) . '?'/eg if $other_unicode; + return $x; - } } -sub rtf_esc_codely { - # Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts. - # We don't want to change the "-" to hard-hyphen, because we want to +sub rtf_esc ($$) { + # The parameter is true if we should escape hyphens + my $escape_re = ((shift) ? $escaped : $escaped_sans_hyphen); + + # When false, it doesn't change "-" to hard-hyphen. + # We don't want to change the "-" to hard-hyphen, because we want to # be able to paste this into a file and run it without there being # dire screaming about the mysterious hard-hyphen character (which # looks just like a normal dash character). - + # XXX The comments used to claim that when false it didn't apply computerese + # style-smarts, but khw didn't see this actually + my $x; # scratch if(!defined wantarray) { # void context: alter in-place! for(@_) { - s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + s/($escape_re)/$Escape{$1}/g; # ESCAPER + $_ = esc_uni($_); } return; } elsif(wantarray) { # return an array return map {; ($x = $_) =~ - s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + s/($escape_re)/$Escape{$1}/g; # ESCAPER + $x = esc_uni($x); $x; } @_; } else { # return a single scalar ($x = ((@_ == 1) ? $_[0] : join '', @_) - ) =~ s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER + ) =~ s/($escape_re)/$Escape{$1}/g; # ESCAPER # Escape \, {, }, -, control chars, and 7f-ff. - $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + $x = esc_uni($x); return $x; } } -%Escape = ( - (($] lt 5.007_003) # Broken for non-ASCII on early Perls - ? (map( (chr($_),chr($_)), # things not apparently needing escaping - 0x20 .. 0x7E ), - map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things - 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46)) - : (map( (chr(utf8::unicode_to_native($_)),chr(utf8::unicode_to_native($_))), - 0x20 .. 0x7E ), - map( (chr($_),sprintf("\\'%02x", utf8::unicode_to_native($_))), - 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))), - - # We get to escape out 'F' so that we can send RTF files thru the mail - # without the slightest worry that paragraphs beginning with "From" - # will get munged. - - # And some refinements: - "\r" => "\n", - "\cj" => "\n", - "\n" => "\n\\line ", - - "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay) - "\f" => "\n\\page\n", # Formfeed - "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen - $Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space - $Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen - - # CRAZY HACKS: - "\n" => "\\line\n", - "\r" => "\n", - "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1 - "\cc" => "}", -); 1; __END__ diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm index df499cacf2d..a07d33b85ac 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Search.pm @@ -3,7 +3,7 @@ package Pod::Simple::Search; use strict; use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY); -$VERSION = '3.35'; ## Current version of this package +$VERSION = '3.40'; ## Current version of this package BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level use Carp (); @@ -12,7 +12,6 @@ $SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; # flag to occasionally sleep for $SLEEPY - 1 seconds. $MAX_VERSION_WITHIN ||= 60; -my $IS_CASE_INSENSITIVE = -e uc __FILE__ && -e lc __FILE__; ############################################################################# @@ -26,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', 'recurse', - 'ciseen' + 'ciseen', 'is_case_insensitive' ); #========================================================================== @@ -42,6 +41,7 @@ sub init { $self->inc(1); $self->recurse(1); $self->verbose(DEBUG); + $self->is_case_insensitive(-e uc __FILE__ && -e lc __FILE__); return $self; } @@ -130,12 +130,12 @@ sub _make_search_callback { # Put the options in variables, for easy access my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress, - $path2name, $name2path, $recurse, $ciseen) = + $path2name, $name2path, $recurse, $ciseen, $is_case_insensitive) = map scalar($self->$_()), qw(laborious verbose shadows limit_re callback progress - path2name name2path recurse ciseen); + path2name name2path recurse ciseen is_case_insensitive); my ($seen, $remember, $files_for); - if ($IS_CASE_INSENSITIVE) { + if ($is_case_insensitive) { $seen = sub { $ciseen->{ lc $_[0] } }; $remember = sub { $name2path->{ $_[0] } = $ciseen->{ lc $_[0] } = $_[1]; }; $files_for = sub { my $n = lc $_[0]; grep { lc $path2name->{$_} eq $n } %{ $path2name } }; @@ -259,7 +259,7 @@ sub _path2modname { while(@m and defined($x = lc( $m[0] )) and( $x eq 'site_perl' - or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s ) + or($x =~ m/^pods?$/ and @m == 1 and $shortname =~ m{^perl.*\.pod$}s ) or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum or $x eq lc( $Config::Config{'archname'} ) )) { shift @m } @@ -546,7 +546,7 @@ sub _limit_glob_to_limit_re { sub _actual_filenames { my $dir = shift; my $fn = lc shift; - opendir my $dh, $dir or return; + opendir my ($dh), $dir or return; return map { File::Spec->catdir($dir, $_) } grep { lc $_ eq $fn } readdir $dh; } @@ -588,7 +588,7 @@ sub find { my $fullext = $fullname . $ext; if ( -f $fullext and $self->contains_pod($fullext) ) { print "FOUND: $fullext\n" if $verbose; - if (@parts > 1 && lc $parts[0] eq 'pod' && $IS_CASE_INSENSITIVE && $ext eq '.pod') { + if (@parts > 1 && lc $parts[0] eq 'pod' && $self->is_case_insensitive() && $ext eq '.pod') { # Well, this file could be for a program (perldoc) but we actually # want a module (Pod::Perldoc). So see if there is a .pm with the # proper casing. @@ -611,7 +611,7 @@ sub find { } # Case-insensitively Look for ./pod directories and slip them in. - for my $subdir ( _actual_filenames($dir, 'pod') ) { + for my $subdir ( _actual_filenames($dir, 'pods'), _actual_filenames($dir, 'pod') ) { if (-d $subdir) { $verbose and print "Noticing $subdir and looking there...\n"; unshift @search_dirs, $subdir; @@ -849,6 +849,20 @@ inspected too, and are noted in the pathname2podname return hash. This attribute's default value is false; and normally you won't need to turn it on. +=item $search->is_case_insensitive( I<true-or-false> ); + +Pod::Simple::Search will by default internally make an assumption +based on the underlying filesystem where the class file is found +whether it is case insensitive or not. + +If it is determined to be case insensitive, during survey() it may +skip pod files/modules that happen to be equal to names it's already +seen, ignoring case. + +However, it's possible to have distinct files in different directories +that intentionally has the same name, just differing in case, that should +be reported. Hence, you may force the behavior by setting this to true +or false. =item $search->limit_re( I<some-regxp> ); @@ -857,7 +871,6 @@ to limit the results just to items whose podnames match the given regexp. Normally this option is not needed, and the more efficient C<limit_glob> attribute is used instead. - =item $search->dir_prefix( I<some-string-value> ); Setting this attribute to a string value means that the searches should diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm index bff5af84c4b..85dbabcd70e 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/SimpleTree.pm @@ -5,7 +5,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); -$VERSION = '3.35'; +$VERSION = '3.40'; 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 88f85e86de2..f9cb09a52ef 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Subclassing.pod @@ -98,9 +98,14 @@ nodes that represent preformatted text (from verbatim sections). TODO intro... mention that events are supplied for implicits, like for missing >'s - In the following section, we use XML to represent the event structure -associated with a particular construct. That is, TODO +associated with a particular construct. That is, an opening tag +represents the element start, the attributes of that opening tag are +the attributes given to the callback, and the closing tag represents +the end element. + +Three callback methods must be supplied by a class extending +L<Pod::Simple> to receive the corresponding event: =over @@ -112,8 +117,9 @@ associated with a particular construct. That is, TODO =back -TODO describe - +Here's the comprehensive list of values you can expect as +I<element_name> in your implementation of C<_handle_element_start> +and C<_handle_element_end>:: =over diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Text.pm index 66e15f48cce..de50b510eae 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.35'; +$VERSION = '3.40'; @ISA = ('Pod::Simple::Methody'); BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/TextContent.pm index 980612b3132..ad4172b7a31 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.35'; +$VERSION = '3.40'; @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 a7364dfa585..0dd12c412dd 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.35'; +$VERSION = '3.40'; #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm index a4bb29ffdb6..eb127022827 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Simple/Transcode.pm @@ -3,7 +3,7 @@ require 5; package Pod::Simple::Transcode; use strict; use vars qw($VERSION @ISA); -$VERSION = '3.35'; +$VERSION = '3.40'; 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 c2069056574..2b675ccb787 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.35'; +$VERSION = '3.40'; # 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 e4d4f7eb60e..99f55683ab3 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.35'; +$VERSION = '3.40'; 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 8c2cf1a01ba..b9c6269bf98 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.35'; +$VERSION = '3.40'; use Pod::Simple::Methody (); @ISA = ('Pod::Simple::Methody'); @@ -92,7 +92,7 @@ the call to C<parse_file>: In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what to put before the "Foo%3a%3aBar". The default value is -"http://search.cpan.org/perldoc?". +"https://metacpan.org/pod/". =head2 perldoc_url_postfix @@ -247,7 +247,7 @@ sub new { my $self = shift; my $new = $self->SUPER::new(@_); $new->{'output_fh'} ||= *STDOUT{IO}; - $new->perldoc_url_prefix('http://search.cpan.org/perldoc?'); + $new->perldoc_url_prefix('https://metacpan.org/pod/'); $new->man_url_prefix('http://man.he.net/man'); $new->html_charset('ISO-8859-1'); $new->nix_X_codes(1); @@ -685,8 +685,8 @@ sub emit { Resolves a POD link target (typically a module or POD file name) and section name to a URL. The resulting link will be returned for the above examples as: - http://search.cpan.org/perldoc?Net::Ping#INSTALL - http://search.cpan.org/perldoc?perlpodspec + https://metacpan.org/pod/Net::Ping#INSTALL + https://metacpan.org/pod/perlpodspec #SYNOPSIS Note that when there is only a section argument the URL will simply be a link diff --git a/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm b/Master/tlpkg/tlperl/lib/Pod/Simple/XMLOutStream.pm index 62fe39549da..cb818a17409 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.35'; +$VERSION = '3.40'; BEGIN { @ISA = ('Pod::Simple'); *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; diff --git a/Master/tlpkg/tlperl/lib/Pod/Text.pm b/Master/tlpkg/tlperl/lib/Pod/Text.pm index b05730ef476..56e6e78a86c 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Text.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Text.pm @@ -14,7 +14,7 @@ package Pod::Text; -use 5.006; +use 5.008; use strict; use warnings; @@ -30,7 +30,7 @@ use Pod::Simple (); # We have to export pod2text for backward compatibility. @EXPORT = qw(pod2text); -$VERSION = '4.11'; +$VERSION = '4.14'; # Ensure that $Pod::Simple::nbsp and $Pod::Simple::shy are available. Code # taken from Pod::Simple 3.32, but was only added in 3.30. @@ -39,16 +39,8 @@ if ($Pod::Simple::VERSION ge 3.30) { $NBSP = $Pod::Simple::nbsp; $SHY = $Pod::Simple::shy; } else { - if ($] ge 5.007_003) { - $NBSP = chr utf8::unicode_to_native(0xA0); - $SHY = chr utf8::unicode_to_native(0xAD); - } elsif (Pod::Simple::ASCII) { - $NBSP = "\xA0"; - $SHY = "\xAD"; - } else { - $NBSP = "\x41"; - $SHY = "\xCA"; - } + $NBSP = chr utf8::unicode_to_native(0xA0); + $SHY = chr utf8::unicode_to_native(0xAD); } ############################################################################## @@ -247,7 +239,7 @@ sub wrap { my $spaces = ' ' x $$self{MARGIN}; my $width = $$self{opt_width} - $$self{MARGIN}; while (length > $width) { - if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) { + if (s/^([^\n]{0,$width})[ \t\n]+// || s/^([^\n]{$width})//) { $output .= $spaces . $1 . "\n"; } else { last; @@ -265,14 +257,16 @@ sub reformat { local $_ = shift; # If we're trying to preserve two spaces after sentences, do some munging - # to support that. Otherwise, smash all repeated whitespace. + # to support that. Otherwise, smash all repeated whitespace. Be careful + # not to use \s here, which in Unicode input may match non-breaking spaces + # that we don't want to smash. if ($$self{opt_sentence}) { s/ +$//mg; s/\.\n/. \n/g; s/\n/ /g; s/ +/ /g; } else { - s/\s+/ /g; + s/[ \t\n]+/ /g; } return $self->wrap ($_); } @@ -333,15 +327,14 @@ sub start_document { # When UTF-8 output is set, check whether our output file handle already # has a PerlIO encoding layer set. If it does not, we'll need to encode - # our output before printing it (handled in the output() sub). Wrap the - # check in an eval to handle versions of Perl without PerlIO. + # our output before printing it (handled in the output() sub). $$self{ENCODE} = 0; if ($$self{opt_utf8}) { $$self{ENCODE} = 1; eval { my @options = (output => 1, details => 1); my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1]; - if ($flag & PerlIO::F_UTF8 ()) { + if ($flag && ($flag & PerlIO::F_UTF8 ())) { $$self{ENCODE} = 0; $$self{ENCODING} = 'UTF-8'; } @@ -919,7 +912,9 @@ being the file to write the formatted output to. You can also call parse_lines() to parse an array of lines or parse_string_document() to parse a document already in memory. As with parse_file(), parse_lines() and parse_string_document() default to sending -their output to C<STDOUT> unless changed with the output_fh() method. +their output to C<STDOUT> unless changed with the output_fh() method. Be +aware that parse_lines() and parse_string_document() both expect raw bytes, +not decoded characters. To put the output from any parse method into a string instead of a file handle, call the output_string() method instead of output_fh(). @@ -1006,7 +1001,7 @@ how to use Pod::Simple. =head1 COPYRIGHT AND LICENSE -Copyright 1999-2002, 2004, 2006, 2008-2009, 2012-2016, 2018 Russ Allbery +Copyright 1999-2002, 2004, 2006, 2008-2009, 2012-2016, 2018-2019 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm index 8d956f2a5dd..5d47c5ecb3b 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Color.pm @@ -12,7 +12,7 @@ package Pod::Text::Color; -use 5.006; +use 5.008; use strict; use warnings; @@ -23,7 +23,7 @@ use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); -$VERSION = '4.11'; +$VERSION = '4.14'; ############################################################################## # Overrides @@ -97,9 +97,6 @@ sub wrap { # $shortchar matches some sequence of $char ending in codes followed by # whitespace or the end of the string. $longchar matches exactly $width # $chars, used when we have to truncate and hard wrap. - # - # $shortchar and $longchar are created in a slightly odd way because the - # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x. my $code = '(?:\e\[[\d;]+m)'; my $char = "(?>$code*[^\\n])"; my $shortchar = '^(' . $char . "{0,$width}(?>$code*)" . ')(?:\s+|\z)'; @@ -185,7 +182,7 @@ Russ Allbery <rra@cpan.org>. =head1 COPYRIGHT AND LICENSE -Copyright 1999, 2001, 2004, 2006, 2008, 2009, 2018 Russ Allbery +Copyright 1999, 2001, 2004, 2006, 2008, 2009, 2018-2019 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm index 92a3a9330e0..53bc6afef23 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Overstrike.pm @@ -19,7 +19,7 @@ package Pod::Text::Overstrike; -use 5.006; +use 5.008; use strict; use warnings; @@ -29,7 +29,7 @@ use Pod::Text (); @ISA = qw(Pod::Text); -$VERSION = '4.11'; +$VERSION = '4.14'; ############################################################################## # Overrides @@ -185,7 +185,7 @@ created by Russ Allbery <rra@cpan.org>. Subsequently updated by Russ Allbery. Copyright 2000 by Joe Smith <Joe.Smith@inwap.com> -Copyright 2001, 2004, 2008, 2014, 2018 by Russ Allbery <rra@cpan.org> +Copyright 2001, 2004, 2008, 2014, 2018-2019 by Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm b/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm index d36ba4f518a..be218f0bf04 100644 --- a/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm +++ b/Master/tlpkg/tlperl/lib/Pod/Text/Termcap.pm @@ -12,7 +12,7 @@ package Pod::Text::Termcap; -use 5.006; +use 5.008; use strict; use warnings; @@ -24,7 +24,7 @@ use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); -$VERSION = '4.11'; +$VERSION = '4.14'; ############################################################################## # Overrides @@ -36,14 +36,6 @@ sub new { my ($self, %args) = @_; my ($ospeed, $term, $termios); - # $ENV{HOME} is usually not set on Windows. The default Term::Cap path - # may not work on Solaris. - unless (exists $ENV{TERMPATH}) { - my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : ''; - $ENV{TERMPATH} = - "${home}/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap"; - } - # Fall back on a hard-coded terminal speed if POSIX::Termios isn't # available (such as on VMS). eval { $termios = POSIX::Termios->new }; @@ -80,10 +72,12 @@ sub new { # Initialize Pod::Text. $self = $self->SUPER::new (%args); - # Fall back on the ANSI escape sequences if Term::Cap doesn't work. - $$self{BOLD} = $bold || "\e[1m"; - $$self{UNDL} = $undl || "\e[4m"; - $$self{NORM} = $norm || "\e[m"; + # If we were unable to get any of the formatting sequences, don't attempt + # that type of formatting. This will do weird things if bold or underline + # were available but normal wasn't, but hopefully that will never happen. + $$self{BOLD} = $bold || q{}; + $$self{UNDL} = $undl || q{}; + $$self{NORM} = $norm || q{}; return $self; } @@ -106,11 +100,19 @@ sub cmd_head2 { sub cmd_b { my $self = shift; return "$$self{BOLD}$_[1]$$self{NORM}" } sub cmd_i { my $self = shift; return "$$self{UNDL}$_[1]$$self{NORM}" } +# Return a regex that matches a formatting sequence. This will only be valid +# if we were able to get at least some termcap information. +sub format_regex { + my ($self) = @_; + my @codes = ($self->{BOLD}, $self->{UNDL}, $self->{NORM}); + return join(q{|}, map { $_ eq q{} ? () : "\Q$_\E" } @codes); +} + # Analyze a single line and return any formatting codes in effect at the end # of that line. sub end_format { my ($self, $line) = @_; - my $pattern = "(\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)"; + my $pattern = "(" . $self->format_regex() . ")"; my $current; while ($line =~ /$pattern/g) { my $code = $1; @@ -147,15 +149,17 @@ sub wrap { my $spaces = ' ' x $$self{MARGIN}; my $width = $$self{opt_width} - $$self{MARGIN}; + # If we were unable to find any termcap sequences, use Pod::Text wrapping. + if ($self->{BOLD} eq q{} && $self->{UNDL} eq q{} && $self->{NORM} eq q{}) { + return $self->SUPER::wrap($_); + } + # $code matches a single special sequence. $char matches any number of # special sequences preceding a single character other than a newline. # $shortchar matches some sequence of $char ending in codes followed by # whitespace or the end of the string. $longchar matches exactly $width # $chars, used when we have to truncate and hard wrap. - # - # $shortchar and $longchar are created in a slightly odd way because the - # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x. - my $code = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)"; + my $code = "(?:" . $self->format_regex() . ")"; my $char = "(?>$code*[^\\n])"; my $shortchar = '^(' . $char . "{0,$width}(?>$code*)" . ')(?:\s+|\z)'; my $longchar = '^(' . $char . "{$width})"; @@ -225,34 +229,20 @@ text using the correct termcap escape sequences for the current terminal. Apart from the format codes, it in all ways functions like Pod::Text. See L<Pod::Text> for details and available options. -=head1 ENVIRONMENT - -This module sets the TERMPATH environment variable globally to: - - $HOME/.termcap:/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap - -if it isn't already set. (The first entry is omitted if the HOME -environment variable isn't set.) This is a (very old) workaround for -problems finding termcap information on older versions of Solaris, and is -not good module behavior. Please do not rely on this behavior; it may be -dropped in a future release. - -=head1 NOTES - -This module uses Term::Cap to retrieve the formatting escape sequences for -the current terminal, and falls back on the ECMA-48 (the same in this -regard as ANSI X3.64 and ISO 6429, the escape codes also used by DEC VT100 -terminals) if the bold, underline, and reset codes aren't set in the -termcap information. +This module uses L<Term::Cap> to find the correct terminal settings. See the +documentation of that module for how it finds terminal database information +and how to override that behavior if necessary. If unable to find control +strings for bold and underscore formatting, that formatting is skipped, +resulting in the same output as Pod::Text. =head1 AUTHOR -Russ Allbery <rra@cpan.org>. +Russ Allbery <rra@cpan.org> =head1 COPYRIGHT AND LICENSE -Copyright 1999, 2001-2002, 2004, 2006, 2008-2009, 2014-2015, 2018 Russ Allbery -<rra@cpan.org> +Copyright 1999, 2001-2002, 2004, 2006, 2008-2009, 2014-2015, 2018-2019 Russ +Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. |