require 5;
+use 5.006; # we use some open(X, "<", $y) syntax
package Pod::Perldoc;
use strict;
use warnings;
use vars qw($VERSION @Pagers $Bindir $Pod2man
$Temp_Files_Created $Temp_File_Lifetime
);
-$VERSION = '3.08';
+$VERSION = '3.14_04';
#..........................................................................
BEGIN { # Make a DEBUG constant very first thing...
use Pod::Perldoc::GetOptsOO; # uses the DEBUG.
#..........................................................................
-{ my $pager = $Config{'pager'};
- push @Pagers, $pager if -x (split /\s+/, $pager)[0];
-}
-$Bindir = $Config{'scriptdirexp'};
-$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
-
-#..........................................................................
sub TRUE () {1}
sub FALSE () {return}
*IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32;
*IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos;
*IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2;
+ *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin;
+ *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux;
+ *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX;
}
$Temp_File_Lifetime ||= 60 * 60 * 24 * 5;
# that anyone's still looking at it!!
# (Currently used only by the MSWin cleanup routine)
+
+#..........................................................................
+{ my $pager = $Config{'pager'};
+ push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS;
+}
+$Bindir = $Config{'scriptdirexp'};
+$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' );
+
# End of class-init stuff
#
###########################################################################
#
# Option accessors...
-foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTd}) {
+foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdUL}) {
no strict 'refs';
*$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } };
}
sub opt_f_with { shift->_elem('opt_f', @_) }
sub opt_q_with { shift->_elem('opt_q', @_) }
sub opt_d_with { shift->_elem('opt_d', @_) }
+sub opt_L_with { shift->_elem('opt_L', @_) }
sub opt_w_with { # Specify an option for the formatter subclass
my($self, $value) = @_;
exit;
}
-sub opt_U {} # legacy no-op
-
sub opt_t { # choose plaintext as output format
my $self = shift;
$self->opt_o_with('text') if @_ and $_[0];
my $callsub = (caller(1))[3];
my $package = quotemeta(__PACKAGE__ . '::');
$callsub =~ s/^$package/'/os;
+ # the o is justified, as $package really won't change.
$callsub . ": ";
} : '',
@_,
-i Ignore case
-t Display pod using pod2text instead of pod2man and nroff
(-t is the default on win32 unless -n is specified)
- -u Display unformatted pod text
+ -u Display unformatted pod text
-m Display module's file in its entirety
-n Specify replacement for nroff
-l Display the module's file name
-F Arguments are file names, not modules
- -v Verbosely describe what's going on
+ -v Verbosely describe what's going on
-T Send output to STDOUT without any pager
-d output_filename_to_send_to
-o output_format_name
-M FormatterModuleNameToUse
-w formatter_option:option_value
- -X use index if present (looks for pod.idx at $Config{archlib})
+ -L translation_code Choose doc translation (if any)
+ -X use index if present (looks for pod.idx at $Config{archlib})
-q Search the text of questions (not answers) in perlfaq[1-9]
PageName|ModuleName...
$me =~ s,.*[/\\],,; # get basename
die <<"EOUSAGE";
-Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-F] [-X] PageName|ModuleName|ProgramName
+Usage: $me [-h] [-V] [-r] [-i] [-v] [-t] [-u] [-m] [-n nroffer_program] [-l] [-T] [-d output_filename] [-o output_format] [-M FormatterModuleNameToUse] [-w formatter_option:option_value] [-L translation_code] [-F] [-X] PageName|ModuleName|ProgramName
$me -f PerlFunc
$me -q FAQKeywords
DEBUG > 3 and printf "Formatter switches now: [%s]\n",
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} };
+ $self->{'translators'} = [];
+ $self->{'extra_search_dirs'} = [];
+
return;
}
$self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
$self->opt_o_with('text');
$self->opt_o_with('man') unless IS_MSWin32 || IS_Dos
- || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i);
+ || !($ENV{TERM} && (
+ ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
+ ));
return;
}
$self->opt_n("nroff") unless $self->opt_n;
$self->add_formatter_option( '__nroffer' => $self->opt_n );
+ # Adjust for using translation packages
+ $self->add_translator($self->opt_L) if $self->opt_L;
+
return;
}
# Any sanity-checking need doing here?
+ # But does not make sense to set either -f or -q in $ENV{"PERLDOC"}
+ if( $self->opt_f or $self->opt_q ) {
+ $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q;
+ warn
+ "Perldoc is only really meant for reading one word at a time.\n",
+ "So these parameters are being ignored: ",
+ join(' ', @{$self->{'args'}}),
+ "\n"
+ if @{$self->{'args'}}
+ }
return;
}
next;
}
+ my @searchdirs;
+
+ # prepend extra search directories (including language specific)
+ push @searchdirs, @{ $self->{'extra_search_dirs'} };
+
# We must look both in @INC for library modules and in $bindir
# for executables, like h2xs or perldoc itself.
-
- my @searchdirs = ($self->{'bindir'}, @INC);
+ push @searchdirs, ($self->{'bindir'}, @INC);
unless ($self->opt_m) {
if (IS_VMS) {
my($i,$trn);
$file =~ s/\.(pm|pod)\z//; # XXX: badfs
print STDERR "\tperldoc $_\::$file\n";
}
- closedir DIR or die "closedir $dir: $!";
+ closedir(DIR) or die "closedir $dir: $!";
}
}
}
push @{ $self->{'temp_file_list'} }, $buffer;
# I.e., it MIGHT be deleted at the end.
- print $buffd "=over 8\n\n";
+ my $in_list = $self->opt_f;
+
+ print $buffd "=over 8\n\n" if $in_list;
print $buffd @dynamic_pod or die "Can't print $buffer: $!";
- print $buffd "=back\n";
+ print $buffd "=back\n" if $in_list;
+
close $buffd or die "Can't close $buffer: $!";
@$found_things = $buffer;
return;
}
+#.........................................................................
+
+sub new_translator { # $tr = $self->new_translator($lang);
+ my $self = shift;
+ my $lang = shift;
+
+ my $pack = 'POD2::' . uc($lang);
+ eval "require $pack";
+ if ( !$@ && $pack->can('new') ) {
+ return $pack->new();
+ }
+
+ eval { require POD2::Base };
+ return if $@;
+
+ return POD2::Base->new({ lang => $lang });
+}
+
+#.........................................................................
+
+sub add_translator { # $self->add_translator($lang);
+ my $self = shift;
+ for my $lang (@_) {
+ my $tr = $self->new_translator($lang);
+ if ( defined $tr ) {
+ push @{ $self->{'translators'} }, $tr;
+ push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs;
+
+ $self->aside( "translator for '$lang' loaded\n" );
+ } else {
+ # non-installed or bad translator package
+ warn "Perldoc cannot load translator package for '$lang': ignored\n";
+ }
+
+ }
+ return;
+}
+
#..........................................................................
sub search_perlfunc {
or die("Can't open $perlfunc: $!");
# Functions like -r, -e, etc. are listed under `-X'.
- my $search_string = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
- ? 'I<-X' : $self->opt_f ;
-
+ my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
+ ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
+
DEBUG > 2 and
- print "Going to perlfunc-scan for $search_string in $perlfunc\n";
-
-
+ print "Going to perlfunc-scan for $search_re in $perlfunc\n";
+
+ my $re = 'Alphabetical Listing of Perl Functions';
+ if ( $self->opt_L ) {
+ my $tr = $self->{'translators'}->[0];
+ $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
+ }
+
# Skip introduction
local $_;
while (<PFUNC>) {
- last if /^=head2 Alphabetical Listing of Perl Functions/;
+ last if /^=head2 $re/;
}
# Look for our function
my $found = 0;
my $inlist = 0;
while (<PFUNC>) { # "The Mothership Connection is here!"
- if (/^=item\s+\Q$search_string\E\b/o) {
+ if ( m/^=item\s+$search_re\b/ ) {
$found = 1;
}
elsif (/^=item/) {
my $found = 0;
my %found_in;
my $search_key = $self->opt_q;
- my $rx = eval { qr/$search_key/ } or die <<EOD;
+
+ my $rx = eval { qr/$search_key/ }
+ or die <<EOD;
Invalid regular expression '$search_key' given as -q pattern:
$@
Did you mean \\Q$search_key ?
local $_;
foreach my $file (@$found_things) {
die "invalid file spec: $!" if $file =~ /[<>|]/;
- open(INFAQ, "<", $file) or die "Can't read-open $file: $!\nAborting";
+ open(INFAQ, "<", $file) # XXX 5.6ism
+ or die "Can't read-open $file: $!\nAborting";
while (<INFAQ>) {
- if (/^=head2\s+.*(?:$search_key)/oi) { # it's good for only one key
+ if ( m/^=head2\s+.*(?:$search_key)/i ) {
$found = 1;
push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
}
die "Nothing found?!";
# should have been caught before here
} elsif(@$found_things > 1) {
- warn join '',
+ warn
"Perldoc is only really meant for reading one document at a time.\n",
"So these parameters are being ignored: ",
join(' ', @$found_things[1 .. $#$found_things] ),
my $spec;
do {
- $spec = sprintf "%s/perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
+ $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup
# Yes, we embed the create-time in the filename!
$tempdir,
$infix || 'x',
$fh = Symbol::gensym();
}
DEBUG > 3 and print "About to try making temp file $spec\n";
- return($fh, $spec) if open($fh, ">", $spec);
+ return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism
$self->aside("Can't create temp file $spec: $!\n");
}
push @pagers, qw( more less pg view cat );
unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
}
+
+ if (IS_Cygwin) {
+ if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) {
+ unshift @pagers, '/usr/bin/less -isrR';
+ }
+ }
+
unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
return;
local $_;
my $any_error = 0;
foreach my $output (@found) {
- unless( open(TMP, "<", $output) ) {
+ unless( open(TMP, "<", $output) ) { # XXX 5.6ism
warn("Can't open $output: $!");
$any_error = 1;
next;
unless( ref $self ) {
# Should never get called:
$Carp::Verbose = 1;
- Carp::croak join '',
+ require Carp;
+ Carp::croak( join '',
"Crazy ", __PACKAGE__, " error:\n",
"check_file must be an object_method!\n",
"Aborting"
+ );
}
if(length $dir and not -d $dir) {
sub containspod {
my($self, $file, $readit) = @_;
return 1 if !$readit && $file =~ /\.pod\z/i;
+
+
+ # Under cygwin the /usr/bin/perl is legal executable, but
+ # you cannot open a file with that name. It must be spelled
+ # out as "/usr/bin/perl.exe".
+ #
+ # The following if-case under cygwin prevents error
+ #
+ # $ perldoc perl
+ # Cannot open /usr/bin/perl: no such file or directory
+ #
+ # This would work though
+ #
+ # $ perldoc perl.pod
+
+ if ( IS_Cygwin and -x $file and -f "$file.exe" )
+ {
+ warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_v;
+ return 0;
+ }
+
local($_);
- open(TEST,"<", $file) or die "Can't open $file: $!";
+ open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism
while (<TEST>) {
if (/^=head/) {
close(TEST) or die "Can't close $file: $!";
# Does this look like a module or extension directory?
- if (-f "Makefile.PL") {
+ if (-f "Makefile.PL" || -f "Build.PL") {
# Add "." and "lib" to @INC (if they exist)
eval q{ use lib qw(. lib); 1; } or die;
# don't add if superuser
- if ($< && $> && -f "blib") { # don't be looking too hard now!
+ if ($< && $> && -d "blib") { # don't be looking too hard now!
eval q{ use blib; 1 };
warn $@ if $@ && $self->opt_v;
}
$fh = Symbol::gensym();
}
DEBUG > 3 and print "About to try writing to specified output file $outspec\n";
- die "Can't write-open $outspec: $!" unless open($fh, ">", $outspec);
+ die "Can't write-open $outspec: $!"
+ unless open($fh, ">", $outspec); # XXX 5.6ism
+
DEBUG > 3 and print "Successfully opened $outspec\n";
binmode($fh) if $self->{'output_is_binary'};
return($fh, $outspec);
my ($self, $output, $output_to_stdout, @pagers) = @_;
if ($output_to_stdout) {
$self->aside("Sending unpaged output to STDOUT.\n");
- open(TMP, "<", $output) or die "Can't open $output: $!";
+ open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism
local $_;
while (<TMP>) {
print or die "Can't print to stdout: $!";
# extension get the wrong default extension (such as .LIS for TYPE)
$output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS;
+
+ $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos;
+ # Altho "/" under MSWin is in theory good as a pathsep,
+ # many many corners of the OS don't like it. So we
+ # have to force it to be "\" to make everyone happy.
+
foreach my $pager (@pagers) {
$self->aside("About to try calling $pager $output\n");
if (IS_VMS) {
$self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename?
for ($i=0; $i<@dirs; $i++) {
$dir = $dirs[$i];
+ next unless -d $dir;
($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS;
if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod")))
or ( $ret = $self->check_file($dir,"$s.pm"))
$< = $id; # real uid
$> = $id; # effective uid
};
- die "Superuser must not run $0 without security audit and taint checks.\n"
- unless !$@ && $< && $>;
+ if( !$@ && $< && $> ) {
+ DEBUG and print "OK, I dropped privileges.\n";
+ } elsif( $self->opt_U ) {
+ DEBUG and print "Couldn't drop privileges, but in -U mode, so feh."
+ } else {
+ DEBUG and print "Hm, couldn't drop privileges. Ah well.\n";
+ # We used to die here; but that seemed pointless.
+ }
}
return;
}
# it'll run faster.
#
# Version 1.01: Tue May 30 14:47:34 EDT 1995
-# Andy Dougherty <doughera@lafayette.edu>
+# Andy Dougherty <doughera@lafcol.lafayette.edu>
# -added pod documentation.
# -added PATH searching.
# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
projects / p5sagit/p5-mst-13.2.git / blobdiff