diff options
author | Norbert Preining <preining@logic.at> | 2008-03-29 14:28:19 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2008-03-29 14:28:19 +0000 |
commit | d4eedbeb6301b3ed03a6b6f703020f7dc5dcdc63 (patch) | |
tree | 2e75e7be0a5c8389343b511710f59c3e87dd65d9 /Master/tlpkg/installer | |
parent | 90c3bb4dc0c455df131af548a15d4cf875a86708 (diff) |
too many changes, see email, basically tl.-package-manager work
git-svn-id: svn://tug.org/texlive/trunk@7221 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/installer')
-rw-r--r-- | Master/tlpkg/installer/install-menu-perltk.pl | 47 | ||||
-rwxr-xr-x | Master/tlpkg/installer/install-menu-text.pl | 7 | ||||
-rw-r--r-- | Master/tlpkg/installer/lang/perltk-de | 6 | ||||
-rw-r--r-- | Master/tlpkg/installer/lang/perltk-en.sample | 2 | ||||
-rw-r--r-- | Master/tlpkg/installer/lang/perltk-pl | 2 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/File/Spec.pm | 322 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/File/Spec/Unix.pm | 510 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/File/Spec/Win32.pm | 369 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/Pod/InputObjects.pm | 941 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/Pod/ParseLink.pm | 184 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/Pod/Parser.pm | 1799 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/Pod/Select.pm | 754 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/Pod/Text.pm | 848 | ||||
-rw-r--r-- | Master/tlpkg/installer/perllib/Pod/Usage.pm | 659 |
14 files changed, 6423 insertions, 27 deletions
diff --git a/Master/tlpkg/installer/install-menu-perltk.pl b/Master/tlpkg/installer/install-menu-perltk.pl index 67dbed6a8e2..169b1388126 100644 --- a/Master/tlpkg/installer/install-menu-perltk.pl +++ b/Master/tlpkg/installer/install-menu-perltk.pl @@ -20,7 +20,6 @@ our @collections_lang; our @collections_lang_doc; our $texlive_release; our $trynet; -our $max_bins_on_CD; our $MENU_INSTALL = 0; our $MENU_ABORT = 1; @@ -35,25 +34,29 @@ require Tk::PNG; use utf8; no utf8; -if ($^O =~ /^MSWin(32|64)$/i) { - # trying to deduce automatically the country code - my $foo = TeXLive::TLWinGoo::reg_country(); - if ($foo) { - $::lang = $foo; - } else { - tllog($::LOG_DEBUG, "Didn't get any usuful code from reg_country: $foo...\n"); - } +if (defined($::opt_lang)) { + $::lang = $::opt_lang; } else { - # we load POSIX and locale stuff - require POSIX; - import POSIX qw/locale_h/; - # now we try to deduce $::lang - my $loc = setlocale(&POSIX::LC_CTYPE); - my ($lang,$area,$codeset); - if ($loc =~ m/^([^_.]*)(_([^.]*))?(\.([^@]*))?(@.*)?$/) { - $lang = defined($1)?$1:""; + if ($^O =~ /^MSWin(32|64)$/i) { + # trying to deduce automatically the country code + my $foo = TeXLive::TLWinGoo::reg_country(); + if ($foo) { + $::lang = $foo; + } else { + tllog($::LOG_DEBUG, "Didn't get any usuful code from reg_country: $foo...\n"); + } + } else { + # we load POSIX and locale stuff + require POSIX; + import POSIX qw/locale_h/; + # now we try to deduce $::lang + my $loc = setlocale(&POSIX::LC_CTYPE); + my ($lang,$area,$codeset); + if ($loc =~ m/^([^_.]*)(_([^.]*))?(\.([^@]*))?(@.*)?$/) { + $lang = defined($1)?$1:""; + } + $::lang = $lang if ($lang); } - $::lang = $lang if ($lang); } my $mw; @@ -138,6 +141,8 @@ my %text = ( title => 'TeX Live 2008 Installation', diskreq => 'disk space required', yes => 'Yes', no => 'No', + notwritable => '(default not writable - please change!)', + changetexdir => '(please change TEXDIR first!)' ); @@ -635,7 +640,7 @@ sub menu_set_pathes_text { if (TeXLive::TLUtils::texdir_check($vars{'TEXDIR'})) { menu_set_text($texdirtext, "$vars{'TEXDIR'}"); } else { - menu_set_text($texdirtext, "(default not writable - please change!)"); + menu_set_text($texdirtext, $text{'notwritable'}); } menu_set_text($texmflocaltext, "$vars{'TEXMFLOCAL'}"); if (-w $vars{'TEXMFSYSVAR'}) { @@ -644,10 +649,10 @@ sub menu_set_pathes_text { if (TeXLive::TLUtils::texdir_check($vars{'TEXDIR'})) { menu_set_text($texmfsysvartext, "$vars{'TEXMFSYSVAR'}"); } else { - menu_set_text($texmfsysvartext, "(please change TEXDIR first!)"); + menu_set_text($texmfsysvartext, $text{'changetexdir'}); } } else { - menu_set_text($texmfsysvartext, "(default not writable - please change!)"); + menu_set_text($texmfsysvartext, $text{'notwritable'}); } menu_set_text($texmfhometext, "$vars{'TEXMFHOME'}"); } diff --git a/Master/tlpkg/installer/install-menu-text.pl b/Master/tlpkg/installer/install-menu-text.pl index 88ed73355e7..c3d01a7a885 100755 --- a/Master/tlpkg/installer/install-menu-text.pl +++ b/Master/tlpkg/installer/install-menu-text.pl @@ -17,7 +17,6 @@ our @collections_lang; our @collections_lang_doc; our $texlive_release; our $trynet; -our $max_bins_on_CD; my $MENU_CONTINUE = -1; our $MENU_INSTALL = 0; @@ -137,10 +136,10 @@ sub binary_menu { } $diskbin=' ' - if (media eq 'CD' and $vars{'n_systems_available'}>$max_bins_on_CD); + if (media eq 'CD' and $vars{'n_systems_available'}>$MaxBinOnCD); foreach my $binary (@binaries) { - if (media eq 'CD' and $vars{'n_systems_available'}>$max_bins_on_CD) { + if (media eq 'CD' and $vars{'n_systems_available'}>$MaxBinOnCD) { $diskbin=$from_net{"$binary"}? "* ":" "; } printf " %s %s %s%-16s %s\n", $keys[$index], @@ -152,7 +151,7 @@ sub binary_menu { "netbin_$binary":"diskbin_$binary"; ++$index; } - if ($vars{'n_systems_available'}<=$max_bins_on_CD ) { + if ($vars{'n_systems_available'}<=$MaxBinOnCD ) { print "\n Binaries for additional systems are available on the DVD.\n" . " If you have network access, try option <N>.\n"; diff --git a/Master/tlpkg/installer/lang/perltk-de b/Master/tlpkg/installer/lang/perltk-de index 0d59792da7d..987b605cf3d 100644 --- a/Master/tlpkg/installer/lang/perltk-de +++ b/Master/tlpkg/installer/lang/perltk-de @@ -1,5 +1,6 @@ # -# german strings for texlive installer +# German strings for texlive installer +# Norbert Preining # text.title: TeX Live 2008 Installation text.custom: Weitere Einstellungen @@ -37,6 +38,9 @@ text.collof: Sammlungen von text.diskreq: benötigter Festplattenplatz text.yes: Ja text.no: Nein +text.notwritable: (Vorgabe ohne Schreibberechtigung - bitte ändern!) +text.changetexdir: (Bitte zuerst TEXDIR ändern!) + label.scheme: Ausgewähltes Schema label.stdcoll: Standardsammlungen diff --git a/Master/tlpkg/installer/lang/perltk-en.sample b/Master/tlpkg/installer/lang/perltk-en.sample index 7683178f5bc..08d91e8a9b2 100644 --- a/Master/tlpkg/installer/lang/perltk-en.sample +++ b/Master/tlpkg/installer/lang/perltk-en.sample @@ -41,6 +41,8 @@ text.collof: collections out of text.diskreq: disk space required text.yes: Yes text.no: No +text.notwritable: (default not writable - please change!) +text.changetexdir: (please change TEXDIR first!) label.binsys: Binary System(s) label.scheme: Selected Scheme diff --git a/Master/tlpkg/installer/lang/perltk-pl b/Master/tlpkg/installer/lang/perltk-pl index 5923594d7d0..cd26bb1b18d 100644 --- a/Master/tlpkg/installer/lang/perltk-pl +++ b/Master/tlpkg/installer/lang/perltk-pl @@ -1,5 +1,5 @@ # -# install-menu-perltk-pl.pl +# Polish strings for texlive installer # Jerzy B. Ludwichowski # text.title: Instalowanie TeX Live 2008 diff --git a/Master/tlpkg/installer/perllib/File/Spec.pm b/Master/tlpkg/installer/perllib/File/Spec.pm new file mode 100644 index 00000000000..0c8cd21e057 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec.pm @@ -0,0 +1,322 @@ +package File::Spec; + +use strict; +use vars qw(@ISA $VERSION); + +$VERSION = '3.12'; +$VERSION = eval $VERSION; + +my %module = (MacOS => 'Mac', + MSWin32 => 'Win32', + os2 => 'OS2', + VMS => 'VMS', + epoc => 'Epoc', + NetWare => 'Win32', # Yes, File::Spec::Win32 works on NetWare. + symbian => 'Win32', # Yes, File::Spec::Win32 works on symbian. + dos => 'OS2', # Yes, File::Spec::OS2 works on DJGPP. + cygwin => 'Cygwin'); + + +my $module = $module{$^O} || 'Unix'; + +require "File/Spec/$module.pm"; +@ISA = ("File::Spec::$module"); + +1; + +__END__ + +=head1 NAME + +File::Spec - portably perform operations on file names + +=head1 SYNOPSIS + + use File::Spec; + + $x=File::Spec->catfile('a', 'b', 'c'); + +which returns 'a/b/c' under Unix. Or: + + use File::Spec::Functions; + + $x = catfile('a', 'b', 'c'); + +=head1 DESCRIPTION + +This module is designed to support operations commonly performed on file +specifications (usually called "file names", but not to be confused with the +contents of a file, or Perl's file handles), such as concatenating several +directory and file names into a single path, or determining whether a path +is rooted. It is based on code directly taken from MakeMaker 5.17, code +written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya +Zakharevich, Paul Schinder, and others. + +Since these functions are different for most operating systems, each set of +OS specific routines is available in a separate module, including: + + File::Spec::Unix + File::Spec::Mac + File::Spec::OS2 + File::Spec::Win32 + File::Spec::VMS + +The module appropriate for the current OS is automatically loaded by +File::Spec. Since some modules (like VMS) make use of facilities available +only under that OS, it may not be possible to load all modules under all +operating systems. + +Since File::Spec is object oriented, subroutines should not be called directly, +as in: + + File::Spec::catfile('a','b'); + +but rather as class methods: + + File::Spec->catfile('a','b'); + +For simple uses, L<File::Spec::Functions> provides convenient functional +forms of these methods. + +=head1 METHODS + +=over 2 + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. + + $cpath = File::Spec->canonpath( $path ) ; + +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + +=item catdir + +Concatenate two or more directory names to form a complete path ending +with a directory. But remove the trailing slash from the resulting +string, because it doesn't look good, isn't necessary and confuses +OS/2. Of course, if this is the root directory, don't cut off the +trailing slash :-) + + $path = File::Spec->catdir( @directories ); + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + + $path = File::Spec->catfile( @directories, $filename ); + +=item curdir + +Returns a string representation of the current directory. + + $curdir = File::Spec->curdir(); + +=item devnull + +Returns a string representation of the null device. + + $devnull = File::Spec->devnull(); + +=item rootdir + +Returns a string representation of the root directory. + + $rootdir = File::Spec->rootdir(); + +=item tmpdir + +Returns a string representation of the first writable directory from a +list of possible temporary directories. Returns the current directory +if no writable temporary directories are found. The list of directories +checked depends on the platform; e.g. File::Spec::Unix checks C<$ENV{TMPDIR}> +(unless taint is on) and F</tmp>. + + $tmpdir = File::Spec->tmpdir(); + +=item updir + +Returns a string representation of the parent directory. + + $updir = File::Spec->updir(); + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + + @paths = File::Spec->no_upwards( @paths ); + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +case is not or is significant when comparing file specifications. + + $is_case_tolerant = File::Spec->case_tolerant(); + +=item file_name_is_absolute + +Takes as its argument a path, and returns true if it is an absolute path. + + $is_absolute = File::Spec->file_name_is_absolute( $path ); + +This does not consult the local filesystem on Unix, Win32, OS/2, or +Mac OS (Classic). It does consult the working environment for VMS +(see L<File::Spec::VMS/file_name_is_absolute>). + +=item path + +Takes no argument. Returns the environment variable C<PATH> (or the local +platform's equivalent) as a list. + + @PATH = File::Spec->path(); + +=item join + +join is the same as catfile. + +=item splitpath + +Splits a path in to volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless C<$no_file> is true or a +trailing separator or F</.> or F</..> is present. On Unix, this means that C<$no_file> +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=item splitdir + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +C<$directories> must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSes. + +=item catpath() + +Takes volume, directory and file portions and returns an entire path. Under +Unix, C<$volume> is ignored, and directory and file are concatenated. A '/' is +inserted if need be. On other OSes, C<$volume> is significant. + + $full_path = File::Spec->catpath( $volume, $directory, $file ); + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +If C<$base> is not present or '', then L<cwd()|Cwd> is used. If C<$base> is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems with the concept of volume, if C<$path> and C<$base> appear to be +on two different volumes, we will not attempt to resolve the two +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in +garbage results part of the time. + +On systems that have a grammar that indicates filenames, this ignores the +C<$base> filename as well. Otherwise all path components are assumed to be +directories. + +If C<$path> is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<cwd()|Cwd>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=item rel2abs() + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +If C<$base> is not present or '', then L<cwd()|Cwd> is used. If C<$base> is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L<cwd()|Cwd>. + +On systems with the concept of volume, if C<$path> and C<$base> appear to be +on two different volumes, we will not attempt to resolve the two +paths, and we will instead simply return C<$path>. Note that previous +versions of this module ignored the volume of C<$base>, which resulted in +garbage results part of the time. + +On systems that have a grammar that indicates filenames, this ignores the +C<$base> filename as well. Otherwise all path components are assumed to be +directories. + +If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=back + +For further information, please see L<File::Spec::Unix>, +L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or +L<File::Spec::VMS>. + +=head1 SEE ALSO + +L<File::Spec::Unix>, L<File::Spec::Mac>, L<File::Spec::OS2>, +L<File::Spec::Win32>, L<File::Spec::VMS>, L<File::Spec::Functions>, +L<ExtUtils::MakeMaker> + +=head1 AUTHOR + +Currently maintained by Ken Williams C<< <KWILLIAMS@cpan.org> >>. + +The vast majority of the code was written by +Kenneth Albanowski C<< <kjahds@kjahds.com> >>, +Andy Dougherty C<< <doughera@lafayette.edu> >>, +Andreas KE<ouml>nig C<< <A.Koenig@franz.ww.TU-Berlin.DE> >>, +Tim Bunce C<< <Tim.Bunce@ig.co.uk> >>. +VMS support by Charles Bailey C<< <bailey@newman.upenn.edu> >>. +OS/2 support by Ilya Zakharevich C<< <ilya@math.ohio-state.edu> >>. +Mac support by Paul Schinder C<< <schinder@pobox.com> >>, and +Thomas Wegner C<< <wegner_thomas@yahoo.com> >>. +abs2rel() and rel2abs() written by Shigio Yamaguchi C<< <shigio@tamacom.com> >>, +modified by Barrie Slaymaker C<< <barries@slaysys.com> >>. +splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/File/Spec/Unix.pm b/Master/tlpkg/installer/perllib/File/Spec/Unix.pm new file mode 100644 index 00000000000..4a25fe632f2 --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec/Unix.pm @@ -0,0 +1,510 @@ +package File::Spec::Unix; + +use strict; +use vars qw($VERSION); + +$VERSION = '1.5'; + +=head1 NAME + +File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules + +=head1 SYNOPSIS + + require File::Spec::Unix; # Done automatically by File::Spec + +=head1 DESCRIPTION + +Methods for manipulating file specifications. Other File::Spec +modules, such as File::Spec::Mac, inherit from File::Spec::Unix and +override specific methods. + +=head1 METHODS + +=over 2 + +=item canonpath() + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminates successive slashes and successive "/.". + + $cpath = File::Spec->canonpath( $path ) ; + +Note that this does *not* collapse F<x/../y> sections into F<y>. This +is by design. If F</foo> on your system is a symlink to F</bar/baz>, +then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive +F<../>-removal would give you. If you want to do this kind of +processing, you probably want C<Cwd>'s C<realpath()> function to +actually traverse the filesystem cleaning up paths like this. + +=cut + +sub canonpath { + my ($self,$path) = @_; + + # Handle POSIX-style node names beginning with double slash (qnx, nto) + # Handle network path names beginning with double slash (cygwin) + # (POSIX says: "a pathname that begins with two successive slashes + # may be interpreted in an implementation-defined manner, although + # more than two leading slashes shall be treated as a single slash.") + my $node = ''; + if ( $^O =~ m/^(?:qnx|nto|cygwin)$/ && $path =~ s:^(//[^/]+)(/|\z):/:s ) { + $node = $1; + } + # This used to be + # $path =~ s|/+|/|g unless($^O eq 'cygwin'); + # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail + # (Mainly because trailing "" directories didn't get stripped). + # Why would cygwin avoid collapsing multiple slashes into one? --jhi + $path =~ s|/+|/|g; # xx////xx -> xx/xx + $path =~ s@(/\.)+(/|\Z(?!\n))@/@g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|; # /../../xx -> xx + $path =~ s|^/\.\.$|/|; # /.. -> / + $path =~ s|/\Z(?!\n)|| unless $path eq "/"; # xx/ -> xx + return "$node$path"; +} + +=item catdir() + +Concatenate two or more directory names to form a complete path ending +with a directory. But remove the trailing slash from the resulting +string, because it doesn't look good, isn't necessary and confuses +OS2. Of course, if this is the root directory, don't cut off the +trailing slash :-) + +=cut + +sub catdir { + my $self = shift; + + $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + my $self = shift; + my $file = $self->canonpath(pop @_); + return $file unless @_; + my $dir = $self->catdir(@_); + $dir .= "/" unless substr($dir,-1) eq "/"; + return $dir.$file; +} + +=item curdir + +Returns a string representation of the current directory. "." on UNIX. + +=cut + +sub curdir () { '.' } + +=item devnull + +Returns a string representation of the null device. "/dev/null" on UNIX. + +=cut + +sub devnull () { '/dev/null' } + +=item rootdir + +Returns a string representation of the root directory. "/" on UNIX. + +=cut + +sub rootdir () { '/' } + +=item tmpdir + +Returns a string representation of the first writable directory from +the following list or the current directory if none from the list are +writable: + + $ENV{TMPDIR} + /tmp + +Since perl 5.8.0, if running under taint mode, and if $ENV{TMPDIR} +is tainted, it is not used. + +=cut + +my $tmpdir; +sub _tmpdir { + return $tmpdir if defined $tmpdir; + my $self = shift; + my @dirlist = @_; + { + no strict 'refs'; + if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0 + require Scalar::Util; + @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; + } + } + foreach (@dirlist) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = $self->curdir unless defined $tmpdir; + $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); + return $tmpdir; +} + +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ); +} + +=item updir + +Returns a string representation of the parent directory. ".." on UNIX. + +=cut + +sub updir () { '..' } + +=item no_upwards + +Given a list of file names, strip out those that refer to a parent +directory. (Does not strip symlinks, only '.', '..', and equivalents.) + +=cut + +sub no_upwards { + my $self = shift; + return grep(!/^\.{1,2}\Z(?!\n)/s, @_); +} + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +is not or is significant when comparing file specifications. + +=cut + +sub case_tolerant () { 0 } + +=item file_name_is_absolute + +Takes as argument a path and returns true if it is an absolute path. + +This does not consult the local filesystem on Unix, Win32, OS/2 or Mac +OS (Classic). It does consult the working environment for VMS (see +L<File::Spec::VMS/file_name_is_absolute>). + +=cut + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m:^/:s); +} + +=item path + +Takes no argument, returns the environment variable PATH as an array. + +=cut + +sub path { + return () unless exists $ENV{PATH}; + my @path = split(':', $ENV{PATH}); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +=item join + +join is the same as catfile. + +=cut + +sub join { + my $self = shift; + return $self->catfile(@_); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. On systems +with no concept of volume, returns '' for volume. + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless $no_file is true or a +trailing separator or /. or /.. is present. On Unix this means that $no_file +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + $directory = $path; + } + else { + $path =~ m|^ ( (?: .* / (?: \.\.?\Z(?!\n) )? )? ) ([^/]*) |xs; + $directory = $1; + $file = $2; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSs. + +On Unix, + + File::Spec->splitdir( "/a/b//c/" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + return split m|/|, $_[1], -1; # Preserve trailing fields +} + + +=item catpath() + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and directory and file are concatenated. A '/' is +inserted if needed (though if the directory portion doesn't start with +'/' it is not added). On other OSs, $volume is significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( $directory ne '' && + $file ne '' && + substr( $directory, -1 ) ne '/' && + substr( $file, 0, 1 ) ne '/' + ) { + $directory .= "/$file" ; + } + else { + $directory .= $file ; + } + + return $directory ; +} + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems that have a grammar that indicates filenames, this ignores the +$base filename. Otherwise all path components are assumed to be +directories. + +If $path is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<cwd()|Cwd>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path); + my @basechunks = $self->splitdir( $base); + + while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { + shift @pathchunks ; + shift @basechunks ; + } + + $path = CORE::join( '/', @pathchunks ); + $base = CORE::join( '/', @basechunks ); + + # $base now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + $base =~ s|[^/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + if ( $path ne '' && $base ne '' ) { + $path = "$base/$path" ; + } else { + $path = "$base$path" ; + } + + return $self->canonpath( $path ) ; +} + +=item rel2abs() + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; + +If $base is not present or '', then L<cwd()|Cwd> is used. If $base is +relative, then it is converted to absolute form using +L</rel2abs()>. This means that it is taken to be relative to +L<cwd()|Cwd>. + +On systems that have a grammar that indicates filenames, this ignores +the $base filename. Otherwise all path components are assumed to be +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +No checks against the filesystem are made. On VMS, there is +interaction with the working environment, as logicals and +macros are expanded. + +Based on code written by Shigio Yamaguchi. + +=cut + +sub rel2abs { + my ($self,$path,$base ) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = $self->_cwd(); + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Glom them together + $path = $self->catdir( $base, $path ) ; + } + + return $self->canonpath( $path ) ; +} + +=back + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +# Internal routine to File::Spec, no point in making this public since +# it is the standard Cwd interface. Most of the platform-specific +# File::Spec subclasses use this. +sub _cwd { + require Cwd; + Cwd::cwd(); +} + + +# Internal method to reduce xx\..\yy -> yy +sub _collapse { + my($fs, $path) = @_; + + my $updir = $fs->updir; + my $curdir = $fs->curdir; + + my($vol, $dirs, $file) = $fs->splitpath($path); + my @dirs = $fs->splitdir($dirs); + + my @collapsed; + foreach my $dir (@dirs) { + if( $dir eq $updir and # if we have an updir + @collapsed and # and something to collapse + length $collapsed[-1] and # and its not the rootdir + $collapsed[-1] ne $updir and # nor another updir + $collapsed[-1] ne $curdir # nor the curdir + ) + { # then + pop @collapsed; # collapse + } + else { # else + push @collapsed, $dir; # just hang onto it + } + } + + return $fs->catpath($vol, + $fs->catdir(@collapsed), + $file + ); +} + + +1; diff --git a/Master/tlpkg/installer/perllib/File/Spec/Win32.pm b/Master/tlpkg/installer/perllib/File/Spec/Win32.pm new file mode 100644 index 00000000000..a324306a74b --- /dev/null +++ b/Master/tlpkg/installer/perllib/File/Spec/Win32.pm @@ -0,0 +1,369 @@ +package File::Spec::Win32; + +use strict; + +use vars qw(@ISA $VERSION); +require File::Spec::Unix; + +$VERSION = '1.6'; + +@ISA = qw(File::Spec::Unix); + +=head1 NAME + +File::Spec::Win32 - methods for Win32 file specs + +=head1 SYNOPSIS + + require File::Spec::Win32; # Done internally by File::Spec if needed + +=head1 DESCRIPTION + +See File::Spec::Unix for a documentation of the methods provided +there. This package overrides the implementation of these methods, not +the semantics. + +=over 4 + +=item devnull + +Returns a string representation of the null device. + +=cut + +sub devnull { + return "nul"; +} + +sub rootdir () { '\\' } + + +=item tmpdir + +Returns a string representation of the first existing directory +from the following list: + + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + SYS:/temp + C:\system\temp + C:/temp + /tmp + / + +The SYS:/temp is preferred in Novell NetWare and the C:\system\temp +for Symbian (the File::Spec::Win32 is used also for those platforms). + +Since Perl 5.8.0, if running under taint mode, and if the environment +variables are tainted, they are not used. + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)}, + 'SYS:/temp', + 'C:\system\temp', + 'C:/temp', + '/tmp', + '/' ); +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); +} + +=item catfile + +Concatenate one or more directory names and a filename to form a +complete path ending with a filename + +=cut + +sub catfile { + my $self = shift; + my $file = $self->canonpath(pop @_); + return $file unless @_; + my $dir = $self->catdir(@_); + $dir .= "\\" unless substr($dir,-1) eq "\\"; + return $dir.$file; +} + +sub catdir { + my $self = shift; + my @args = @_; + foreach (@args) { + tr[/][\\]; + # append a backslash to each argument unless it has one there + $_ .= "\\" unless m{\\$}; + } + return $self->canonpath(join('', @args)); +} + +sub path { + my @path = split(';', $ENV{PATH}); + s/"//g for @path; + @path = grep length, @path; + unshift(@path, "."); + return @path; +} + +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". +On Win32 makes + + dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even + dir1\dir2\dir3\...\dir4 -> \dir\dir4 + +=cut + +sub canonpath { + my ($self,$path) = @_; + + $path =~ s/^([a-z]:)/\u$1/s; + $path =~ s|/|\\|g; + $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx + $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx + $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx + $path =~ s|\\\Z(?!\n)|| + unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx + # xx1/xx2/xx3/../../xx -> xx1/xx + $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up + $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up + return $path if $path =~ m|^\.\.|; # skip relative paths + return $path unless $path =~ /\.\./; # too few .'s to cleanup + return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup + $path =~ s{^\\\.\.$}{\\}; # \.. -> \ + 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx + + return $self->_collapse($path); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path into volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '\\', '\\.', '\\..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, '' ). + +Separators accepted are \ and /. + +Volumes can be drive letters or UNC sharenames (\\server\share). + +The results can be passed to L</catpath> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L<catdir()|File::Spec/catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|[\\/]\Z(?!\n)| ) { + return split( m|[\\/]|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + my $v; + $volume .= $v + if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + $base = $self->_cwd() unless defined $base and length $base; + + for ($path, $base) { $_ = $self->canonpath($_) } + + my ($path_volume) = $self->splitpath($path, 1); + my ($base_volume) = $self->splitpath($base, 1); + + # Can't relativize across volumes + return $path unless $path_volume eq $base_volume; + + for ($path, $base) { $_ = $self->rel2abs($_) } + + my $path_directories = ($self->splitpath($path, 1))[1]; + my $base_directories = ($self->splitpath($base, 1))[1]; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); + + return $self->canonpath( $self->catpath('', $result_dirs, '') ); +} + + +sub rel2abs { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + require Cwd ; + $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ; + $base = $self->_cwd() unless defined $base ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + +=back + +=head2 Note For File::Spec::Win32 Maintainers + +Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32. + +=head1 COPYRIGHT + +Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<File::Spec> and L<File::Spec::Unix>. This package overrides the +implementation of these methods, not the semantics. + +=cut + +1; diff --git a/Master/tlpkg/installer/perllib/Pod/InputObjects.pm b/Master/tlpkg/installer/perllib/Pod/InputObjects.pm new file mode 100644 index 00000000000..fa5f61f9a70 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/InputObjects.pm @@ -0,0 +1,941 @@ +############################################################################# +# 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 vars qw($VERSION); +$VERSION = 1.30; ## 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 + +This module defines some basic input objects used by B<Pod::Parser> when +reading and parsing POD text from an input source. The following objects +are defined: + +=over 4 + +=begin __PRIVATE__ + +=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. + +=end __PRIVATE__ + +=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 + +############################################################################# + +use strict; +#use diagnostics; +#use Carp; + +############################################################################# + +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 havent 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 and !(ref $ptree[0]) and !(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 + +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/installer/perllib/Pod/ParseLink.pm b/Master/tlpkg/installer/perllib/Pod/ParseLink.pm new file mode 100644 index 00000000000..7e4153da3d0 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/ParseLink.pm @@ -0,0 +1,184 @@ +# Pod::ParseLink -- Parse an L<> formatting code in POD text. +# $Id: ParseLink.pm,v 1.6 2002/07/15 05:46:00 eagle Exp $ +# +# Copyright 2001 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module implements parsing of the text of an L<> formatting code as +# defined in perlpodspec. It should be suitable for any POD formatter. It +# exports only one function, parselink(), which returns the five-item parse +# defined in perlpodspec. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::ParseLink; + +require 5.004; + +use strict; +use vars qw(@EXPORT @ISA $VERSION); + +use Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(parselink); + +# Don't use the CVS revision as the version, since this module is also in Perl +# core and too many things could munge CVS magic revision strings. This +# number should ideally be the same as the CVS revision in podlators, however. +$VERSION = 1.06; + + +############################################################################## +# Implementation +############################################################################## + +# Parse the name and section portion of a link into a name and section. +sub _parse_section { + my ($link) = @_; + $link =~ s/^\s+//; + $link =~ s/\s+$//; + + # If the whole link is enclosed in quotes, interpret it all as a section + # even if it contains a slash. + return (undef, $1) if ($link =~ /^"\s*(.*?)\s*"$/); + + # Split into page and section on slash, and then clean up quoting in the + # section. If there is no section and the name contains spaces, also + # guess that it's an old section link. + my ($page, $section) = split (/\s*\/\s*/, $link, 2); + $section =~ s/^"\s*(.*?)\s*"$/$1/ if $section; + if ($page && $page =~ / / && !defined ($section)) { + $section = $page; + $page = undef; + } else { + $page = undef unless $page; + $section = undef unless $section; + } + return ($page, $section); +} + +# Infer link text from the page and section. +sub _infer_text { + my ($page, $section) = @_; + my $inferred; + if ($page && !$section) { + $inferred = $page; + } elsif (!$page && $section) { + $inferred = '"' . $section . '"'; + } elsif ($page && $section) { + $inferred = '"' . $section . '" in ' . $page; + } + return $inferred; +} + +# Given the contents of an L<> formatting code, parse it into the link text, +# the possibly inferred link text, the name or URL, the section, and the type +# of link (pod, man, or url). +sub parselink { + my ($link) = @_; + $link =~ s/\s+/ /g; + if ($link =~ /\A\w+:[^:\s]\S*\Z/) { + return (undef, $link, $link, undef, 'url'); + } else { + my $text; + if ($link =~ /\|/) { + ($text, $link) = split (/\|/, $link, 2); + } + my ($name, $section) = _parse_section ($link); + my $inferred = $text || _infer_text ($name, $section); + my $type = ($name && $name =~ /\(\S*\)/) ? 'man' : 'pod'; + return ($text, $inferred, $name, $section, $type); + } +} + + +############################################################################## +# Module return value and documentation +############################################################################## + +# Ensure we evaluate to true. +1; +__END__ + +=head1 NAME + +Pod::ParseLink - Parse an LE<lt>E<gt> formatting code in POD text + +=head1 SYNOPSIS + + use Pod::ParseLink; + my ($text, $inferred, $name, $section, $type) = parselink ($link); + +=head1 DESCRIPTION + +This module only provides a single function, parselink(), which takes the +text of an LE<lt>E<gt> formatting code and parses it. It returns the anchor +text for the link (if any was given), the anchor text possibly inferred from +the name and section, the name or URL, the section if any, and the type of +link. The type will be one of 'url', 'pod', or 'man', indicating a URL, a +link to a POD page, or a link to a Unix manual page. + +Parsing is implemented per L<perlpodspec>. For backward compatibility, +links where there is no section and name contains spaces, or links where the +entirety of the link (except for the anchor text if given) is enclosed in +double-quotes are interpreted as links to a section (LE<lt>/sectionE<gt>). + +The inferred anchor text is implemented per L<perlpodspec>: + + L<name> => L<name|name> + L</section> => L<"section"|/section> + L<name/section> => L<"section" in name|name/section> + +The name may contain embedded EE<lt>E<gt> and ZE<lt>E<gt> formatting codes, +and the section, anchor text, and inferred anchor text may contain any +formatting codes. Any double quotes around the section are removed as part +of the parsing, as is any leading or trailing whitespace. + +If the text of the LE<lt>E<gt> escape is entirely enclosed in double quotes, +it's interpreted as a link to a section for backwards compatibility. + +No attempt is made to resolve formatting codes. This must be done after +calling parselink (since EE<lt>E<gt> formatting codes can be used to escape +characters that would otherwise be significant to the parser and resolving +them before parsing would result in an incorrect parse of a formatting code +like: + + L<verticalE<verbar>barE<sol>slash> + +which should be interpreted as a link to the C<vertical|bar/slash> POD page +and not as a link to the C<slash> section of the C<bar> POD page with an +anchor text of C<vertical>. Note that not only the anchor text will need to +have formatting codes expanded, but so will the target of the link (to deal +with EE<lt>E<gt> and ZE<lt>E<gt> formatting codes), and special handling of +the section may be necessary depending on whether the translator wants to +consider markup in sections to be significant when resolving links. See +L<perlpodspec> for more information. + +=head1 SEE ALSO + +L<Pod::Parser> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 2001 by Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Pod/Parser.pm b/Master/tlpkg/installer/perllib/Pod/Parser.pm new file mode 100644 index 00000000000..a5fde848503 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Parser.pm @@ -0,0 +1,1799 @@ +############################################################################# +# 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 vars qw($VERSION); +$VERSION = 1.32; ## 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<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 preprocesssing 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 intepret 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 vars qw(@ISA); +use strict; +#use diagnostics; +use Pod::InputObjects; +use Carp; +use Exporter; +BEGIN { + if ($] < 5.6) { + require Symbol; + import Symbol; + } +} +@ISA = qw(Exporter); + +## These "variables" are used as local "glob aliases" for performance +use vars qw(%myData %myOpts @input_stack); + +############################################################################# + +=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 = shift; + my $class = ref($this) || $this; + ## Any remaining arguments are treated as initial values for the + ## hash that is used to represent this object. + my %params = @_; + 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 curresponding 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 ($self, $iseq) = @_; + my $args = join("", $iseq->parse_tree->children); + return $self->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]<(?:<+\s)?)/; + while ( @tokens ) { + $_ = shift @tokens; + ## Look for the beginning of a sequence + if ( /^([A-Z])(<(?:<+\s)?)$/ ) { + ## 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 + ## dont 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 + ## dont 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 += tr/\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 warn($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 isnt in one of the selected sections + if (exists $myData{_SELECTED_SECTIONS}) { + $self->is_selected($text) or return ($myData{_CUTTING} = 1); + } + + ## If we havent 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; + ## If this is a "cut" directive then we dont 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 (length $cmd) { + ## A command paragraph + $self->command($cmd, $text, $line_num, $pod_para); + } + elsif ($text =~ /^\s+/) { + ## Indented text - must be a verbatim paragraph + $self->verbatim($text, $line_num, $pod_para); + } + else { + ## Looks like an ordinary block of text + $self->textblock($text, $line_num, $pod_para); + } + 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 isnt, then keep iterating until it is. + next unless (($textline =~ /^([^\S\r\n]*)[\r\n]*$/) + && (length $paragraph)); + + ## Issue a warning about any non-empty blank lines + if (length($1) > 0 and $myOpts{'-warnings'} and ! $myData{_CUTTING}) { + my $errorsub = $self->errorsub(); + my $file = $self->input_file(); + my $errmsg = "*** WARNING: line containing nothing but whitespace". + " in paragraph at line $nlines in file $file\n"; + (ref $errorsub) and &{$errorsub}($errmsg) + or (defined $errorsub) and $self->$errorsub($errmsg) + or warn($errmsg); + } + + ## Now process the paragraph + parse_paragraph($self, $paragraph, ($nlines - $plines) + 1); + $paragraph = ''; + $plines = 0; + } + ## Dont 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. + +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, an L<IO::String> object is also accepted as an output +file handle. + +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) = (gensym(), gensym()) if ($] < 5.006); + 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<warn> +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 warn($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<warn> 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(); + + ## Dont 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 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> + +=cut + +1; +# vim: ts=4 sw=4 et diff --git a/Master/tlpkg/installer/perllib/Pod/Select.pm b/Master/tlpkg/installer/perllib/Pod/Select.pm new file mode 100644 index 00000000000..1cc14dff4b6 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Select.pm @@ -0,0 +1,754 @@ +############################################################################# +# 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 vars qw($VERSION); +$VERSION = 1.30; ## 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<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 strict; +#use diagnostics; +use Carp; +use Pod::Parser 1.04; +use vars qw(@ISA @EXPORT $MAX_HEADING_LEVEL); + +@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_ + +use vars qw(%myData @section_headings); + +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 + +use vars qw(@selected_sections); + +sub select { + my $self = shift; + my @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 > 0) { + 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 + my $spec; + for $spec (@sections) { + if ( defined($_ = &_compile_section_spec($spec)) ) { + ## Store them in our sections array + push(@selected_sections, $_); + } + else { + carp "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; + $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; + $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 explictly 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} > 0)); + + ## 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 + my ($section_spec, $regex, $negated, $match); + for $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. + ##------------------------------------------------------ + $match = 1; + for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { + $regex = $section_spec->[$i]; + $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 given 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"). 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 should correspond to the names of input files +containing POD sections. A file name of "-" or "<&STDIN" will +be interpeted to mean standard input (which is the default if no +filenames 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) { + if (ref($_)) { + next unless (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') ); + } + else { + $pod_parser->parse_from_file($_, $output); + ++$num_inputs; + } + } + $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 ommitted 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 "/$_/"; ## check regex syntax + if ($@) { + ++$bad_regexs; + carp "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> + +=cut + +1; +# vim: ts=4 sw=4 et diff --git a/Master/tlpkg/installer/perllib/Pod/Text.pm b/Master/tlpkg/installer/perllib/Pod/Text.pm new file mode 100644 index 00000000000..1028f2e9e1b --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Text.pm @@ -0,0 +1,848 @@ +# Pod::Text -- Convert POD data to formatted ASCII text. +# $Id: Text.pm,v 2.21 2002/08/04 03:34:58 eagle Exp $ +# +# Copyright 1999, 2000, 2001, 2002 by Russ Allbery <rra@stanford.edu> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# This module converts POD to formatted text. It replaces the old Pod::Text +# module that came with versions of Perl prior to 5.6.0 and attempts to match +# 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. +# +# Perl core hackers, please note that this module is also separately +# maintained outside of the Perl core as part of the podlators. Please send +# me any patches at the address above in addition to sending them to the +# standard Perl mailing lists. + +############################################################################## +# Modules and declarations +############################################################################## + +package Pod::Text; + +require 5.004; + +use Carp qw(carp croak); +use Exporter (); +use Pod::ParseLink qw(parselink); +use Pod::Select (); + +use strict; +use vars qw(@ISA @EXPORT %ESCAPES $VERSION); + +# We inherit from Pod::Select instead of Pod::Parser so that we can be used by +# Pod::Usage. +@ISA = qw(Pod::Select Exporter); + +# We have to export pod2text for backward compatibility. +@EXPORT = qw(pod2text); + +# Don't use the CVS revision as the version, since this module is also in Perl +# core and too many things could munge CVS magic revision strings. This +# number should ideally be the same as the CVS revision in podlators, however. +$VERSION = 2.21; + + +############################################################################## +# 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. :) "iexcl" to +# "divide" added by Tim Jenness. +%ESCAPES = ( + 'amp' => '&', # ampersand + 'apos' => "'", # apostrophe + 'lt' => '<', # left chevron, less-than + 'gt' => '>', # right chevron, greater-than + 'quot' => '"', # double quote + 'sol' => '/', # solidus (forward slash) + 'verbar' => '|', # vertical bar + + "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" => "\xCC", # capital I, grave accent + "igrave" => "\xEC", # 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 + + "laquo" => "\xAB", # left pointing double angle quotation mark + "lchevron" => "\xAB", # synonym (backwards compatibility) + "raquo" => "\xBB", # right pointing double angle quotation mark + "rchevron" => "\xBB", # synonym (backwards compatibility) + + "iexcl" => "\xA1", # inverted exclamation mark + "cent" => "\xA2", # cent sign + "pound" => "\xA3", # (UK) pound sign + "curren" => "\xA4", # currency sign + "yen" => "\xA5", # yen sign + "brvbar" => "\xA6", # broken vertical bar + "sect" => "\xA7", # section sign + "uml" => "\xA8", # diaresis + "copy" => "\xA9", # Copyright symbol + "ordf" => "\xAA", # feminine ordinal indicator + "not" => "\xAC", # not sign + "shy" => '', # soft (discretionary) hyphen + "reg" => "\xAE", # registered trademark + "macr" => "\xAF", # macron, overline + "deg" => "\xB0", # degree sign + "plusmn" => "\xB1", # plus-minus sign + "sup2" => "\xB2", # superscript 2 + "sup3" => "\xB3", # superscript 3 + "acute" => "\xB4", # acute accent + "micro" => "\xB5", # micro sign + "para" => "\xB6", # pilcrow sign = paragraph sign + "middot" => "\xB7", # middle dot = Georgian comma + "cedil" => "\xB8", # cedilla + "sup1" => "\xB9", # superscript 1 + "ordm" => "\xBA", # masculine ordinal indicator + "frac14" => "\xBC", # vulgar fraction one quarter + "frac12" => "\xBD", # vulgar fraction one half + "frac34" => "\xBE", # vulgar fraction three quarters + "iquest" => "\xBF", # inverted question mark + "times" => "\xD7", # multiplication sign + "divide" => "\xF7", # division sign + + "nbsp" => "\x01", # non-breaking space +); + + +############################################################################## +# 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{margin} = 0 unless defined $$self{margin}; + $$self{loose} = 0 unless defined $$self{loose}; + $$self{sentence} = 0 unless defined $$self{sentence}; + $$self{width} = 76 unless defined $$self{width}; + + # Figure out what quotes we'll be using for C<> text. + $$self{quotes} ||= '"'; + if ($$self{quotes} eq 'none') { + $$self{LQUOTE} = $$self{RQUOTE} = ''; + } elsif (length ($$self{quotes}) == 1) { + $$self{LQUOTE} = $$self{RQUOTE} = $$self{quotes}; + } elsif ($$self{quotes} =~ /^(.)(.)$/ + || $$self{quotes} =~ /^(..)(..)$/) { + $$self{LQUOTE} = $1; + $$self{RQUOTE} = $2; + } else { + croak qq(Invalid quote specification "$$self{quotes}"); + } + + # Stack of indentations. + $$self{INDENTS} = []; + + # Current left margin. + $$self{MARGIN} = $$self{indent} + $$self{margin}; + + $self->SUPER::initialize; + + # Tell Pod::Parser that we want the non-POD stuff too if code was set. + $self->parseopts ('-want_nonPODs' => 1) if $$self{code}; +} + + +############################################################################## +# 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 ($self->can ('cmd_' . $command)) { + $command = 'cmd_' . $command; + $self->$command (@_); + } else { + my ($text, $line, $paragraph) = @_; + my $file; + ($file, $line) = $paragraph->file_line; + $text =~ s/\n+\z//; + $text = " $text" if ($text =~ /^\S/); + warn qq($file:$line: Unknown command paragraph: =$command$text\n); + return; + } +} + +# 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; + $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}; + $self->output ($_[0]), return if $$self{VERBATIM}; + local $_ = shift; + my $line = shift; + + # Interpolate and output the paragraph. + $_ = $self->interpolate ($_, $line); + s/\s+$/\n/; + if (defined $$self{ITEM}) { + $self->item ($_ . "\n"); + } else { + $self->output ($self->reformat ($_ . "\n")); + } +} + +# Called for a formatting code. Gets the command, argument, and a +# Pod::InteriorSequence object and is expected to return the resulting text. +# Calls methods for code, bold, italic, file, and link to handle those types +# of codes, and handles S<>, E<>, X<>, and Z<> directly. +sub interior_sequence { + local $_; + my ($self, $command, $seq); + ($self, $command, $_, $seq) = @_; + + # We have to defer processing of the inside of an L<> formatting code. If + # this code is nested inside an L<> code, return the literal raw text of + # it. + my $parent = $seq->nested; + while (defined $parent) { + return $seq->raw_text if ($parent->cmd_name eq 'L'); + $parent = $parent->nested; + } + + # Index entries are ignored in plain text. + return '' if ($command eq 'X' || $command eq 'Z'); + + # Expand escapes into the actual character now, warning if invalid. + if ($command eq 'E') { + if (/^\d+$/) { + return chr; + } else { + return $ESCAPES{$_} if defined $ESCAPES{$_}; + my ($file, $line) = $seq->file_line; + warn "$file:$line: Unknown escape: E<$_>\n"; + return "E<$_>"; + } + } + + # For all the other formatting codes, 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+/ /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 ($_, $seq) } + else { + my ($file, $line) = $seq->file_line; + warn "$file:$line: Unknown formatting code: $command<$_>\n"; + } +} + +# Called for each paragraph that's actually part of the POD. We take +# advantage of this opportunity to untabify the input. Also, if given the +# code option, we may see paragraphs that aren't part of the POD and need to +# output them directly. +sub preprocess_paragraph { + my $self = shift; + local $_ = shift; + 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; + $self->output_code ($_) if $self->cutting; + $_; +} + + +############################################################################## +# Command paragraphs +############################################################################## + +# All command paragraphs take the paragraph and the line number. + +# First level heading. +sub cmd_head1 { + my ($self, $text, $line) = @_; + $self->heading ($text, $line, 0, '===='); +} + +# Second level heading. +sub cmd_head2 { + my ($self, $text, $line) = @_; + $self->heading ($text, $line, $$self{indent} / 2, '== '); +} + +# Third level heading. +sub cmd_head3 { + my ($self, $text, $line) = @_; + $self->heading ($text, $line, $$self{indent} * 2 / 3 + 0.5, '= '); +} + +# Third level heading. +sub cmd_head4 { + my ($self, $text, $line) = @_; + $self->heading ($text, $line, $$self{indent} * 3 / 4 + 0.5, '- '); +} + +# Start a list. +sub cmd_over { + my $self = shift; + local $_ = shift; + $self->item ("\n\n") if defined $$self{ITEM}; + unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } + push (@{ $$self{INDENTS} }, $$self{MARGIN}); + $$self{MARGIN} += ($_ + 0); +} + +# End a list. +sub cmd_back { + my ($self, $text, $line, $paragraph) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $$self{MARGIN} = pop @{ $$self{INDENTS} }; + unless (defined $$self{MARGIN}) { + my $file; + ($file, $line) = $paragraph->file_line; + warn "$file:$line: Unmatched =back\n"; + $$self{MARGIN} = $$self{indent}; + } +} + +# An individual list item. +sub cmd_item { + my $self = shift; + if (defined $$self{ITEM}) { $self->item } + local $_ = shift; + 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]*\n?//; + $self->verbatim ($_, $line); +} + + +############################################################################## +# Formatting codes +############################################################################## + +# The simple 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_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } +sub seq_i { return '*' . $_[1] . '*' } + +# Apply a whole bunch of messy heuristics to not quote things that don't +# benefit from being quoted. These originally come from Barrie Slaymaker and +# largely duplicate code in Pod::Man. +sub seq_c { + my $self = shift; + local $_ = shift; + + # A regex that matches the portion of a variable reference that's the + # array or hash index, separated out just because we want to use it in + # several places in the following regex. + my $index = '(?: \[.*\] | \{.*\} )?'; + + # Check for things that we don't want to quote, and if we find any of + # them, return the string with just a font change and no quoting. + m{ + ^\s* + (?: + ( [\'\`\"] ) .* \1 # already quoted + | \` .* \' # `quoted' + | \$+ [\#^]? \S $index # special ($^Foo, $") + | [\$\@%&*]+ \#? [:\'\w]+ $index # plain var or func + | [\$\@%&*]* [:\'\w]+ (?: -> )? \(\s*[^\s,]\s*\) # 0/1-arg func call + | [+-]? ( \d[\d.]* | \.\d+ ) (?: [eE][+-]?\d+ )? # a number + | 0x [a-fA-F\d]+ # a hex constant + ) + \s*\z + }xo && return $_; + + # If we didn't return, go ahead and quote the text. + return $$self{alt} ? "``$_''" : "$$self{LQUOTE}$_$$self{RQUOTE}"; +} + +# 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. Most of the +# work is done by Pod::ParseLink. +sub seq_l { + my ($self, $link, $seq) = @_; + my ($text, $type) = (parselink ($link))[1,4]; + my ($file, $line) = $seq->file_line; + $text = $self->interpolate ($text, $line); + $text = '<' . $text . '>' if $type eq 'url'; + return $text || ''; +} + + +############################################################################## +# Header handling +############################################################################## + +# The common code for handling all headers. Takes the interpolated header +# text, the line number, the indentation, and the surrounding marker for the +# alt formatting method. +sub heading { + my ($self, $text, $line, $indent, $marker) = @_; + $self->item ("\n\n") if defined $$self{ITEM}; + $text =~ s/\s+$//; + $text = $self->interpolate ($text, $line); + if ($$self{alt}) { + my $closemark = reverse (split (//, $marker)); + my $margin = ' ' x $$self{margin}; + $self->output ("\n" . "$margin$marker $text $closemark" . "\n\n"); + } else { + $text .= "\n" if $$self{loose}; + my $margin = ' ' x ($$self{margin} + $indent); + $self->output ($margin . $text . "\n"); + } +} + + +############################################################################## +# 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 $margin = ' ' x $$self{margin}; + if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) { + my $realindent = $$self{MARGIN}; + $$self{MARGIN} = $indent; + my $output = $self->reformat ($tag); + $output =~ s/^$margin /$margin:/ if ($$self{alt} && $indent > 0); + $output =~ s/\n*$/\n/; + + # If the text is just whitespace, we have an empty item paragraph; + # this can result from =over/=item/=back without any intermixed + # paragraphs. Insert some whitespace to keep the =item from merging + # into the next paragraph. + $output .= "\n" if $_ && $_ =~ /^\s*$/; + + $self->output ($output); + $$self{MARGIN} = $realindent; + $self->output ($self->reformat ($_)) if $_ && /\S/; + } else { + my $space = ' ' x $indent; + $space =~ s/^$margin /$margin:/ if $$self{alt}; + $_ = $self->reformat ($_); + s/^$margin /$margin:/ if ($$self{alt} && $indent > 0); + my $tagspace = ' ' x length $tag; + s/^($space)$tagspace/$1$tag/ or warn "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/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) { + $output .= $spaces . $1 . "\n"; + } else { + last; + } + } + $output .= $spaces . $_; + $output =~ s/\s+$/\n\n/; + $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/\.\n/. \n/g; + s/\n/ /g; + s/ +/ /g; + } else { + s/\s+/ /g; + } + $self->wrap ($_); +} + +# Output text to the output device. +sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } + +# Output a block of code (something that isn't part of the POD text). Called +# by preprocess_paragraph only if we were given the code option. Exists here +# only so that it can be overridden by subclasses. +sub output_code { $_[0]->output ($_[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::Text->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 @fhs = @_; + local *IN; + unless (open (IN, $fhs[0])) { + croak ("Can't open $fhs[0] for reading: $!\n"); + return; + } + $fhs[0] = \*IN; + return $parser->parse_from_filehandle (@fhs); + } else { + return $parser->parse_from_file (@_); + } +} + + +############################################################################## +# Module return value and documentation +############################################################################## + +1; +__END__ + +=head1 NAME + +Pod::Text - Convert POD data to formatted ASCII text + +=head1 SYNOPSIS + + use Pod::Text; + my $parser = Pod::Text->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 + +Pod::Text is a module that can convert documentation in the POD format (the +preferred language for documenting Perl) into formatted ASCII. It uses no +special formatting controls or codes whatsoever, and its output is therefore +suitable for nearly any device. + +As a derived class from Pod::Parser, Pod::Text supports the same methods and +interfaces. See L<Pod::Parser> for all the details; briefly, one creates a +new parser with C<< Pod::Text->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 code + +If set to a true value, the non-POD parts of the input file will be included +in the output. Useful for viewing code documented with POD blocks with the +POD rendered and the code left intact. + +=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<=head1> heading. +If set to false (the default), no blank line is printed after C<=head1>, +although one is still printed after C<=head2>. 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 margin + +The width of the left margin in spaces. Defaults to 0. This is the margin +for all text, including headings, not the amount by which regular text is +indented; for the latter, see the I<indent> option. To set the right +margin, see the I<width> option. + +=item quotes + +Sets the quote marks used to surround CE<lt>> text. If the value is a +single character, it is used as both the left and right quote; if it is two +characters, the first character is used as the left quote and the second as +the right quoted; and if it is four characters, the first two are used as +the left quote and the second two as the right quote. + +This may also be set to the special value C<none>, in which case no quote +marks are added around CE<lt>> text. + +=item sentence + +If set to a true value, Pod::Text 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 + +=item Item called without tag + +(W) Something has gone wrong in internal C<=item> processing. These +messages indicate a bug in Pod::Text; you should never see them. + +=item Can't open %s for reading: %s + +(F) Pod::Text was invoked via the compatibility mode pod2text() interface +and the input file it was given could not be opened. + +=item Invalid quote specification "%s" + +(F) The quote specification given (the quotes option to the constructor) was +invalid. A quote specification must be one, two, or four characters long. + +=item %s:%d: Unknown command paragraph: %s + +(W) The POD source contained a non-standard command paragraph (something of +the form C<=command args>) that Pod::Man didn't know about. It was ignored. + +=item %s:%d: Unknown escape: %s + +(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::Text didn't +know about. + +=item %s:%d: Unknown formatting code: %s + +(W) The POD source contained a non-standard formatting code (something of +the form C<XE<lt>E<gt>>) that Pod::Text didn't know about. + +=item %s:%d: Unmatched =back + +(W) Pod::Text 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>. + +=head1 SEE ALSO + +L<Pod::Parser>, L<Pod::Text::Termcap>, L<pod2text(1)> + +The current version of this module is always available from its web site at +L<http://www.eyrie.org/~eagle/software/podlators/>. It is also part of the +Perl core distribution as of 5.6.0. + +=head1 AUTHOR + +Russ Allbery <rra@stanford.edu>, based I<very> heavily on the original +Pod::Text by Tom Christiansen <tchrist@mox.perl.com> and its conversion to +Pod::Parser by Brad Appleton <bradapp@enteract.com>. + +=head1 COPYRIGHT AND LICENSE + +Copyright 1999, 2000, 2001, 2002 by Russ Allbery <rra@stanford.edu>. + +This program is free software; you may redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/Master/tlpkg/installer/perllib/Pod/Usage.pm b/Master/tlpkg/installer/perllib/Pod/Usage.pm new file mode 100644 index 00000000000..c298e941f21 --- /dev/null +++ b/Master/tlpkg/installer/perllib/Pod/Usage.pm @@ -0,0 +1,659 @@ +############################################################################# +# Pod/Usage.pm -- print usage messages for the running script. +# +# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. +# This file is part of "PodParser". PodParser is free software; +# you can redistribute it and/or modify it under the same terms +# as Perl itself. +############################################################################# + +package Pod::Usage; + +use vars qw($VERSION); +$VERSION = 1.33; ## Current version of this package +require 5.005; ## requires this Perl version or later + +=head1 NAME + +Pod::Usage, pod2usage() - print a usage message from embedded pod documentation + +=head1 SYNOPSIS + + use Pod::Usage + + my $message_text = "This text precedes the usage message."; + my $exit_status = 2; ## The exit status to use + my $verbose_level = 0; ## The verbose level to use + my $filehandle = \*STDERR; ## The filehandle to write to + + pod2usage($message_text); + + pod2usage($exit_status); + + pod2usage( { -message => $message_text , + -exitval => $exit_status , + -verbose => $verbose_level, + -output => $filehandle } ); + + pod2usage( -msg => $message_text , + -exitval => $exit_status , + -verbose => $verbose_level, + -output => $filehandle ); + + pod2usage( -verbose => 2, + -noperldoc => 1 ) + +=head1 ARGUMENTS + +B<pod2usage> should be given either a single argument, or a list of +arguments corresponding to an associative array (a "hash"). When a single +argument is given, it should correspond to exactly one of the following: + +=over 4 + +=item * + +A string containing the text of a message to print I<before> printing +the usage message + +=item * + +A numeric value corresponding to the desired exit status + +=item * + +A reference to a hash + +=back + +If more than one argument is given then the entire argument list is +assumed to be a hash. If a hash is supplied (either as a reference or +as a list) it should contain one or more elements with the following +keys: + +=over 4 + +=item C<-message> + +=item C<-msg> + +The text of a message to print immediately prior to printing the +program's usage message. + +=item C<-exitval> + +The desired exit status to pass to the B<exit()> function. +This should be an integer, or else the string "NOEXIT" to +indicate that control should simply be returned without +terminating the invoking process. + +=item C<-verbose> + +The desired level of "verboseness" to use when printing the usage +message. If the corresponding value is 0, then only the "SYNOPSIS" +section of the pod documentation is printed. If the corresponding value +is 1, then the "SYNOPSIS" section, along with any section entitled +"OPTIONS", "ARGUMENTS", or "OPTIONS AND ARGUMENTS" is printed. If the +corresponding value is 2 or more then the entire manpage is printed. + +The special verbosity level 99 requires to also specify the -section +parameter; then these sections are extracted (see L<Pod::Select>) +and printed. + +=item C<-section> + +A string representing a selection list for sections to be printed +when -verbose is set to 99, e.g. C<"NAME|SYNOPSIS|DESCRIPTION|VERSION">. + +=item C<-output> + +A reference to a filehandle, or the pathname of a file to which the +usage message should be written. The default is C<\*STDERR> unless the +exit value is less than 2 (in which case the default is C<\*STDOUT>). + +=item C<-input> + +A reference to a filehandle, or the pathname of a file from which the +invoking script's pod documentation should be read. It defaults to the +file indicated by C<$0> (C<$PROGRAM_NAME> for users of F<English.pm>). + +=item C<-pathlist> + +A list of directory paths. If the input file does not exist, then it +will be searched for in the given directory list (in the order the +directories appear in the list). It defaults to the list of directories +implied by C<$ENV{PATH}>. The list may be specified either by a reference +to an array, or by a string of directory paths which use the same path +separator as C<$ENV{PATH}> on your system (e.g., C<:> for Unix, C<;> for +MSWin32 and DOS). + +=item C<-noperldoc> + +By default, Pod::Usage will call L<perldoc> when -verbose >= 2 is +specified. This does not work well e.g. if the script was packed +with L<PAR>. The -noperldoc option suppresses the external call to +L<perldoc> and uses the simple text formatter (L<Pod::Text>) to +output the POD. + +=back + +=head1 DESCRIPTION + +B<pod2usage> will print a usage message for the invoking script (using +its embedded pod documentation) and then exit the script with the +desired exit status. The usage message printed may have any one of three +levels of "verboseness": If the verbose level is 0, then only a synopsis +is printed. If the verbose level is 1, then the synopsis is printed +along with a description (if present) of the command line options and +arguments. If the verbose level is 2, then the entire manual page is +printed. + +Unless they are explicitly specified, the default values for the exit +status, verbose level, and output stream to use are determined as +follows: + +=over 4 + +=item * + +If neither the exit status nor the verbose level is specified, then the +default is to use an exit status of 2 with a verbose level of 0. + +=item * + +If an exit status I<is> specified but the verbose level is I<not>, then the +verbose level will default to 1 if the exit status is less than 2 and +will default to 0 otherwise. + +=item * + +If an exit status is I<not> specified but verbose level I<is> given, then +the exit status will default to 2 if the verbose level is 0 and will +default to 1 otherwise. + +=item * + +If the exit status used is less than 2, then output is printed on +C<STDOUT>. Otherwise output is printed on C<STDERR>. + +=back + +Although the above may seem a bit confusing at first, it generally does +"the right thing" in most situations. This determination of the default +values to use is based upon the following typical Unix conventions: + +=over 4 + +=item * + +An exit status of 0 implies "success". For example, B<diff(1)> exits +with a status of 0 if the two files have the same contents. + +=item * + +An exit status of 1 implies possibly abnormal, but non-defective, program +termination. For example, B<grep(1)> exits with a status of 1 if +it did I<not> find a matching line for the given regular expression. + +=item * + +An exit status of 2 or more implies a fatal error. For example, B<ls(1)> +exits with a status of 2 if you specify an illegal (unknown) option on +the command line. + +=item * + +Usage messages issued as a result of bad command-line syntax should go +to C<STDERR>. However, usage messages issued due to an explicit request +to print usage (like specifying B<-help> on the command line) should go +to C<STDOUT>, just in case the user wants to pipe the output to a pager +(such as B<more(1)>). + +=item * + +If program usage has been explicitly requested by the user, it is often +desireable to exit with a status of 1 (as opposed to 0) after issuing +the user-requested usage message. It is also desireable to give a +more verbose description of program usage in this case. + +=back + +B<pod2usage> doesn't force the above conventions upon you, but it will +use them by default if you don't expressly tell it to do otherwise. The +ability of B<pod2usage()> to accept a single number or a string makes it +convenient to use as an innocent looking error message handling function: + + use Pod::Usage; + use Getopt::Long; + + ## Parse options + GetOptions("help", "man", "flag1") || pod2usage(2); + pod2usage(1) if ($opt_help); + pod2usage(-verbose => 2) if ($opt_man); + + ## Check for too many filenames + pod2usage("$0: Too many files given.\n") if (@ARGV > 1); + +Some user's however may feel that the above "economy of expression" is +not particularly readable nor consistent and may instead choose to do +something more like the following: + + use Pod::Usage; + use Getopt::Long; + + ## Parse options + GetOptions("help", "man", "flag1") || pod2usage(-verbose => 0); + pod2usage(-verbose => 1) if ($opt_help); + pod2usage(-verbose => 2) if ($opt_man); + + ## Check for too many filenames + pod2usage(-verbose => 2, -message => "$0: Too many files given.\n") + if (@ARGV > 1); + +As with all things in Perl, I<there's more than one way to do it>, and +B<pod2usage()> adheres to this philosophy. If you are interested in +seeing a number of different ways to invoke B<pod2usage> (although by no +means exhaustive), please refer to L<"EXAMPLES">. + +=head1 EXAMPLES + +Each of the following invocations of C<pod2usage()> will print just the +"SYNOPSIS" section to C<STDERR> and will exit with a status of 2: + + pod2usage(); + + pod2usage(2); + + pod2usage(-verbose => 0); + + pod2usage(-exitval => 2); + + pod2usage({-exitval => 2, -output => \*STDERR}); + + pod2usage({-verbose => 0, -output => \*STDERR}); + + pod2usage(-exitval => 2, -verbose => 0); + + pod2usage(-exitval => 2, -verbose => 0, -output => \*STDERR); + +Each of the following invocations of C<pod2usage()> will print a message +of "Syntax error." (followed by a newline) to C<STDERR>, immediately +followed by just the "SYNOPSIS" section (also printed to C<STDERR>) and +will exit with a status of 2: + + pod2usage("Syntax error."); + + pod2usage(-message => "Syntax error.", -verbose => 0); + + pod2usage(-msg => "Syntax error.", -exitval => 2); + + pod2usage({-msg => "Syntax error.", -exitval => 2, -output => \*STDERR}); + + pod2usage({-msg => "Syntax error.", -verbose => 0, -output => \*STDERR}); + + pod2usage(-msg => "Syntax error.", -exitval => 2, -verbose => 0); + + pod2usage(-message => "Syntax error.", + -exitval => 2, + -verbose => 0, + -output => \*STDERR); + +Each of the following invocations of C<pod2usage()> will print the +"SYNOPSIS" section and any "OPTIONS" and/or "ARGUMENTS" sections to +C<STDOUT> and will exit with a status of 1: + + pod2usage(1); + + pod2usage(-verbose => 1); + + pod2usage(-exitval => 1); + + pod2usage({-exitval => 1, -output => \*STDOUT}); + + pod2usage({-verbose => 1, -output => \*STDOUT}); + + pod2usage(-exitval => 1, -verbose => 1); + + pod2usage(-exitval => 1, -verbose => 1, -output => \*STDOUT}); + +Each of the following invocations of C<pod2usage()> will print the +entire manual page to C<STDOUT> and will exit with a status of 1: + + pod2usage(-verbose => 2); + + pod2usage({-verbose => 2, -output => \*STDOUT}); + + pod2usage(-exitval => 1, -verbose => 2); + + pod2usage({-exitval => 1, -verbose => 2, -output => \*STDOUT}); + +=head2 Recommended Use + +Most scripts should print some type of usage message to C<STDERR> when a +command line syntax error is detected. They should also provide an +option (usually C<-H> or C<-help>) to print a (possibly more verbose) +usage message to C<STDOUT>. Some scripts may even wish to go so far as to +provide a means of printing their complete documentation to C<STDOUT> +(perhaps by allowing a C<-man> option). The following complete example +uses B<Pod::Usage> in combination with B<Getopt::Long> to do all of these +things: + + use Getopt::Long; + use Pod::Usage; + + my $man = 0; + my $help = 0; + ## Parse options and print usage if there is a syntax error, + ## or if usage was explicitly requested. + GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); + pod2usage(1) if $help; + pod2usage(-verbose => 2) if $man; + + ## If no arguments were given, then allow STDIN to be used only + ## if it's not connected to a terminal (otherwise print usage) + pod2usage("$0: No files given.") if ((@ARGV == 0) && (-t STDIN)); + __END__ + + =head1 NAME + + sample - Using GetOpt::Long and Pod::Usage + + =head1 SYNOPSIS + + sample [options] [file ...] + + Options: + -help brief help message + -man full documentation + + =head1 OPTIONS + + =over 8 + + =item B<-help> + + Print a brief help message and exits. + + =item B<-man> + + Prints the manual page and exits. + + =back + + =head1 DESCRIPTION + + B<This program> will read the given input file(s) and do something + useful with the contents thereof. + + =cut + +=head1 CAVEATS + +By default, B<pod2usage()> will use C<$0> as the path to the pod input +file. Unfortunately, not all systems on which Perl runs will set C<$0> +properly (although if C<$0> isn't found, B<pod2usage()> will search +C<$ENV{PATH}> or else the list specified by the C<-pathlist> option). +If this is the case for your system, you may need to explicitly specify +the path to the pod docs for the invoking script using something +similar to the following: + + pod2usage(-exitval => 2, -input => "/path/to/your/pod/docs"); + +In the pathological case that a script is called via a relative path +I<and> the script itself changes the current working directory +(see L<perlfunc/chdir>) I<before> calling pod2usage, Pod::Usage will +fail even on robust platforms. Don't do that. + +=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::pod2text()> written by +Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> + +=head1 ACKNOWLEDGEMENTS + +Steven McDougall E<lt>swmcd@world.std.comE<gt> for his help and patience +with re-writing this manpage. + +=cut + +############################################################################# + +use strict; +#use diagnostics; +use Carp; +use Config; +use Exporter; +use File::Spec; + +use vars qw(@ISA @EXPORT); +@EXPORT = qw(&pod2usage); +BEGIN { + if ( $] >= 5.005_58 ) { + require Pod::Text; + @ISA = qw( Pod::Text ); + } + else { + require Pod::PlainText; + @ISA = qw( Pod::PlainText ); + } +} + + +##--------------------------------------------------------------------------- + +##--------------------------------- +## Function definitions begin here +##--------------------------------- + +sub pod2usage { + local($_) = shift; + my %opts; + ## Collect arguments + if (@_ > 0) { + ## Too many arguments - assume that this is a hash and + ## the user forgot to pass a reference to it. + %opts = ($_, @_); + } + elsif (!defined $_) { + $_ = ""; + } + elsif (ref $_) { + ## User passed a ref to a hash + %opts = %{$_} if (ref($_) eq 'HASH'); + } + elsif (/^[-+]?\d+$/) { + ## User passed in the exit value to use + $opts{"-exitval"} = $_; + } + else { + ## User passed in a message to print before issuing usage. + $_ and $opts{"-message"} = $_; + } + + ## 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 $val = $opts{$_}; + s/^(?=\w)/-/; + /^-msg/i and $_ = '-message'; + /^-exit/i and $_ = '-exitval'; + lc($_) => $val; + } (keys %opts); + + ## Now determine default -exitval and -verbose values to use + if ((! defined $opts{"-exitval"}) && (! defined $opts{"-verbose"})) { + $opts{"-exitval"} = 2; + $opts{"-verbose"} = 0; + } + elsif (! defined $opts{"-exitval"}) { + $opts{"-exitval"} = ($opts{"-verbose"} > 0) ? 1 : 2; + } + elsif (! defined $opts{"-verbose"}) { + $opts{"-verbose"} = (lc($opts{"-exitval"}) eq "noexit" || + $opts{"-exitval"} < 2); + } + + ## Default the output file + $opts{"-output"} = (lc($opts{"-exitval"}) eq "noexit" || + $opts{"-exitval"} < 2) ? \*STDOUT : \*STDERR + unless (defined $opts{"-output"}); + ## Default the input file + $opts{"-input"} = $0 unless (defined $opts{"-input"}); + + ## Look up input file in path if it doesnt exist. + unless ((ref $opts{"-input"}) || (-e $opts{"-input"})) { + my ($dirname, $basename) = ('', $opts{"-input"}); + my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/) ? ";" + : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' : ":"); + my $pathspec = $opts{"-pathlist"} || $ENV{PATH} || $ENV{PERL5LIB}; + + my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec); + for $dirname (@paths) { + $_ = File::Spec->catfile($dirname, $basename) if length; + last if (-e $_) && ($opts{"-input"} = $_); + } + } + + ## Now create a pod reader and constrain it to the desired sections. + my $parser = new Pod::Usage(USAGE_OPTIONS => \%opts); + if ($opts{"-verbose"} == 0) { + $parser->select('SYNOPSIS\s*'); + } + elsif ($opts{"-verbose"} == 1) { + my $opt_re = '(?i)' . + '(?:OPTIONS|ARGUMENTS)' . + '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?'; + $parser->select( 'SYNOPSIS', $opt_re, "DESCRIPTION/$opt_re" ); + } + elsif ($opts{"-verbose"} == 99) { + $parser->select( $opts{"-sections"} ); + $opts{"-verbose"} = 1; + } + + ## Now translate the pod document and then exit with the desired status + if ( !$opts{"-noperldoc"} + and $opts{"-verbose"} >= 2 + and !ref($opts{"-input"}) + and $opts{"-output"} == \*STDOUT ) + { + ## spit out the entire PODs. Might as well invoke perldoc + my $progpath = File::Spec->catfile($Config{scriptdir}, "perldoc"); + system($progpath, $opts{"-input"}); + } + else { + $parser->parse_from_file($opts{"-input"}, $opts{"-output"}); + } + + exit($opts{"-exitval"}) unless (lc($opts{"-exitval"}) eq 'noexit'); +} + +##--------------------------------------------------------------------------- + +##------------------------------- +## Method definitions begin here +##------------------------------- + +sub new { + my $this = shift; + my $class = ref($this) || $this; + my %params = @_; + my $self = {%params}; + bless $self, $class; + if ($self->can('initialize')) { + $self->initialize(); + } else { + $self = $self->SUPER::new(); + %$self = (%$self, %params); + } + return $self; +} + +sub select { + my ($self, @res) = @_; + if ($ISA[0]->can('select')) { + $self->SUPER::select(@_); + } else { + $self->{USAGE_SELECT} = \@res; + } +} + +# Override Pod::Text->seq_i to return just "arg", not "*arg*". +sub seq_i { return $_[1] } + +# This overrides the Pod::Text method to do something very akin to what +# Pod::Select did as well as the work done below by preprocess_paragraph. +# Note that the below is very, very specific to Pod::Text. +sub _handle_element_end { + my ($self, $element) = @_; + if ($element eq 'head1') { + $$self{USAGE_HEAD1} = $$self{PENDING}[-1][1]; + $$self{PENDING}[-1][1] =~ s/^\s*SYNOPSIS\s*$/USAGE/; + } elsif ($element eq 'head2') { + $$self{USAGE_HEAD2} = $$self{PENDING}[-1][1]; + } + if ($element eq 'head1' || $element eq 'head2') { + $$self{USAGE_SKIPPING} = 1; + my $heading = $$self{USAGE_HEAD1}; + $heading .= '/' . $$self{USAGE_HEAD2} if defined $$self{USAGE_HEAD2}; + for (@{ $$self{USAGE_SELECT} }) { + if ($heading =~ /^$_\s*$/) { + $$self{USAGE_SKIPPING} = 0; + last; + } + } + + # Try to do some lowercasing instead of all-caps in headings, and use + # a colon to end all headings. + local $_ = $$self{PENDING}[-1][1]; + s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; + s/\s*$/:/ unless (/:\s*$/); + $_ .= "\n"; + $$self{PENDING}[-1][1] = $_; + } + if ($$self{USAGE_SKIPPING}) { + pop @{ $$self{PENDING} }; + } else { + $self->SUPER::_handle_element_end($element); + } +} + +sub start_document { + my $self = shift; + $self->SUPER::start_document(); + my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; + my $out_fh = $self->output_fh(); + print $out_fh "$msg\n"; +} + +sub begin_pod { + my $self = shift; + $self->SUPER::begin_pod(); ## Have to call superclass + my $msg = $self->{USAGE_OPTIONS}->{-message} or return 1; + my $out_fh = $self->output_handle(); + print $out_fh "$msg\n"; +} + +sub preprocess_paragraph { + my $self = shift; + local $_ = shift; + my $line = shift; + ## See if this is a heading and we arent printing the entire manpage. + if (($self->{USAGE_OPTIONS}->{-verbose} < 2) && /^=head/) { + ## Change the title of the SYNOPSIS section to USAGE + s/^=head1\s+SYNOPSIS\s*$/=head1 USAGE/; + ## Try to do some lowercasing instead of all-caps in headings + s{([A-Z])([A-Z]+)}{((length($2) > 2) ? $1 : lc($1)) . lc($2)}ge; + ## Use a colon to end all headings + s/\s*$/:/ unless (/:\s*$/); + $_ .= "\n"; + } + return $self->SUPER::preprocess_paragraph($_); +} + +1; # keep require happy |