| 1 |
|
| 2 |
require 5; |
| 3 |
use 5.006; # we use some open(X, "<", $y) syntax |
| 4 |
package Pod::Perldoc; |
| 5 |
use strict; |
| 6 |
use warnings; |
| 7 |
use Config '%Config'; |
| 8 |
|
| 9 |
use Fcntl; # for sysopen |
| 10 |
use File::Spec::Functions qw(catfile catdir splitdir); |
| 11 |
|
| 12 |
use vars qw($VERSION @Pagers $Bindir $Pod2man |
| 13 |
$Temp_Files_Created $Temp_File_Lifetime |
| 14 |
); |
| 15 |
$VERSION = '3.14'; |
| 16 |
#.......................................................................... |
| 17 |
|
| 18 |
BEGIN { # Make a DEBUG constant very first thing... |
| 19 |
unless(defined &DEBUG) { |
| 20 |
if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint |
| 21 |
eval("sub DEBUG () {$1}"); |
| 22 |
die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@; |
| 23 |
} else { |
| 24 |
*DEBUG = sub () {0}; |
| 25 |
} |
| 26 |
} |
| 27 |
} |
| 28 |
|
| 29 |
use Pod::Perldoc::GetOptsOO; # uses the DEBUG. |
| 30 |
|
| 31 |
#.......................................................................... |
| 32 |
|
| 33 |
sub TRUE () {1} |
| 34 |
sub FALSE () {return} |
| 35 |
|
| 36 |
BEGIN { |
| 37 |
*IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS; |
| 38 |
*IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32; |
| 39 |
*IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos; |
| 40 |
*IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2; |
| 41 |
*IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin; |
| 42 |
*IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux; |
| 43 |
*IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX; |
| 44 |
} |
| 45 |
|
| 46 |
$Temp_File_Lifetime ||= 60 * 60 * 24 * 5; |
| 47 |
# If it's older than five days, it's quite unlikely |
| 48 |
# that anyone's still looking at it!! |
| 49 |
# (Currently used only by the MSWin cleanup routine) |
| 50 |
|
| 51 |
|
| 52 |
#.......................................................................... |
| 53 |
{ my $pager = $Config{'pager'}; |
| 54 |
push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS; |
| 55 |
} |
| 56 |
$Bindir = $Config{'scriptdirexp'}; |
| 57 |
$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); |
| 58 |
|
| 59 |
# End of class-init stuff |
| 60 |
# |
| 61 |
########################################################################### |
| 62 |
# |
| 63 |
# Option accessors... |
| 64 |
|
| 65 |
foreach my $subname (map "opt_$_", split '', q{mhlvriFfXqnTdU}) { |
| 66 |
no strict 'refs'; |
| 67 |
*$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; |
| 68 |
} |
| 69 |
|
| 70 |
# And these are so that GetOptsOO knows they take options: |
| 71 |
sub opt_f_with { shift->_elem('opt_f', @_) } |
| 72 |
sub opt_q_with { shift->_elem('opt_q', @_) } |
| 73 |
sub opt_d_with { shift->_elem('opt_d', @_) } |
| 74 |
|
| 75 |
sub opt_w_with { # Specify an option for the formatter subclass |
| 76 |
my($self, $value) = @_; |
| 77 |
if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) { |
| 78 |
my $option = $1; |
| 79 |
my $option_value = defined($2) ? $2 : "TRUE"; |
| 80 |
$option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" |
| 81 |
$self->add_formatter_option( $option, $option_value ); |
| 82 |
} else { |
| 83 |
warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n"; |
| 84 |
} |
| 85 |
return; |
| 86 |
} |
| 87 |
|
| 88 |
sub opt_M_with { # specify formatter class name(s) |
| 89 |
my($self, $classes) = @_; |
| 90 |
return unless defined $classes and length $classes; |
| 91 |
DEBUG > 4 and print "Considering new formatter classes -M$classes\n"; |
| 92 |
my @classes_to_add; |
| 93 |
foreach my $classname (split m/[,;]+/s, $classes) { |
| 94 |
next unless $classname =~ m/\S/; |
| 95 |
if( $classname =~ m/^(\w+(::\w+)+)$/s ) { |
| 96 |
# A mildly restrictive concept of what modulenames are valid. |
| 97 |
push @classes_to_add, $1; # untaint |
| 98 |
} else { |
| 99 |
warn "\"$classname\" isn't a valid classname. Ignoring.\n"; |
| 100 |
} |
| 101 |
} |
| 102 |
|
| 103 |
unshift @{ $self->{'formatter_classes'} }, @classes_to_add; |
| 104 |
|
| 105 |
DEBUG > 3 and print( |
| 106 |
"Adding @classes_to_add to the list of formatter classes, " |
| 107 |
. "making them @{ $self->{'formatter_classes'} }.\n" |
| 108 |
); |
| 109 |
|
| 110 |
return; |
| 111 |
} |
| 112 |
|
| 113 |
sub opt_V { # report version and exit |
| 114 |
print join '', |
| 115 |
"Perldoc v$VERSION, under perl v$] for $^O", |
| 116 |
|
| 117 |
(defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) |
| 118 |
? (" (win32 build ", &Win32::BuildNumber(), ")") : (), |
| 119 |
|
| 120 |
(chr(65) eq 'A') ? () : " (non-ASCII)", |
| 121 |
|
| 122 |
"\n", |
| 123 |
; |
| 124 |
exit; |
| 125 |
} |
| 126 |
|
| 127 |
sub opt_t { # choose plaintext as output format |
| 128 |
my $self = shift; |
| 129 |
$self->opt_o_with('text') if @_ and $_[0]; |
| 130 |
return $self->_elem('opt_t', @_); |
| 131 |
} |
| 132 |
|
| 133 |
sub opt_u { # choose raw pod as output format |
| 134 |
my $self = shift; |
| 135 |
$self->opt_o_with('pod') if @_ and $_[0]; |
| 136 |
return $self->_elem('opt_u', @_); |
| 137 |
} |
| 138 |
|
| 139 |
sub opt_n_with { |
| 140 |
# choose man as the output format, and specify the proggy to run |
| 141 |
my $self = shift; |
| 142 |
$self->opt_o_with('man') if @_ and $_[0]; |
| 143 |
$self->_elem('opt_n', @_); |
| 144 |
} |
| 145 |
|
| 146 |
sub opt_o_with { # "o" for output format |
| 147 |
my($self, $rest) = @_; |
| 148 |
return unless defined $rest and length $rest; |
| 149 |
if($rest =~ m/^(\w+)$/s) { |
| 150 |
$rest = $1; #untaint |
| 151 |
} else { |
| 152 |
warn "\"$rest\" isn't a valid output format. Skipping.\n"; |
| 153 |
return; |
| 154 |
} |
| 155 |
|
| 156 |
$self->aside("Noting \"$rest\" as desired output format...\n"); |
| 157 |
|
| 158 |
# Figure out what class(es) that could actually mean... |
| 159 |
|
| 160 |
my @classes; |
| 161 |
foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { |
| 162 |
# Messy but smart: |
| 163 |
foreach my $stem ( |
| 164 |
$rest, # Yes, try it first with the given capitalization |
| 165 |
"\L$rest", "\L\u$rest", "\U$rest" # And then try variations |
| 166 |
|
| 167 |
) { |
| 168 |
push @classes, $prefix . $stem; |
| 169 |
#print "Considering $prefix$stem\n"; |
| 170 |
} |
| 171 |
|
| 172 |
# Tidier, but misses too much: |
| 173 |
#push @classes, $prefix . ucfirst(lc($rest)); |
| 174 |
} |
| 175 |
$self->opt_M_with( join ";", @classes ); |
| 176 |
return; |
| 177 |
} |
| 178 |
|
| 179 |
########################################################################### |
| 180 |
# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % |
| 181 |
|
| 182 |
sub run { # to be called by the "perldoc" executable |
| 183 |
my $class = shift; |
| 184 |
if(DEBUG > 3) { |
| 185 |
print "Parameters to $class\->run:\n"; |
| 186 |
my @x = @_; |
| 187 |
while(@x) { |
| 188 |
$x[1] = '<undef>' unless defined $x[1]; |
| 189 |
$x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; |
| 190 |
print " [$x[0]] => [$x[1]]\n"; |
| 191 |
splice @x,0,2; |
| 192 |
} |
| 193 |
print "\n"; |
| 194 |
} |
| 195 |
return $class -> new(@_) -> process() || 0; |
| 196 |
} |
| 197 |
|
| 198 |
# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % |
| 199 |
########################################################################### |
| 200 |
|
| 201 |
sub new { # yeah, nothing fancy |
| 202 |
my $class = shift; |
| 203 |
my $new = bless {@_}, (ref($class) || $class); |
| 204 |
DEBUG > 1 and print "New $class object $new\n"; |
| 205 |
$new->init(); |
| 206 |
$new; |
| 207 |
} |
| 208 |
|
| 209 |
#.......................................................................... |
| 210 |
|
| 211 |
sub aside { # If we're in -v or DEBUG mode, say this. |
| 212 |
my $self = shift; |
| 213 |
if( DEBUG or $self->opt_v ) { |
| 214 |
my $out = join( '', |
| 215 |
DEBUG ? do { |
| 216 |
my $callsub = (caller(1))[3]; |
| 217 |
my $package = quotemeta(__PACKAGE__ . '::'); |
| 218 |
$callsub =~ s/^$package/'/os; |
| 219 |
# the o is justified, as $package really won't change. |
| 220 |
$callsub . ": "; |
| 221 |
} : '', |
| 222 |
@_, |
| 223 |
); |
| 224 |
if(DEBUG) { print $out } else { print STDERR $out } |
| 225 |
} |
| 226 |
return; |
| 227 |
} |
| 228 |
|
| 229 |
#.......................................................................... |
| 230 |
|
| 231 |
sub usage { |
| 232 |
my $self = shift; |
| 233 |
warn "@_\n" if @_; |
| 234 |
|
| 235 |
# Erase evidence of previous errors (if any), so exit status is simple. |
| 236 |
$! = 0; |
| 237 |
|
| 238 |
die <<EOF; |
| 239 |
perldoc [options] PageName|ModuleName|ProgramName... |
| 240 |
perldoc [options] -f BuiltinFunction |
| 241 |
perldoc [options] -q FAQRegex |
| 242 |
|
| 243 |
Options: |
| 244 |
-h Display this help message |
| 245 |
-V report version |
| 246 |
-r Recursive search (slow) |
| 247 |
-i Ignore case |
| 248 |
-t Display pod using pod2text instead of pod2man and nroff |
| 249 |
(-t is the default on win32 unless -n is specified) |
| 250 |
-u Display unformatted pod text |
| 251 |
-m Display module's file in its entirety |
| 252 |
-n Specify replacement for nroff |
| 253 |
-l Display the module's file name |
| 254 |
-F Arguments are file names, not modules |
| 255 |
-v Verbosely describe what's going on |
| 256 |
-T Send output to STDOUT without any pager |
| 257 |
-d output_filename_to_send_to |
| 258 |
-o output_format_name |
| 259 |
-M FormatterModuleNameToUse |
| 260 |
-w formatter_option:option_value |
| 261 |
-X use index if present (looks for pod.idx at $Config{archlib}) |
| 262 |
-q Search the text of questions (not answers) in perlfaq[1-9] |
| 263 |
|
| 264 |
PageName|ModuleName... |
| 265 |
is the name of a piece of documentation that you want to look at. You |
| 266 |
may either give a descriptive name of the page (as in the case of |
| 267 |
`perlfunc') the name of a module, either like `Term::Info' or like |
| 268 |
`Term/Info', or the name of a program, like `perldoc'. |
| 269 |
|
| 270 |
BuiltinFunction |
| 271 |
is the name of a perl function. Will extract documentation from |
| 272 |
`perlfunc'. |
| 273 |
|
| 274 |
FAQRegex |
| 275 |
is a regex. Will search perlfaq[1-9] for and extract any |
| 276 |
questions that match. |
| 277 |
|
| 278 |
Any switches in the PERLDOC environment variable will be used before the |
| 279 |
command line arguments. The optional pod index file contains a list of |
| 280 |
filenames, one per line. |
| 281 |
[Perldoc v$VERSION] |
| 282 |
EOF |
| 283 |
|
| 284 |
} |
| 285 |
|
| 286 |
#.......................................................................... |
| 287 |
|
| 288 |
sub usage_brief { |
| 289 |
my $me = $0; # Editing $0 is unportable |
| 290 |
|
| 291 |
$me =~ s,.*[/\\],,; # get basename |
| 292 |
|
| 293 |
die <<"EOUSAGE"; |
| 294 |
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 |
| 295 |
$me -f PerlFunc |
| 296 |
$me -q FAQKeywords |
| 297 |
|
| 298 |
The -h option prints more help. Also try "perldoc perldoc" to get |
| 299 |
acquainted with the system. [Perldoc v$VERSION] |
| 300 |
EOUSAGE |
| 301 |
|
| 302 |
} |
| 303 |
|
| 304 |
#.......................................................................... |
| 305 |
|
| 306 |
sub pagers { @{ shift->{'pagers'} } } |
| 307 |
|
| 308 |
#.......................................................................... |
| 309 |
|
| 310 |
sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_) |
| 311 |
if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] } |
| 312 |
else { return $_[0]{ $_[1] } } |
| 313 |
} |
| 314 |
#.......................................................................... |
| 315 |
########################################################################### |
| 316 |
# |
| 317 |
# Init formatter switches, and start it off with __bindir and all that |
| 318 |
# other stuff that ToMan.pm needs. |
| 319 |
# |
| 320 |
|
| 321 |
sub init { |
| 322 |
my $self = shift; |
| 323 |
|
| 324 |
# Make sure creat()s are neither too much nor too little |
| 325 |
eval { umask(0077) }; # doubtless someone has no mask |
| 326 |
|
| 327 |
$self->{'args'} ||= \@ARGV; |
| 328 |
$self->{'found'} ||= []; |
| 329 |
$self->{'temp_file_list'} ||= []; |
| 330 |
|
| 331 |
|
| 332 |
$self->{'target'} = undef; |
| 333 |
|
| 334 |
$self->init_formatter_class_list; |
| 335 |
|
| 336 |
$self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; |
| 337 |
$self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; |
| 338 |
$self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; |
| 339 |
|
| 340 |
push @{ $self->{'formatter_switches'} = [] }, ( |
| 341 |
# Yeah, we could use a hashref, but maybe there's some class where options |
| 342 |
# have to be ordered; so we'll use an arrayref. |
| 343 |
|
| 344 |
[ '__bindir' => $self->{'bindir' } ], |
| 345 |
[ '__pod2man' => $self->{'pod2man'} ], |
| 346 |
); |
| 347 |
|
| 348 |
DEBUG > 3 and printf "Formatter switches now: [%s]\n", |
| 349 |
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; |
| 350 |
|
| 351 |
return; |
| 352 |
} |
| 353 |
|
| 354 |
#.......................................................................... |
| 355 |
|
| 356 |
sub init_formatter_class_list { |
| 357 |
my $self = shift; |
| 358 |
$self->{'formatter_classes'} ||= []; |
| 359 |
|
| 360 |
# Remember, no switches have been read yet, when |
| 361 |
# we've started this routine. |
| 362 |
|
| 363 |
$self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru |
| 364 |
$self->opt_o_with('text'); |
| 365 |
$self->opt_o_with('man') unless IS_MSWin32 || IS_Dos |
| 366 |
|| !($ENV{TERM} && ( |
| 367 |
($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i |
| 368 |
)); |
| 369 |
|
| 370 |
return; |
| 371 |
} |
| 372 |
|
| 373 |
#.......................................................................... |
| 374 |
|
| 375 |
sub process { |
| 376 |
# if this ever returns, its retval will be used for exit(RETVAL) |
| 377 |
|
| 378 |
my $self = shift; |
| 379 |
DEBUG > 1 and print " Beginning process.\n"; |
| 380 |
DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n"; |
| 381 |
if(DEBUG > 3) { |
| 382 |
print "Object contents:\n"; |
| 383 |
my @x = %$self; |
| 384 |
while(@x) { |
| 385 |
$x[1] = '<undef>' unless defined $x[1]; |
| 386 |
$x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; |
| 387 |
print " [$x[0]] => [$x[1]]\n"; |
| 388 |
splice @x,0,2; |
| 389 |
} |
| 390 |
print "\n"; |
| 391 |
} |
| 392 |
|
| 393 |
# TODO: make it deal with being invoked as various different things |
| 394 |
# such as perlfaq". |
| 395 |
|
| 396 |
return $self->usage_brief unless @{ $self->{'args'} }; |
| 397 |
$self->pagers_guessing; |
| 398 |
$self->options_reading; |
| 399 |
$self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); |
| 400 |
$self->drop_privs_maybe; |
| 401 |
$self->options_processing; |
| 402 |
|
| 403 |
# Hm, we have @pages and @found, but we only really act on one |
| 404 |
# file per call, with the exception of the opt_q hack, and with |
| 405 |
# -l things |
| 406 |
|
| 407 |
$self->aside("\n"); |
| 408 |
|
| 409 |
my @pages; |
| 410 |
$self->{'pages'} = \@pages; |
| 411 |
if( $self->opt_f) { @pages = ("perlfunc") } |
| 412 |
elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } |
| 413 |
else { @pages = @{$self->{'args'}}; |
| 414 |
# @pages = __FILE__ |
| 415 |
# if @pages == 1 and $pages[0] eq 'perldoc'; |
| 416 |
} |
| 417 |
|
| 418 |
return $self->usage_brief unless @pages; |
| 419 |
|
| 420 |
$self->find_good_formatter_class(); |
| 421 |
$self->formatter_sanity_check(); |
| 422 |
|
| 423 |
$self->maybe_diddle_INC(); |
| 424 |
# for when we're apparently in a module or extension directory |
| 425 |
|
| 426 |
my @found = $self->grand_search_init(\@pages); |
| 427 |
exit (IS_VMS ? 98962 : 1) unless @found; |
| 428 |
|
| 429 |
if ($self->opt_l) { |
| 430 |
DEBUG and print "We're in -l mode, so byebye after this:\n"; |
| 431 |
print join("\n", @found), "\n"; |
| 432 |
return; |
| 433 |
} |
| 434 |
|
| 435 |
$self->tweak_found_pathnames(\@found); |
| 436 |
$self->assert_closing_stdout; |
| 437 |
return $self->page_module_file(@found) if $self->opt_m; |
| 438 |
DEBUG > 2 and print "Found: [@found]\n"; |
| 439 |
|
| 440 |
return $self->render_and_page(\@found); |
| 441 |
} |
| 442 |
|
| 443 |
#.......................................................................... |
| 444 |
{ |
| 445 |
|
| 446 |
my( %class_seen, %class_loaded ); |
| 447 |
sub find_good_formatter_class { |
| 448 |
my $self = $_[0]; |
| 449 |
my @class_list = @{ $self->{'formatter_classes'} || [] }; |
| 450 |
die "WHAT? Nothing in the formatter class list!?" unless @class_list; |
| 451 |
|
| 452 |
my $good_class_found; |
| 453 |
foreach my $c (@class_list) { |
| 454 |
DEBUG > 4 and print "Trying to load $c...\n"; |
| 455 |
if($class_loaded{$c}) { |
| 456 |
DEBUG > 4 and print "OK, the already-loaded $c it is!\n"; |
| 457 |
$good_class_found = $c; |
| 458 |
last; |
| 459 |
} |
| 460 |
|
| 461 |
if($class_seen{$c}) { |
| 462 |
DEBUG > 4 and print |
| 463 |
"I've tried $c before, and it's no good. Skipping.\n"; |
| 464 |
next; |
| 465 |
} |
| 466 |
|
| 467 |
$class_seen{$c} = 1; |
| 468 |
|
| 469 |
if( $c->can('parse_from_file') ) { |
| 470 |
DEBUG > 4 and print |
| 471 |
"Interesting, the formatter class $c is already loaded!\n"; |
| 472 |
|
| 473 |
} elsif( |
| 474 |
(IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2) |
| 475 |
# the alway case-insensitive fs's |
| 476 |
and $class_seen{lc("~$c")}++ |
| 477 |
) { |
| 478 |
DEBUG > 4 and print |
| 479 |
"We already used something quite like \"\L$c\E\", so no point using $c\n"; |
| 480 |
# This avoids redefining the package. |
| 481 |
} else { |
| 482 |
DEBUG > 4 and print "Trying to eval 'require $c'...\n"; |
| 483 |
|
| 484 |
local $^W = $^W; |
| 485 |
if(DEBUG() or $self->opt_v) { |
| 486 |
# feh, let 'em see it |
| 487 |
} else { |
| 488 |
$^W = 0; |
| 489 |
# The average user just has no reason to be seeing |
| 490 |
# $^W-suppressable warnings from the the require! |
| 491 |
} |
| 492 |
|
| 493 |
eval "require $c"; |
| 494 |
if($@) { |
| 495 |
DEBUG > 4 and print "Couldn't load $c: $!\n"; |
| 496 |
next; |
| 497 |
} |
| 498 |
} |
| 499 |
|
| 500 |
if( $c->can('parse_from_file') ) { |
| 501 |
DEBUG > 4 and print "Settling on $c\n"; |
| 502 |
my $v = $c->VERSION; |
| 503 |
$v = ( defined $v and length $v ) ? " version $v" : ''; |
| 504 |
$self->aside("Formatter class $c$v successfully loaded!\n"); |
| 505 |
$good_class_found = $c; |
| 506 |
last; |
| 507 |
} else { |
| 508 |
DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; |
| 509 |
} |
| 510 |
} |
| 511 |
|
| 512 |
die "Can't find any loadable formatter class in @class_list?!\nAborting" |
| 513 |
unless $good_class_found; |
| 514 |
|
| 515 |
$self->{'formatter_class'} = $good_class_found; |
| 516 |
$self->aside("Will format with the class $good_class_found\n"); |
| 517 |
|
| 518 |
return; |
| 519 |
} |
| 520 |
|
| 521 |
} |
| 522 |
#.......................................................................... |
| 523 |
|
| 524 |
sub formatter_sanity_check { |
| 525 |
my $self = shift; |
| 526 |
my $formatter_class = $self->{'formatter_class'} |
| 527 |
|| die "NO FORMATTER CLASS YET!?"; |
| 528 |
|
| 529 |
if(!$self->opt_T # so -T can FORCE sending to STDOUT |
| 530 |
and $formatter_class->can('is_pageable') |
| 531 |
and !$formatter_class->is_pageable |
| 532 |
and !$formatter_class->can('page_for_perldoc') |
| 533 |
) { |
| 534 |
my $ext = |
| 535 |
($formatter_class->can('output_extension') |
| 536 |
&& $formatter_class->output_extension |
| 537 |
) || ''; |
| 538 |
$ext = ".$ext" if length $ext; |
| 539 |
|
| 540 |
die |
| 541 |
"When using Perldoc to format with $formatter_class, you have to\n" |
| 542 |
. "specify -T or -dsomefile$ext\n" |
| 543 |
. "See `perldoc perldoc' for more information on those switches.\n" |
| 544 |
; |
| 545 |
} |
| 546 |
} |
| 547 |
|
| 548 |
#.......................................................................... |
| 549 |
|
| 550 |
sub render_and_page { |
| 551 |
my($self, $found_list) = @_; |
| 552 |
|
| 553 |
$self->maybe_generate_dynamic_pod($found_list); |
| 554 |
|
| 555 |
my($out, $formatter) = $self->render_findings($found_list); |
| 556 |
|
| 557 |
if($self->opt_d) { |
| 558 |
printf "Perldoc (%s) output saved to %s\n", |
| 559 |
$self->{'formatter_class'} || ref($self), |
| 560 |
$out; |
| 561 |
print "But notice that it's 0 bytes long!\n" unless -s $out; |
| 562 |
|
| 563 |
|
| 564 |
} elsif( # Allow the formatter to "page" itself, if it wants. |
| 565 |
$formatter->can('page_for_perldoc') |
| 566 |
and do { |
| 567 |
$self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n"); |
| 568 |
if( $formatter->page_for_perldoc($out, $self) ) { |
| 569 |
$self->aside("page_for_perldoc returned true, so NOT paging with $self.\n"); |
| 570 |
1; |
| 571 |
} else { |
| 572 |
$self->aside("page_for_perldoc returned false, so paging with $self instead.\n"); |
| 573 |
''; |
| 574 |
} |
| 575 |
} |
| 576 |
) { |
| 577 |
# Do nothing, since the formatter has "paged" it for itself. |
| 578 |
|
| 579 |
} else { |
| 580 |
# Page it normally (internally) |
| 581 |
|
| 582 |
if( -s $out ) { # Usual case: |
| 583 |
$self->page($out, $self->{'output_to_stdout'}, $self->pagers); |
| 584 |
|
| 585 |
} else { |
| 586 |
# Odd case: |
| 587 |
$self->aside("Skipping $out (from $$found_list[0] " |
| 588 |
. "via $$self{'formatter_class'}) as it is 0-length.\n"); |
| 589 |
|
| 590 |
push @{ $self->{'temp_file_list'} }, $out; |
| 591 |
$self->unlink_if_temp_file($out); |
| 592 |
} |
| 593 |
} |
| 594 |
|
| 595 |
$self->after_rendering(); # any extra cleanup or whatever |
| 596 |
|
| 597 |
return; |
| 598 |
} |
| 599 |
|
| 600 |
#.......................................................................... |
| 601 |
|
| 602 |
sub options_reading { |
| 603 |
my $self = shift; |
| 604 |
|
| 605 |
if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { |
| 606 |
require Text::ParseWords; |
| 607 |
$self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); |
| 608 |
# Yes, appends to the beginning |
| 609 |
unshift @{ $self->{'args'} }, |
| 610 |
Text::ParseWords::shellwords( $ENV{"PERLDOC"} ) |
| 611 |
; |
| 612 |
DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n"; |
| 613 |
} else { |
| 614 |
DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n"; |
| 615 |
} |
| 616 |
|
| 617 |
DEBUG > 1 |
| 618 |
and print " Args right before switch processing: @{$self->{'args'}}\n"; |
| 619 |
|
| 620 |
Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' ) |
| 621 |
or return $self->usage; |
| 622 |
|
| 623 |
DEBUG > 1 |
| 624 |
and print " Args after switch processing: @{$self->{'args'}}\n"; |
| 625 |
|
| 626 |
return $self->usage if $self->opt_h; |
| 627 |
|
| 628 |
return; |
| 629 |
} |
| 630 |
|
| 631 |
#.......................................................................... |
| 632 |
|
| 633 |
sub options_processing { |
| 634 |
my $self = shift; |
| 635 |
|
| 636 |
if ($self->opt_X) { |
| 637 |
my $podidx = "$Config{'archlib'}/pod.idx"; |
| 638 |
$podidx = "" unless -f $podidx && -r _ && -M _ <= 7; |
| 639 |
$self->{'podidx'} = $podidx; |
| 640 |
} |
| 641 |
|
| 642 |
$self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT; |
| 643 |
|
| 644 |
$self->options_sanity; |
| 645 |
|
| 646 |
$self->opt_n("nroff") unless $self->opt_n; |
| 647 |
$self->add_formatter_option( '__nroffer' => $self->opt_n ); |
| 648 |
|
| 649 |
return; |
| 650 |
} |
| 651 |
|
| 652 |
#.......................................................................... |
| 653 |
|
| 654 |
sub options_sanity { |
| 655 |
my $self = shift; |
| 656 |
|
| 657 |
# The opts-counting stuff interacts quite badly with |
| 658 |
# the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"} |
| 659 |
# set to -t, and I specify -u on the command line, I don't want |
| 660 |
# to be hectored at that -u and -t don't make sense together. |
| 661 |
|
| 662 |
#my $opts = grep $_ && 1, # yes, the count of the set ones |
| 663 |
# $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l |
| 664 |
#; |
| 665 |
# |
| 666 |
#$self->usage("only one of -t, -u, -m or -l") if $opts > 1; |
| 667 |
|
| 668 |
|
| 669 |
# Any sanity-checking need doing here? |
| 670 |
|
| 671 |
return; |
| 672 |
} |
| 673 |
|
| 674 |
#.......................................................................... |
| 675 |
|
| 676 |
sub grand_search_init { |
| 677 |
my($self, $pages, @found) = @_; |
| 678 |
|
| 679 |
foreach (@$pages) { |
| 680 |
if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { |
| 681 |
my $searchfor = catfile split '::', $_; |
| 682 |
$self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); |
| 683 |
local $_; |
| 684 |
while (<PODIDX>) { |
| 685 |
chomp; |
| 686 |
push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; |
| 687 |
} |
| 688 |
close(PODIDX) or die "Can't close $$self{'podidx'}: $!"; |
| 689 |
next; |
| 690 |
} |
| 691 |
|
| 692 |
$self->aside( "Searching for $_\n" ); |
| 693 |
|
| 694 |
if ($self->opt_F) { |
| 695 |
next unless -r; |
| 696 |
push @found, $_ if $self->opt_m or $self->containspod($_); |
| 697 |
next; |
| 698 |
} |
| 699 |
|
| 700 |
# We must look both in @INC for library modules and in $bindir |
| 701 |
# for executables, like h2xs or perldoc itself. |
| 702 |
|
| 703 |
my @searchdirs = ($self->{'bindir'}, @INC); |
| 704 |
unless ($self->opt_m) { |
| 705 |
if (IS_VMS) { |
| 706 |
my($i,$trn); |
| 707 |
for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { |
| 708 |
push(@searchdirs,$trn); |
| 709 |
} |
| 710 |
push(@searchdirs,'perl_root:[lib.pod]') # installed pods |
| 711 |
} |
| 712 |
else { |
| 713 |
push(@searchdirs, grep(-d, split($Config{path_sep}, |
| 714 |
$ENV{'PATH'}))); |
| 715 |
} |
| 716 |
} |
| 717 |
my @files = $self->searchfor(0,$_,@searchdirs); |
| 718 |
if (@files) { |
| 719 |
$self->aside( "Found as @files\n" ); |
| 720 |
} |
| 721 |
else { |
| 722 |
# no match, try recursive search |
| 723 |
@searchdirs = grep(!/^\.\z/s,@INC); |
| 724 |
@files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r; |
| 725 |
if (@files) { |
| 726 |
$self->aside( "Loosely found as @files\n" ); |
| 727 |
} |
| 728 |
else { |
| 729 |
print STDERR "No " . |
| 730 |
($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; |
| 731 |
if ( @{ $self->{'found'} } ) { |
| 732 |
print STDERR "However, try\n"; |
| 733 |
for my $dir (@{ $self->{'found'} }) { |
| 734 |
opendir(DIR, $dir) or die "opendir $dir: $!"; |
| 735 |
while (my $file = readdir(DIR)) { |
| 736 |
next if ($file =~ /^\./s); |
| 737 |
$file =~ s/\.(pm|pod)\z//; # XXX: badfs |
| 738 |
print STDERR "\tperldoc $_\::$file\n"; |
| 739 |
} |
| 740 |
closedir(DIR) or die "closedir $dir: $!"; |
| 741 |
} |
| 742 |
} |
| 743 |
} |
| 744 |
} |
| 745 |
push(@found,@files); |
| 746 |
} |
| 747 |
return @found; |
| 748 |
} |
| 749 |
|
| 750 |
#.......................................................................... |
| 751 |
|
| 752 |
sub maybe_generate_dynamic_pod { |
| 753 |
my($self, $found_things) = @_; |
| 754 |
my @dynamic_pod; |
| 755 |
|
| 756 |
$self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; |
| 757 |
|
| 758 |
$self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; |
| 759 |
|
| 760 |
if( ! $self->opt_f and ! $self->opt_q ) { |
| 761 |
DEBUG > 4 and print "That's a non-dynamic pod search.\n"; |
| 762 |
} elsif ( @dynamic_pod ) { |
| 763 |
$self->aside("Hm, I found some Pod from that search!\n"); |
| 764 |
my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); |
| 765 |
|
| 766 |
push @{ $self->{'temp_file_list'} }, $buffer; |
| 767 |
# I.e., it MIGHT be deleted at the end. |
| 768 |
|
| 769 |
my $in_list = $self->opt_f; |
| 770 |
|
| 771 |
print $buffd "=over 8\n\n" if $in_list; |
| 772 |
print $buffd @dynamic_pod or die "Can't print $buffer: $!"; |
| 773 |
print $buffd "=back\n" if $in_list; |
| 774 |
|
| 775 |
close $buffd or die "Can't close $buffer: $!"; |
| 776 |
|
| 777 |
@$found_things = $buffer; |
| 778 |
# Yes, so found_things never has more than one thing in |
| 779 |
# it, by time we leave here |
| 780 |
|
| 781 |
$self->add_formatter_option('__filter_nroff' => 1); |
| 782 |
|
| 783 |
} else { |
| 784 |
@$found_things = (); |
| 785 |
$self->aside("I found no Pod from that search!\n"); |
| 786 |
} |
| 787 |
|
| 788 |
return; |
| 789 |
} |
| 790 |
|
| 791 |
#.......................................................................... |
| 792 |
|
| 793 |
sub add_formatter_option { # $self->add_formatter_option('key' => 'value'); |
| 794 |
my $self = shift; |
| 795 |
push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; |
| 796 |
|
| 797 |
DEBUG > 3 and printf "Formatter switches now: [%s]\n", |
| 798 |
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; |
| 799 |
|
| 800 |
return; |
| 801 |
} |
| 802 |
|
| 803 |
#.......................................................................... |
| 804 |
|
| 805 |
sub search_perlfunc { |
| 806 |
my($self, $found_things, $pod) = @_; |
| 807 |
|
| 808 |
DEBUG > 2 and print "Search: @$found_things\n"; |
| 809 |
|
| 810 |
my $perlfunc = shift @$found_things; |
| 811 |
open(PFUNC, "<", $perlfunc) # "Funk is its own reward" |
| 812 |
or die("Can't open $perlfunc: $!"); |
| 813 |
|
| 814 |
# Functions like -r, -e, etc. are listed under `-X'. |
| 815 |
my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) |
| 816 |
? '(?:I<)?-X' : quotemeta($self->opt_f) ; |
| 817 |
|
| 818 |
DEBUG > 2 and |
| 819 |
print "Going to perlfunc-scan for $search_re in $perlfunc\n"; |
| 820 |
|
| 821 |
# Skip introduction |
| 822 |
local $_; |
| 823 |
while (<PFUNC>) { |
| 824 |
last if /^=head2 Alphabetical Listing of Perl Functions/; |
| 825 |
} |
| 826 |
|
| 827 |
# Look for our function |
| 828 |
my $found = 0; |
| 829 |
my $inlist = 0; |
| 830 |
while (<PFUNC>) { # "The Mothership Connection is here!" |
| 831 |
if ( m/^=item\s+$search_re\b/ ) { |
| 832 |
$found = 1; |
| 833 |
} |
| 834 |
elsif (/^=item/) { |
| 835 |
last if $found > 1 and not $inlist; |
| 836 |
} |
| 837 |
next unless $found; |
| 838 |
if (/^=over/) { |
| 839 |
++$inlist; |
| 840 |
} |
| 841 |
elsif (/^=back/) { |
| 842 |
--$inlist; |
| 843 |
} |
| 844 |
push @$pod, $_; |
| 845 |
++$found if /^\w/; # found descriptive text |
| 846 |
} |
| 847 |
if (!@$pod) { |
| 848 |
die sprintf |
| 849 |
"No documentation for perl function `%s' found\n", |
| 850 |
$self->opt_f |
| 851 |
; |
| 852 |
} |
| 853 |
close PFUNC or die "Can't open $perlfunc: $!"; |
| 854 |
|
| 855 |
return; |
| 856 |
} |
| 857 |
|
| 858 |
#.......................................................................... |
| 859 |
|
| 860 |
sub search_perlfaqs { |
| 861 |
my( $self, $found_things, $pod) = @_; |
| 862 |
|
| 863 |
my $found = 0; |
| 864 |
my %found_in; |
| 865 |
my $search_key = $self->opt_q; |
| 866 |
|
| 867 |
my $rx = eval { qr/$search_key/ } |
| 868 |
or die <<EOD; |
| 869 |
Invalid regular expression '$search_key' given as -q pattern: |
| 870 |
$@ |
| 871 |
Did you mean \\Q$search_key ? |
| 872 |
|
| 873 |
EOD |
| 874 |
|
| 875 |
local $_; |
| 876 |
foreach my $file (@$found_things) { |
| 877 |
die "invalid file spec: $!" if $file =~ /[<>|]/; |
| 878 |
open(INFAQ, "<", $file) # XXX 5.6ism |
| 879 |
or die "Can't read-open $file: $!\nAborting"; |
| 880 |
while (<INFAQ>) { |
| 881 |
if ( m/^=head2\s+.*(?:$search_key)/i ) { |
| 882 |
$found = 1; |
| 883 |
push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++; |
| 884 |
} |
| 885 |
elsif (/^=head[12]/) { |
| 886 |
$found = 0; |
| 887 |
} |
| 888 |
next unless $found; |
| 889 |
push @$pod, $_; |
| 890 |
} |
| 891 |
close(INFAQ); |
| 892 |
} |
| 893 |
die("No documentation for perl FAQ keyword `$search_key' found\n") |
| 894 |
unless @$pod; |
| 895 |
|
| 896 |
return; |
| 897 |
} |
| 898 |
|
| 899 |
|
| 900 |
#.......................................................................... |
| 901 |
|
| 902 |
sub render_findings { |
| 903 |
# Return the filename to open |
| 904 |
|
| 905 |
my($self, $found_things) = @_; |
| 906 |
|
| 907 |
my $formatter_class = $self->{'formatter_class'} |
| 908 |
|| die "No formatter class set!?"; |
| 909 |
my $formatter = $formatter_class->can('new') |
| 910 |
? $formatter_class->new |
| 911 |
: $formatter_class |
| 912 |
; |
| 913 |
|
| 914 |
if(! @$found_things) { |
| 915 |
die "Nothing found?!"; |
| 916 |
# should have been caught before here |
| 917 |
} elsif(@$found_things > 1) { |
| 918 |
warn join '', |
| 919 |
"Perldoc is only really meant for reading one document at a time.\n", |
| 920 |
"So these parameters are being ignored: ", |
| 921 |
join(' ', @$found_things[1 .. $#$found_things] ), |
| 922 |
"\n" |
| 923 |
} |
| 924 |
|
| 925 |
my $file = $found_things->[0]; |
| 926 |
|
| 927 |
DEBUG > 3 and printf "Formatter switches now: [%s]\n", |
| 928 |
join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; |
| 929 |
|
| 930 |
# Set formatter options: |
| 931 |
if( ref $formatter ) { |
| 932 |
foreach my $f (@{ $self->{'formatter_switches'} || [] }) { |
| 933 |
my($switch, $value, $silent_fail) = @$f; |
| 934 |
if( $formatter->can($switch) ) { |
| 935 |
eval { $formatter->$switch( defined($value) ? $value : () ) }; |
| 936 |
warn "Got an error when setting $formatter_class\->$switch:\n$@\n" |
| 937 |
if $@; |
| 938 |
} else { |
| 939 |
if( $silent_fail or $switch =~ m/^__/s ) { |
| 940 |
DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; |
| 941 |
} else { |
| 942 |
warn "$formatter_class doesn't recognize the $switch switch.\n"; |
| 943 |
} |
| 944 |
} |
| 945 |
} |
| 946 |
} |
| 947 |
|
| 948 |
$self->{'output_is_binary'} = |
| 949 |
$formatter->can('write_with_binmode') && $formatter->write_with_binmode; |
| 950 |
|
| 951 |
my ($out_fh, $out) = $self->new_output_file( |
| 952 |
( $formatter->can('output_extension') && $formatter->output_extension ) |
| 953 |
|| undef, |
| 954 |
$self->useful_filename_bit, |
| 955 |
); |
| 956 |
|
| 957 |
# Now, finally, do the formatting! |
| 958 |
{ |
| 959 |
local $^W = $^W; |
| 960 |
if(DEBUG() or $self->opt_v) { |
| 961 |
# feh, let 'em see it |
| 962 |
} else { |
| 963 |
$^W = 0; |
| 964 |
# The average user just has no reason to be seeing |
| 965 |
# $^W-suppressable warnings from the formatting! |
| 966 |
} |
| 967 |
|
| 968 |
eval { $formatter->parse_from_file( $file, $out_fh ) }; |
| 969 |
} |
| 970 |
|
| 971 |
warn "Error while formatting with $formatter_class:\n $@\n" if $@; |
| 972 |
DEBUG > 2 and print "Back from formatting with $formatter_class\n"; |
| 973 |
|
| 974 |
close $out_fh |
| 975 |
or warn "Can't close $out: $!\n(Did $formatter already close it?)"; |
| 976 |
sleep 0; sleep 0; sleep 0; |
| 977 |
# Give the system a few timeslices to meditate on the fact |
| 978 |
# that the output file does in fact exist and is closed. |
| 979 |
|
| 980 |
$self->unlink_if_temp_file($file); |
| 981 |
|
| 982 |
unless( -s $out ) { |
| 983 |
if( $formatter->can( 'if_zero_length' ) ) { |
| 984 |
# Basically this is just a hook for Pod::Simple::Checker; since |
| 985 |
# what other class could /happily/ format an input file with Pod |
| 986 |
# as a 0-length output file? |
| 987 |
$formatter->if_zero_length( $file, $out, $out_fh ); |
| 988 |
} else { |
| 989 |
warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" |
| 990 |
} |
| 991 |
} |
| 992 |
|
| 993 |
DEBUG and print "Finished writing to $out.\n"; |
| 994 |
return($out, $formatter) if wantarray; |
| 995 |
return $out; |
| 996 |
} |
| 997 |
|
| 998 |
#.......................................................................... |
| 999 |
|
| 1000 |
sub unlink_if_temp_file { |
| 1001 |
# Unlink the specified file IFF it's in the list of temp files. |
| 1002 |
# Really only used in the case of -f / -q things when we can |
| 1003 |
# throw away the dynamically generated source pod file once |
| 1004 |
# we've formatted it. |
| 1005 |
# |
| 1006 |
my($self, $file) = @_; |
| 1007 |
return unless defined $file and length $file; |
| 1008 |
|
| 1009 |
my $temp_file_list = $self->{'temp_file_list'} || return; |
| 1010 |
if(grep $_ eq $file, @$temp_file_list) { |
| 1011 |
$self->aside("Unlinking $file\n"); |
| 1012 |
unlink($file) or warn "Odd, couldn't unlink $file: $!"; |
| 1013 |
} else { |
| 1014 |
DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; |
| 1015 |
} |
| 1016 |
return; |
| 1017 |
} |
| 1018 |
|
| 1019 |
#.......................................................................... |
| 1020 |
|
| 1021 |
sub MSWin_temp_cleanup { |
| 1022 |
|
| 1023 |
# Nothing particularly MSWin-specific in here, but I don't know if any |
| 1024 |
# other OS needs its temp dir policed like MSWin does! |
| 1025 |
|
| 1026 |
my $self = shift; |
| 1027 |
|
| 1028 |
my $tempdir = $ENV{'TEMP'}; |
| 1029 |
return unless defined $tempdir and length $tempdir |
| 1030 |
and -e $tempdir and -d _ and -w _; |
| 1031 |
|
| 1032 |
$self->aside( |
| 1033 |
"Considering whether any old files of mine in $tempdir need unlinking.\n" |
| 1034 |
); |
| 1035 |
|
| 1036 |
opendir(TMPDIR, $tempdir) || return; |
| 1037 |
my @to_unlink; |
| 1038 |
|
| 1039 |
my $limit = time() - $Temp_File_Lifetime; |
| 1040 |
|
| 1041 |
DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n", |
| 1042 |
($limit) x 2; |
| 1043 |
|
| 1044 |
my $filespec; |
| 1045 |
|
| 1046 |
while(defined($filespec = readdir(TMPDIR))) { |
| 1047 |
if( |
| 1048 |
$filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s |
| 1049 |
) { |
| 1050 |
if( hex($1) < $limit ) { |
| 1051 |
push @to_unlink, "$tempdir/$filespec"; |
| 1052 |
$self->aside( "Will unlink my old temp file $to_unlink[-1]\n" ); |
| 1053 |
} else { |
| 1054 |
DEBUG > 5 and |
| 1055 |
printf " $tempdir/$filespec is too recent (after %x)\n", $limit; |
| 1056 |
} |
| 1057 |
} else { |
| 1058 |
DEBUG > 5 and |
| 1059 |
print " $tempdir/$filespec doesn't look like a perldoc temp file.\n"; |
| 1060 |
} |
| 1061 |
} |
| 1062 |
closedir(TMPDIR); |
| 1063 |
$self->aside(sprintf "Unlinked %s items of mine in %s\n", |
| 1064 |
scalar(unlink(@to_unlink)), |
| 1065 |
$tempdir |
| 1066 |
); |
| 1067 |
return; |
| 1068 |
} |
| 1069 |
|
| 1070 |
# . . . . . . . . . . . . . . . . . . . . . . . . . |
| 1071 |
|
| 1072 |
sub MSWin_perldoc_tempfile { |
| 1073 |
my($self, $suffix, $infix) = @_; |
| 1074 |
|
| 1075 |
my $tempdir = $ENV{'TEMP'}; |
| 1076 |
return unless defined $tempdir and length $tempdir |
| 1077 |
and -e $tempdir and -d _ and -w _; |
| 1078 |
|
| 1079 |
my $spec; |
| 1080 |
|
| 1081 |
do { |
| 1082 |
$spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup |
| 1083 |
# Yes, we embed the create-time in the filename! |
| 1084 |
$tempdir, |
| 1085 |
$infix || 'x', |
| 1086 |
time(), |
| 1087 |
$$, |
| 1088 |
defined( &Win32::GetTickCount ) |
| 1089 |
? (Win32::GetTickCount() & 0xff) |
| 1090 |
: int(rand 256) |
| 1091 |
# Under MSWin, $$ values get reused quickly! So if we ran |
| 1092 |
# perldoc foo and then perldoc bar before there was time for |
| 1093 |
# time() to increment time."_$$" would likely be the same |
| 1094 |
# for each process! So we tack on the tick count's lower |
| 1095 |
# bits (or, in a pinch, rand) |
| 1096 |
, |
| 1097 |
$suffix || 'txt'; |
| 1098 |
; |
| 1099 |
} while( -e $spec ); |
| 1100 |
|
| 1101 |
my $counter = 0; |
| 1102 |
|
| 1103 |
while($counter < 50) { |
| 1104 |
my $fh; |
| 1105 |
# If we are running before perl5.6.0, we can't autovivify |
| 1106 |
if ($] < 5.006) { |
| 1107 |
require Symbol; |
| 1108 |
$fh = Symbol::gensym(); |
| 1109 |
} |
| 1110 |
DEBUG > 3 and print "About to try making temp file $spec\n"; |
| 1111 |
return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism |
| 1112 |
$self->aside("Can't create temp file $spec: $!\n"); |
| 1113 |
} |
| 1114 |
|
| 1115 |
$self->aside("Giving up on making a temp file!\n"); |
| 1116 |
die "Can't make a tempfile!?"; |
| 1117 |
} |
| 1118 |
|
| 1119 |
#.......................................................................... |
| 1120 |
|
| 1121 |
|
| 1122 |
sub after_rendering { |
| 1123 |
my $self = $_[0]; |
| 1124 |
$self->after_rendering_VMS if IS_VMS; |
| 1125 |
$self->after_rendering_MSWin32 if IS_MSWin32; |
| 1126 |
$self->after_rendering_Dos if IS_Dos; |
| 1127 |
$self->after_rendering_OS2 if IS_OS2; |
| 1128 |
return; |
| 1129 |
} |
| 1130 |
|
| 1131 |
sub after_rendering_VMS { return } |
| 1132 |
sub after_rendering_Dos { return } |
| 1133 |
sub after_rendering_OS2 { return } |
| 1134 |
|
| 1135 |
sub after_rendering_MSWin32 { |
| 1136 |
shift->MSWin_temp_cleanup() if $Temp_Files_Created; |
| 1137 |
} |
| 1138 |
|
| 1139 |
#.......................................................................... |
| 1140 |
# : : : : : : : : : |
| 1141 |
#.......................................................................... |
| 1142 |
|
| 1143 |
|
| 1144 |
sub minus_f_nocase { # i.e., do like -f, but without regard to case |
| 1145 |
|
| 1146 |
my($self, $dir, $file) = @_; |
| 1147 |
my $path = catfile($dir,$file); |
| 1148 |
return $path if -f $path and -r _; |
| 1149 |
|
| 1150 |
if(!$self->opt_i |
| 1151 |
or IS_VMS or IS_MSWin32 |
| 1152 |
or IS_Dos or IS_OS2 |
| 1153 |
) { |
| 1154 |
# On a case-forgiving file system, or if case is important, |
| 1155 |
# that is it, all we can do. |
| 1156 |
warn "Ignored $path: unreadable\n" if -f _; |
| 1157 |
return ''; |
| 1158 |
} |
| 1159 |
|
| 1160 |
local *DIR; |
| 1161 |
my @p = ($dir); |
| 1162 |
my($p,$cip); |
| 1163 |
foreach $p (splitdir $file){ |
| 1164 |
my $try = catfile @p, $p; |
| 1165 |
$self->aside("Scrutinizing $try...\n"); |
| 1166 |
stat $try; |
| 1167 |
if (-d _) { |
| 1168 |
push @p, $p; |
| 1169 |
if ( $p eq $self->{'target'} ) { |
| 1170 |
my $tmp_path = catfile @p; |
| 1171 |
my $path_f = 0; |
| 1172 |
for (@{ $self->{'found'} }) { |
| 1173 |
$path_f = 1 if $_ eq $tmp_path; |
| 1174 |
} |
| 1175 |
push (@{ $self->{'found'} }, $tmp_path) unless $path_f; |
| 1176 |
$self->aside( "Found as $tmp_path but directory\n" ); |
| 1177 |
} |
| 1178 |
} |
| 1179 |
elsif (-f _ && -r _) { |
| 1180 |
return $try; |
| 1181 |
} |
| 1182 |
elsif (-f _) { |
| 1183 |
warn "Ignored $try: unreadable\n"; |
| 1184 |
} |
| 1185 |
elsif (-d catdir(@p)) { # at least we see the containing directory! |
| 1186 |
my $found = 0; |
| 1187 |
my $lcp = lc $p; |
| 1188 |
my $p_dirspec = catdir(@p); |
| 1189 |
opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!"; |
| 1190 |
while(defined( $cip = readdir(DIR) )) { |
| 1191 |
if (lc $cip eq $lcp){ |
| 1192 |
$found++; |
| 1193 |
last; # XXX stop at the first? what if there's others? |
| 1194 |
} |
| 1195 |
} |
| 1196 |
closedir DIR or die "closedir $p_dirspec: $!"; |
| 1197 |
return "" unless $found; |
| 1198 |
|
| 1199 |
push @p, $cip; |
| 1200 |
my $p_filespec = catfile(@p); |
| 1201 |
return $p_filespec if -f $p_filespec and -r _; |
| 1202 |
warn "Ignored $p_filespec: unreadable\n" if -f _; |
| 1203 |
} |
| 1204 |
} |
| 1205 |
return ""; |
| 1206 |
} |
| 1207 |
|
| 1208 |
#.......................................................................... |
| 1209 |
|
| 1210 |
sub pagers_guessing { |
| 1211 |
my $self = shift; |
| 1212 |
|
| 1213 |
my @pagers; |
| 1214 |
push @pagers, $self->pagers; |
| 1215 |
$self->{'pagers'} = \@pagers; |
| 1216 |
|
| 1217 |
if (IS_MSWin32) { |
| 1218 |
push @pagers, qw( more< less notepad ); |
| 1219 |
unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; |
| 1220 |
} |
| 1221 |
elsif (IS_VMS) { |
| 1222 |
push @pagers, qw( most more less type/page ); |
| 1223 |
} |
| 1224 |
elsif (IS_Dos) { |
| 1225 |
push @pagers, qw( less.exe more.com< ); |
| 1226 |
unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; |
| 1227 |
} |
| 1228 |
else { |
| 1229 |
if (IS_OS2) { |
| 1230 |
unshift @pagers, 'less', 'cmd /c more <'; |
| 1231 |
} |
| 1232 |
push @pagers, qw( more less pg view cat ); |
| 1233 |
unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; |
| 1234 |
} |
| 1235 |
|
| 1236 |
if (IS_Cygwin) { |
| 1237 |
if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) { |
| 1238 |
unshift @pagers, '/usr/bin/less -isrR'; |
| 1239 |
} |
| 1240 |
} |
| 1241 |
|
| 1242 |
unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; |
| 1243 |
|
| 1244 |
return; |
| 1245 |
} |
| 1246 |
|
| 1247 |
#.......................................................................... |
| 1248 |
|
| 1249 |
sub page_module_file { |
| 1250 |
my($self, @found) = @_; |
| 1251 |
|
| 1252 |
# Security note: |
| 1253 |
# Don't ever just pass this off to anything like MSWin's "start.exe", |
| 1254 |
# since we might be calling on a .pl file, and we wouldn't want that |
| 1255 |
# to actually /execute/ the file that we just want to page thru! |
| 1256 |
# Also a consideration if one were to use a web browser as a pager; |
| 1257 |
# doing so could trigger the browser's MIME mapping for whatever |
| 1258 |
# it thinks .pm/.pl/whatever is. Probably just a (useless and |
| 1259 |
# annoying) "Save as..." dialog, but potentially executing the file |
| 1260 |
# in question -- particularly in the case of MSIE and it's, ahem, |
| 1261 |
# occasionally hazy distinction between OS-local extension |
| 1262 |
# associations, and browser-specific MIME mappings. |
| 1263 |
|
| 1264 |
if ($self->{'output_to_stdout'}) { |
| 1265 |
$self->aside("Sending unpaged output to STDOUT.\n"); |
| 1266 |
local $_; |
| 1267 |
my $any_error = 0; |
| 1268 |
foreach my $output (@found) { |
| 1269 |
unless( open(TMP, "<", $output) ) { # XXX 5.6ism |
| 1270 |
warn("Can't open $output: $!"); |
| 1271 |
$any_error = 1; |
| 1272 |
next; |
| 1273 |
} |
| 1274 |
while (<TMP>) { |
| 1275 |
print or die "Can't print to stdout: $!"; |
| 1276 |
} |
| 1277 |
close TMP or die "Can't close while $output: $!"; |
| 1278 |
$self->unlink_if_temp_file($output); |
| 1279 |
} |
| 1280 |
return $any_error; # successful |
| 1281 |
} |
| 1282 |
|
| 1283 |
foreach my $pager ( $self->pagers ) { |
| 1284 |
$self->aside("About to try calling $pager @found\n"); |
| 1285 |
if (system($pager, @found) == 0) { |
| 1286 |
$self->aside("Yay, it worked.\n"); |
| 1287 |
return 0; |
| 1288 |
} |
| 1289 |
$self->aside("That didn't work.\n"); |
| 1290 |
|
| 1291 |
# Odd -- when it fails, under Win32, this seems to neither |
| 1292 |
# return with a fail nor return with a success!! |
| 1293 |
# That's discouraging! |
| 1294 |
} |
| 1295 |
|
| 1296 |
$self->aside( |
| 1297 |
sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n", |
| 1298 |
join(' ', @found), |
| 1299 |
join(' ', $self->pagers), |
| 1300 |
); |
| 1301 |
|
| 1302 |
if (IS_VMS) { |
| 1303 |
DEBUG > 1 and print "Bailing out in a VMSish way.\n"; |
| 1304 |
eval q{ |
| 1305 |
use vmsish qw(status exit); |
| 1306 |
exit $?; |
| 1307 |
1; |
| 1308 |
} or die; |
| 1309 |
} |
| 1310 |
|
| 1311 |
return 1; |
| 1312 |
# i.e., an UNSUCCESSFUL return value! |
| 1313 |
} |
| 1314 |
|
| 1315 |
#.......................................................................... |
| 1316 |
|
| 1317 |
sub check_file { |
| 1318 |
my($self, $dir, $file) = @_; |
| 1319 |
|
| 1320 |
unless( ref $self ) { |
| 1321 |
# Should never get called: |
| 1322 |
$Carp::Verbose = 1; |
| 1323 |
require Carp; |
| 1324 |
Carp::croak( join '', |
| 1325 |
"Crazy ", __PACKAGE__, " error:\n", |
| 1326 |
"check_file must be an object_method!\n", |
| 1327 |
"Aborting" |
| 1328 |
); |
| 1329 |
} |
| 1330 |
|
| 1331 |
if(length $dir and not -d $dir) { |
| 1332 |
DEBUG > 3 and print " No dir $dir -- skipping.\n"; |
| 1333 |
return ""; |
| 1334 |
} |
| 1335 |
|
| 1336 |
if ($self->opt_m) { |
| 1337 |
return $self->minus_f_nocase($dir,$file); |
| 1338 |
} |
| 1339 |
|
| 1340 |
else { |
| 1341 |
my $path = $self->minus_f_nocase($dir,$file); |
| 1342 |
if( length $path and $self->containspod($path) ) { |
| 1343 |
DEBUG > 3 and print |
| 1344 |
" The file $path indeed looks promising!\n"; |
| 1345 |
return $path; |
| 1346 |
} |
| 1347 |
} |
| 1348 |
DEBUG > 3 and print " No good: $file in $dir\n"; |
| 1349 |
|
| 1350 |
return ""; |
| 1351 |
} |
| 1352 |
|
| 1353 |
#.......................................................................... |
| 1354 |
|
| 1355 |
sub containspod { |
| 1356 |
my($self, $file, $readit) = @_; |
| 1357 |
return 1 if !$readit && $file =~ /\.pod\z/i; |
| 1358 |
|
| 1359 |
|
| 1360 |
# Under cygwin the /usr/bin/perl is legal executable, but |
| 1361 |
# you cannot open a file with that name. It must be spelled |
| 1362 |
# out as "/usr/bin/perl.exe". |
| 1363 |
# |
| 1364 |
# The following if-case under cygwin prevents error |
| 1365 |
# |
| 1366 |
# $ perldoc perl |
| 1367 |
# Cannot open /usr/bin/perl: no such file or directory |
| 1368 |
# |
| 1369 |
# This would work though |
| 1370 |
# |
| 1371 |
# $ perldoc perl.pod |
| 1372 |
|
| 1373 |
if ( IS_Cygwin and -x $file and -f "$file.exe" ) |
| 1374 |
{ |
| 1375 |
warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_v; |
| 1376 |
return 0; |
| 1377 |
} |
| 1378 |
|
| 1379 |
local($_); |
| 1380 |
open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism |
| 1381 |
while (<TEST>) { |
| 1382 |
if (/^=head/) { |
| 1383 |
close(TEST) or die "Can't close $file: $!"; |
| 1384 |
return 1; |
| 1385 |
} |
| 1386 |
} |
| 1387 |
close(TEST) or die "Can't close $file: $!"; |
| 1388 |
return 0; |
| 1389 |
} |
| 1390 |
|
| 1391 |
#.......................................................................... |
| 1392 |
|
| 1393 |
sub maybe_diddle_INC { |
| 1394 |
my $self = shift; |
| 1395 |
|
| 1396 |
# Does this look like a module or extension directory? |
| 1397 |
|
| 1398 |
if (-f "Makefile.PL") { |
| 1399 |
|
| 1400 |
# Add "." and "lib" to @INC (if they exist) |
| 1401 |
eval q{ use lib qw(. lib); 1; } or die; |
| 1402 |
|
| 1403 |
# don't add if superuser |
| 1404 |
if ($< && $> && -f "blib") { # don't be looking too hard now! |
| 1405 |
eval q{ use blib; 1 }; |
| 1406 |
warn $@ if $@ && $self->opt_v; |
| 1407 |
} |
| 1408 |
} |
| 1409 |
|
| 1410 |
return; |
| 1411 |
} |
| 1412 |
|
| 1413 |
#.......................................................................... |
| 1414 |
|
| 1415 |
sub new_output_file { |
| 1416 |
my $self = shift; |
| 1417 |
my $outspec = $self->opt_d; # Yes, -d overrides all else! |
| 1418 |
# So don't call this twice per format-job! |
| 1419 |
|
| 1420 |
return $self->new_tempfile(@_) unless defined $outspec and length $outspec; |
| 1421 |
|
| 1422 |
# Otherwise open a write-handle on opt_d!f |
| 1423 |
|
| 1424 |
my $fh; |
| 1425 |
# If we are running before perl5.6.0, we can't autovivify |
| 1426 |
if ($] < 5.006) { |
| 1427 |
require Symbol; |
| 1428 |
$fh = Symbol::gensym(); |
| 1429 |
} |
| 1430 |
DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; |
| 1431 |
die "Can't write-open $outspec: $!" |
| 1432 |
unless open($fh, ">", $outspec); # XXX 5.6ism |
| 1433 |
|
| 1434 |
DEBUG > 3 and print "Successfully opened $outspec\n"; |
| 1435 |
binmode($fh) if $self->{'output_is_binary'}; |
| 1436 |
return($fh, $outspec); |
| 1437 |
} |
| 1438 |
|
| 1439 |
#.......................................................................... |
| 1440 |
|
| 1441 |
sub useful_filename_bit { |
| 1442 |
# This tries to provide a meaningful bit of text to do with the query, |
| 1443 |
# such as can be used in naming the file -- since if we're going to be |
| 1444 |
# opening windows on temp files (as a "pager" may well do!) then it's |
| 1445 |
# better if the temp file's name (which may well be used as the window |
| 1446 |
# title) isn't ALL just random garbage! |
| 1447 |
# In other words "perldoc_LWPSimple_2371981429" is a better temp file |
| 1448 |
# name than "perldoc_2371981429". So this routine is what tries to |
| 1449 |
# provide the "LWPSimple" bit. |
| 1450 |
# |
| 1451 |
my $self = shift; |
| 1452 |
my $pages = $self->{'pages'} || return undef; |
| 1453 |
return undef unless @$pages; |
| 1454 |
|
| 1455 |
my $chunk = $pages->[0]; |
| 1456 |
return undef unless defined $chunk; |
| 1457 |
$chunk =~ s/:://g; |
| 1458 |
$chunk =~ s/\.\w+$//g; # strip any extension |
| 1459 |
if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file |
| 1460 |
$chunk = $1; |
| 1461 |
} else { |
| 1462 |
return undef; |
| 1463 |
} |
| 1464 |
$chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things! |
| 1465 |
$chunk = substr($chunk, -10) if length($chunk) > 10; |
| 1466 |
return $chunk; |
| 1467 |
} |
| 1468 |
|
| 1469 |
#.......................................................................... |
| 1470 |
|
| 1471 |
sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) |
| 1472 |
my $self = shift; |
| 1473 |
|
| 1474 |
++$Temp_Files_Created; |
| 1475 |
|
| 1476 |
if( IS_MSWin32 ) { |
| 1477 |
my @out = $self->MSWin_perldoc_tempfile(@_); |
| 1478 |
return @out if @out; |
| 1479 |
# otherwise fall thru to the normal stuff below... |
| 1480 |
} |
| 1481 |
|
| 1482 |
require File::Temp; |
| 1483 |
return File::Temp::tempfile(UNLINK => 1); |
| 1484 |
} |
| 1485 |
|
| 1486 |
#.......................................................................... |
| 1487 |
|
| 1488 |
sub page { # apply a pager to the output file |
| 1489 |
my ($self, $output, $output_to_stdout, @pagers) = @_; |
| 1490 |
if ($output_to_stdout) { |
| 1491 |
$self->aside("Sending unpaged output to STDOUT.\n"); |
| 1492 |
open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism |
| 1493 |
local $_; |
| 1494 |
while (<TMP>) { |
| 1495 |
print or die "Can't print to stdout: $!"; |
| 1496 |
} |
| 1497 |
close TMP or die "Can't close while $output: $!"; |
| 1498 |
$self->unlink_if_temp_file($output); |
| 1499 |
} else { |
| 1500 |
# On VMS, quoting prevents logical expansion, and temp files with no |
| 1501 |
# extension get the wrong default extension (such as .LIS for TYPE) |
| 1502 |
|
| 1503 |
$output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS; |
| 1504 |
|
| 1505 |
$output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos; |
| 1506 |
# Altho "/" under MSWin is in theory good as a pathsep, |
| 1507 |
# many many corners of the OS don't like it. So we |
| 1508 |
# have to force it to be "\" to make everyone happy. |
| 1509 |
|
| 1510 |
foreach my $pager (@pagers) { |
| 1511 |
$self->aside("About to try calling $pager $output\n"); |
| 1512 |
if (IS_VMS) { |
| 1513 |
last if system("$pager $output") == 0; |
| 1514 |
} else { |
| 1515 |
last if system("$pager \"$output\"") == 0; |
| 1516 |
} |
| 1517 |
} |
| 1518 |
} |
| 1519 |
return; |
| 1520 |
} |
| 1521 |
|
| 1522 |
#.......................................................................... |
| 1523 |
|
| 1524 |
sub searchfor { |
| 1525 |
my($self, $recurse,$s,@dirs) = @_; |
| 1526 |
$s =~ s!::!/!g; |
| 1527 |
$s = VMS::Filespec::unixify($s) if IS_VMS; |
| 1528 |
return $s if -f $s && $self->containspod($s); |
| 1529 |
$self->aside( "Looking for $s in @dirs\n" ); |
| 1530 |
my $ret; |
| 1531 |
my $i; |
| 1532 |
my $dir; |
| 1533 |
$self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename? |
| 1534 |
for ($i=0; $i<@dirs; $i++) { |
| 1535 |
$dir = $dirs[$i]; |
| 1536 |
($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS; |
| 1537 |
if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) |
| 1538 |
or ( $ret = $self->check_file($dir,"$s.pm")) |
| 1539 |
or ( $ret = $self->check_file($dir,$s)) |
| 1540 |
or ( IS_VMS and |
| 1541 |
$ret = $self->check_file($dir,"$s.com")) |
| 1542 |
or ( IS_OS2 and |
| 1543 |
$ret = $self->check_file($dir,"$s.cmd")) |
| 1544 |
or ( (IS_MSWin32 or IS_Dos or IS_OS2) and |
| 1545 |
$ret = $self->check_file($dir,"$s.bat")) |
| 1546 |
or ( $ret = $self->check_file("$dir/pod","$s.pod")) |
| 1547 |
or ( $ret = $self->check_file("$dir/pod",$s)) |
| 1548 |
or ( $ret = $self->check_file("$dir/pods","$s.pod")) |
| 1549 |
or ( $ret = $self->check_file("$dir/pods",$s)) |
| 1550 |
) { |
| 1551 |
DEBUG > 1 and print " Found $ret\n"; |
| 1552 |
return $ret; |
| 1553 |
} |
| 1554 |
|
| 1555 |
if ($recurse) { |
| 1556 |
opendir(D,$dir) or die "Can't opendir $dir: $!"; |
| 1557 |
my @newdirs = map catfile($dir, $_), grep { |
| 1558 |
not /^\.\.?\z/s and |
| 1559 |
not /^auto\z/s and # save time! don't search auto dirs |
| 1560 |
-d catfile($dir, $_) |
| 1561 |
} readdir D; |
| 1562 |
closedir(D) or die "Can't closedir $dir: $!"; |
| 1563 |
next unless @newdirs; |
| 1564 |
# what a wicked map! |
| 1565 |
@newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS; |
| 1566 |
$self->aside( "Also looking in @newdirs\n" ); |
| 1567 |
push(@dirs,@newdirs); |
| 1568 |
} |
| 1569 |
} |
| 1570 |
return (); |
| 1571 |
} |
| 1572 |
|
| 1573 |
#.......................................................................... |
| 1574 |
{ |
| 1575 |
my $already_asserted; |
| 1576 |
sub assert_closing_stdout { |
| 1577 |
my $self = shift; |
| 1578 |
|
| 1579 |
return if $already_asserted; |
| 1580 |
|
| 1581 |
eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~; |
| 1582 |
# What for? to let the pager know that nothing more will come? |
| 1583 |
|
| 1584 |
die $@ if $@; |
| 1585 |
$already_asserted = 1; |
| 1586 |
return; |
| 1587 |
} |
| 1588 |
} |
| 1589 |
|
| 1590 |
#.......................................................................... |
| 1591 |
|
| 1592 |
sub tweak_found_pathnames { |
| 1593 |
my($self, $found) = @_; |
| 1594 |
if (IS_MSWin32) { |
| 1595 |
foreach (@$found) { s,/,\\,g } |
| 1596 |
} |
| 1597 |
return; |
| 1598 |
} |
| 1599 |
|
| 1600 |
#.......................................................................... |
| 1601 |
# : : : : : : : : : |
| 1602 |
#.......................................................................... |
| 1603 |
|
| 1604 |
sub am_taint_checking { |
| 1605 |
my $self = shift; |
| 1606 |
die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way |
| 1607 |
my($k,$v) = each %ENV; |
| 1608 |
return is_tainted($v); |
| 1609 |
} |
| 1610 |
|
| 1611 |
#.......................................................................... |
| 1612 |
|
| 1613 |
sub is_tainted { # just a function |
| 1614 |
my $arg = shift; |
| 1615 |
my $nada = substr($arg, 0, 0); # zero-length! |
| 1616 |
local $@; # preserve the caller's version of $@ |
| 1617 |
eval { eval "# $nada" }; |
| 1618 |
return length($@) != 0; |
| 1619 |
} |
| 1620 |
|
| 1621 |
#.......................................................................... |
| 1622 |
|
| 1623 |
sub drop_privs_maybe { |
| 1624 |
my $self = shift; |
| 1625 |
|
| 1626 |
# Attempt to drop privs if we should be tainting and aren't |
| 1627 |
if (!(IS_VMS || IS_MSWin32 || IS_Dos |
| 1628 |
|| IS_OS2 |
| 1629 |
) |
| 1630 |
&& ($> == 0 || $< == 0) |
| 1631 |
&& !$self->am_taint_checking() |
| 1632 |
) { |
| 1633 |
my $id = eval { getpwnam("nobody") }; |
| 1634 |
$id = eval { getpwnam("nouser") } unless defined $id; |
| 1635 |
$id = -2 unless defined $id; |
| 1636 |
# |
| 1637 |
# According to Stevens' APUE and various |
| 1638 |
# (BSD, Solaris, HP-UX) man pages, setting |
| 1639 |
# the real uid first and effective uid second |
| 1640 |
# is the way to go if one wants to drop privileges, |
| 1641 |
# because if one changes into an effective uid of |
| 1642 |
# non-zero, one cannot change the real uid any more. |
| 1643 |
# |
| 1644 |
# Actually, it gets even messier. There is |
| 1645 |
# a third uid, called the saved uid, and as |
| 1646 |
# long as that is zero, one can get back to |
| 1647 |
# uid of zero. Setting the real-effective *twice* |
| 1648 |
# helps in *most* systems (FreeBSD and Solaris) |
| 1649 |
# but apparently in HP-UX even this doesn't help: |
| 1650 |
# the saved uid stays zero (apparently the only way |
| 1651 |
# in HP-UX to change saved uid is to call setuid() |
| 1652 |
# when the effective uid is zero). |
| 1653 |
# |
| 1654 |
eval { |
| 1655 |
$< = $id; # real uid |
| 1656 |
$> = $id; # effective uid |
| 1657 |
$< = $id; # real uid |
| 1658 |
$> = $id; # effective uid |
| 1659 |
}; |
| 1660 |
if( !$@ && $< && $> ) { |
| 1661 |
DEBUG and print "OK, I dropped privileges.\n"; |
| 1662 |
} elsif( $self->opt_U ) { |
| 1663 |
DEBUG and print "Couldn't drop privileges, but in -U mode, so feh." |
| 1664 |
} else { |
| 1665 |
DEBUG and print "Hm, couldn't drop privileges. Ah well.\n"; |
| 1666 |
# We used to die here; but that seemed pointless. |
| 1667 |
} |
| 1668 |
} |
| 1669 |
return; |
| 1670 |
} |
| 1671 |
|
| 1672 |
#.......................................................................... |
| 1673 |
|
| 1674 |
1; |
| 1675 |
|
| 1676 |
__END__ |
| 1677 |
|
| 1678 |
# See "perldoc perldoc" for basic details. |
| 1679 |
# |
| 1680 |
# Perldoc -- look up a piece of documentation in .pod format that |
| 1681 |
# is embedded in the perl installation tree. |
| 1682 |
# |
| 1683 |
#~~~~~~ |
| 1684 |
# |
| 1685 |
# See ChangeLog in CPAN dist for Pod::Perldoc for later notes. |
| 1686 |
# |
| 1687 |
# Version 3.01: Sun Nov 10 21:38:09 MST 2002 |
| 1688 |
# Sean M. Burke <sburke@cpan.org> |
| 1689 |
# Massive refactoring and code-tidying. |
| 1690 |
# Now it's a module(-family)! |
| 1691 |
# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm |
| 1692 |
# Added -T, -d, -o, -M, -w. |
| 1693 |
# Added some improved MSWin funk. |
| 1694 |
# |
| 1695 |
#~~~~~~ |
| 1696 |
# |
| 1697 |
# Version 2.05: Sat Oct 12 16:09:00 CEST 2002 |
| 1698 |
# Hugo van der Sanden <hv@crypt.org> |
| 1699 |
# Made -U the default, based on patch from Simon Cozens |
| 1700 |
# Version 2.04: Sun Aug 18 13:27:12 BST 2002 |
| 1701 |
# Randy W. Sims <RandyS@ThePierianSpring.org> |
| 1702 |
# allow -n to enable nroff under Win32 |
| 1703 |
# Version 2.03: Sun Apr 23 16:56:34 BST 2000 |
| 1704 |
# Hugo van der Sanden <hv@crypt.org> |
| 1705 |
# don't die when 'use blib' fails |
| 1706 |
# Version 2.02: Mon Mar 13 18:03:04 MST 2000 |
| 1707 |
# Tom Christiansen <tchrist@perl.com> |
| 1708 |
# Added -U insecurity option |
| 1709 |
# Version 2.01: Sat Mar 11 15:22:33 MST 2000 |
| 1710 |
# Tom Christiansen <tchrist@perl.com>, querulously. |
| 1711 |
# Security and correctness patches. |
| 1712 |
# What a twisted bit of distasteful spaghetti code. |
| 1713 |
# Version 2.0: ???? |
| 1714 |
# |
| 1715 |
#~~~~~~ |
| 1716 |
# |
| 1717 |
# Version 1.15: Tue Aug 24 01:50:20 EST 1999 |
| 1718 |
# Charles Wilson <cwilson@ece.gatech.edu> |
| 1719 |
# changed /pod/ directory to /pods/ for cygwin |
| 1720 |
# to support cygwin/win32 |
| 1721 |
# Version 1.14: Wed Jul 15 01:50:20 EST 1998 |
| 1722 |
# Robin Barker <rmb1@cise.npl.co.uk> |
| 1723 |
# -strict, -w cleanups |
| 1724 |
# Version 1.13: Fri Feb 27 16:20:50 EST 1997 |
| 1725 |
# Gurusamy Sarathy <gsar@activestate.com> |
| 1726 |
# -doc tweaks for -F and -X options |
| 1727 |
# Version 1.12: Sat Apr 12 22:41:09 EST 1997 |
| 1728 |
# Gurusamy Sarathy <gsar@activestate.com> |
| 1729 |
# -various fixes for win32 |
| 1730 |
# Version 1.11: Tue Dec 26 09:54:33 EST 1995 |
| 1731 |
# Kenneth Albanowski <kjahds@kjahds.com> |
| 1732 |
# -added Charles Bailey's further VMS patches, and -u switch |
| 1733 |
# -added -t switch, with pod2text support |
| 1734 |
# |
| 1735 |
# Version 1.10: Thu Nov 9 07:23:47 EST 1995 |
| 1736 |
# Kenneth Albanowski <kjahds@kjahds.com> |
| 1737 |
# -added VMS support |
| 1738 |
# -added better error recognition (on no found pages, just exit. On |
| 1739 |
# missing nroff/pod2man, just display raw pod.) |
| 1740 |
# -added recursive/case-insensitive matching (thanks, Andreas). This |
| 1741 |
# slows things down a bit, unfortunately. Give a precise name, and |
| 1742 |
# it'll run faster. |
| 1743 |
# |
| 1744 |
# Version 1.01: Tue May 30 14:47:34 EDT 1995 |
| 1745 |
# Andy Dougherty <doughera@lafcol.lafayette.edu> |
| 1746 |
# -added pod documentation. |
| 1747 |
# -added PATH searching. |
| 1748 |
# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod |
| 1749 |
# and friends. |
| 1750 |
# |
| 1751 |
#~~~~~~~ |
| 1752 |
# |
| 1753 |
# TODO: |
| 1754 |
# |
| 1755 |
# Cache the directories read during sloppy match |
| 1756 |
# (To disk, or just in-memory?) |
| 1757 |
# |
| 1758 |
# Backport this to perl 5.005? |
| 1759 |
# |
| 1760 |
# Implement at least part of the "perlman" interface described |
| 1761 |
# in Programming Perl 3e? |
