1898184e3Ssthenuse 5.006; # we use some open(X, "<", $y) syntax 2898184e3Ssthen 3898184e3Ssthenpackage Pod::Perldoc; 4898184e3Ssthenuse strict; 5898184e3Ssthenuse warnings; 6898184e3Ssthenuse Config '%Config'; 7898184e3Ssthen 8898184e3Ssthenuse Fcntl; # for sysopen 9898184e3Ssthenuse File::Basename qw(basename); 10898184e3Ssthenuse File::Spec::Functions qw(catfile catdir splitdir); 11898184e3Ssthen 12898184e3Ssthenuse vars qw($VERSION @Pagers $Bindir $Pod2man 13898184e3Ssthen $Temp_Files_Created $Temp_File_Lifetime 14898184e3Ssthen); 159f11ffb7Safresh1$VERSION = '3.2801'; 16898184e3Ssthen 17898184e3Ssthen#.......................................................................... 18898184e3Ssthen 19898184e3SsthenBEGIN { # Make a DEBUG constant very first thing... 20898184e3Ssthen unless(defined &DEBUG) { 21898184e3Ssthen if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint 22898184e3Ssthen eval("sub DEBUG () {$1}"); 23898184e3Ssthen die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@; 24898184e3Ssthen } else { 25898184e3Ssthen *DEBUG = sub () {0}; 26898184e3Ssthen } 27898184e3Ssthen } 28898184e3Ssthen} 29898184e3Ssthen 30898184e3Ssthenuse Pod::Perldoc::GetOptsOO; # uses the DEBUG. 31898184e3Ssthenuse Carp qw(croak carp); 32898184e3Ssthen 33898184e3Ssthen# these are also in BaseTo, which I don't want to inherit 34898184e3Ssthensub debugging { 35898184e3Ssthen my $self = shift; 36898184e3Ssthen 37898184e3Ssthen ( defined(&Pod::Perldoc::DEBUG) and &Pod::Perldoc::DEBUG() ) 38898184e3Ssthen } 39898184e3Ssthen 40898184e3Ssthensub debug { 41898184e3Ssthen my( $self, @messages ) = @_; 42898184e3Ssthen return unless $self->debugging; 43898184e3Ssthen print STDERR map { "DEBUG : $_" } @messages; 44898184e3Ssthen } 45898184e3Ssthen 46898184e3Ssthensub warn { 47898184e3Ssthen my( $self, @messages ) = @_; 48898184e3Ssthen 49898184e3Ssthen carp( join "\n", @messages, '' ); 50898184e3Ssthen } 51898184e3Ssthen 52898184e3Ssthensub die { 53898184e3Ssthen my( $self, @messages ) = @_; 54898184e3Ssthen 55898184e3Ssthen croak( join "\n", @messages, '' ); 56898184e3Ssthen } 57898184e3Ssthen 58898184e3Ssthen#.......................................................................... 59898184e3Ssthen 60898184e3Ssthensub TRUE () {1} 61898184e3Ssthensub FALSE () {return} 62898184e3Ssthensub BE_LENIENT () {1} 63898184e3Ssthen 64898184e3SsthenBEGIN { 65898184e3Ssthen *is_vms = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &is_vms; 66898184e3Ssthen *is_mswin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &is_mswin32; 67898184e3Ssthen *is_dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &is_dos; 68898184e3Ssthen *is_os2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &is_os2; 69898184e3Ssthen *is_cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &is_cygwin; 70898184e3Ssthen *is_linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &is_linux; 71898184e3Ssthen *is_hpux = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &is_hpux; 72b8851fccSafresh1 *is_amigaos = $^O eq 'amigaos' ? \&TRUE : \&FALSE unless defined &is_amigaos; 73898184e3Ssthen} 74898184e3Ssthen 75898184e3Ssthen$Temp_File_Lifetime ||= 60 * 60 * 24 * 5; 76898184e3Ssthen # If it's older than five days, it's quite unlikely 77898184e3Ssthen # that anyone's still looking at it!! 78898184e3Ssthen # (Currently used only by the MSWin cleanup routine) 79898184e3Ssthen 80898184e3Ssthen 81898184e3Ssthen#.......................................................................... 82898184e3Ssthen{ my $pager = $Config{'pager'}; 83898184e3Ssthen push @Pagers, $pager if -x (split /\s+/, $pager)[0] or __PACKAGE__->is_vms; 84898184e3Ssthen} 85898184e3Ssthen$Bindir = $Config{'scriptdirexp'}; 86898184e3Ssthen$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); 87898184e3Ssthen 88898184e3Ssthen# End of class-init stuff 89898184e3Ssthen# 90898184e3Ssthen########################################################################### 91898184e3Ssthen# 92898184e3Ssthen# Option accessors... 93898184e3Ssthen 946fb12b70Safresh1foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULva}) { 95898184e3Ssthen no strict 'refs'; 96898184e3Ssthen *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; 97898184e3Ssthen} 98898184e3Ssthen 99898184e3Ssthen# And these are so that GetOptsOO knows they take options: 1006fb12b70Safresh1sub opt_a_with { shift->_elem('opt_a', @_) } 101898184e3Ssthensub opt_f_with { shift->_elem('opt_f', @_) } 102898184e3Ssthensub opt_q_with { shift->_elem('opt_q', @_) } 103898184e3Ssthensub opt_d_with { shift->_elem('opt_d', @_) } 104898184e3Ssthensub opt_L_with { shift->_elem('opt_L', @_) } 105898184e3Ssthensub opt_v_with { shift->_elem('opt_v', @_) } 106898184e3Ssthen 107898184e3Ssthensub opt_w_with { # Specify an option for the formatter subclass 108898184e3Ssthen my($self, $value) = @_; 109898184e3Ssthen if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) { 110898184e3Ssthen my $option = $1; 111898184e3Ssthen my $option_value = defined($2) ? $2 : "TRUE"; 112898184e3Ssthen $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" 113898184e3Ssthen $self->add_formatter_option( $option, $option_value ); 114898184e3Ssthen } else { 115898184e3Ssthen $self->warn( qq("$value" isn't a good formatter option name. I'm ignoring it!\n ) ); 116898184e3Ssthen } 117898184e3Ssthen return; 118898184e3Ssthen} 119898184e3Ssthen 120898184e3Ssthensub opt_M_with { # specify formatter class name(s) 121898184e3Ssthen my($self, $classes) = @_; 122898184e3Ssthen return unless defined $classes and length $classes; 123898184e3Ssthen DEBUG > 4 and print "Considering new formatter classes -M$classes\n"; 124898184e3Ssthen my @classes_to_add; 125898184e3Ssthen foreach my $classname (split m/[,;]+/s, $classes) { 126898184e3Ssthen next unless $classname =~ m/\S/; 127898184e3Ssthen if( $classname =~ m/^(\w+(::\w+)+)$/s ) { 128898184e3Ssthen # A mildly restrictive concept of what modulenames are valid. 129898184e3Ssthen push @classes_to_add, $1; # untaint 130898184e3Ssthen } else { 131898184e3Ssthen $self->warn( qq("$classname" isn't a valid classname. Ignoring.\n) ); 132898184e3Ssthen } 133898184e3Ssthen } 134898184e3Ssthen 135898184e3Ssthen unshift @{ $self->{'formatter_classes'} }, @classes_to_add; 136898184e3Ssthen 137898184e3Ssthen DEBUG > 3 and print( 138898184e3Ssthen "Adding @classes_to_add to the list of formatter classes, " 139898184e3Ssthen . "making them @{ $self->{'formatter_classes'} }.\n" 140898184e3Ssthen ); 141898184e3Ssthen 142898184e3Ssthen return; 143898184e3Ssthen} 144898184e3Ssthen 145898184e3Ssthensub opt_V { # report version and exit 146898184e3Ssthen print join '', 147898184e3Ssthen "Perldoc v$VERSION, under perl v$] for $^O", 148898184e3Ssthen 149898184e3Ssthen (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) 150898184e3Ssthen ? (" (win32 build ", &Win32::BuildNumber(), ")") : (), 151898184e3Ssthen 152898184e3Ssthen (chr(65) eq 'A') ? () : " (non-ASCII)", 153898184e3Ssthen 154898184e3Ssthen "\n", 155898184e3Ssthen ; 156898184e3Ssthen exit; 157898184e3Ssthen} 158898184e3Ssthen 159898184e3Ssthensub opt_t { # choose plaintext as output format 160898184e3Ssthen my $self = shift; 161898184e3Ssthen $self->opt_o_with('text') if @_ and $_[0]; 162898184e3Ssthen return $self->_elem('opt_t', @_); 163898184e3Ssthen} 164898184e3Ssthen 165898184e3Ssthensub opt_u { # choose raw pod as output format 166898184e3Ssthen my $self = shift; 167898184e3Ssthen $self->opt_o_with('pod') if @_ and $_[0]; 168898184e3Ssthen return $self->_elem('opt_u', @_); 169898184e3Ssthen} 170898184e3Ssthen 171898184e3Ssthensub opt_n_with { 172898184e3Ssthen # choose man as the output format, and specify the proggy to run 173898184e3Ssthen my $self = shift; 174898184e3Ssthen $self->opt_o_with('man') if @_ and $_[0]; 175898184e3Ssthen $self->_elem('opt_n', @_); 176898184e3Ssthen} 177898184e3Ssthen 178898184e3Ssthensub opt_o_with { # "o" for output format 179898184e3Ssthen my($self, $rest) = @_; 180898184e3Ssthen return unless defined $rest and length $rest; 181898184e3Ssthen if($rest =~ m/^(\w+)$/s) { 182898184e3Ssthen $rest = $1; #untaint 183898184e3Ssthen } else { 184898184e3Ssthen $self->warn( qq("$rest" isn't a valid output format. Skipping.\n") ); 185898184e3Ssthen return; 186898184e3Ssthen } 187898184e3Ssthen 188898184e3Ssthen $self->aside("Noting \"$rest\" as desired output format...\n"); 189898184e3Ssthen 190898184e3Ssthen # Figure out what class(es) that could actually mean... 191898184e3Ssthen 192898184e3Ssthen my @classes; 193898184e3Ssthen foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { 194898184e3Ssthen # Messy but smart: 195898184e3Ssthen foreach my $stem ( 196898184e3Ssthen $rest, # Yes, try it first with the given capitalization 197898184e3Ssthen "\L$rest", "\L\u$rest", "\U$rest" # And then try variations 198898184e3Ssthen 199898184e3Ssthen ) { 200898184e3Ssthen $self->aside("Considering $prefix$stem\n"); 201898184e3Ssthen push @classes, $prefix . $stem; 202898184e3Ssthen } 203898184e3Ssthen 204898184e3Ssthen # Tidier, but misses too much: 205898184e3Ssthen #push @classes, $prefix . ucfirst(lc($rest)); 206898184e3Ssthen } 207898184e3Ssthen $self->opt_M_with( join ";", @classes ); 208898184e3Ssthen return; 209898184e3Ssthen} 210898184e3Ssthen 211898184e3Ssthen########################################################################### 212898184e3Ssthen# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % 213898184e3Ssthen 214898184e3Ssthensub run { # to be called by the "perldoc" executable 215898184e3Ssthen my $class = shift; 216898184e3Ssthen if(DEBUG > 3) { 217898184e3Ssthen print "Parameters to $class\->run:\n"; 218898184e3Ssthen my @x = @_; 219898184e3Ssthen while(@x) { 220898184e3Ssthen $x[1] = '<undef>' unless defined $x[1]; 221898184e3Ssthen $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; 222898184e3Ssthen print " [$x[0]] => [$x[1]]\n"; 223898184e3Ssthen splice @x,0,2; 224898184e3Ssthen } 225898184e3Ssthen print "\n"; 226898184e3Ssthen } 227898184e3Ssthen return $class -> new(@_) -> process() || 0; 228898184e3Ssthen} 229898184e3Ssthen 230898184e3Ssthen# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % 231898184e3Ssthen########################################################################### 232898184e3Ssthen 233898184e3Ssthensub new { # yeah, nothing fancy 234898184e3Ssthen my $class = shift; 235898184e3Ssthen my $new = bless {@_}, (ref($class) || $class); 236898184e3Ssthen DEBUG > 1 and print "New $class object $new\n"; 237898184e3Ssthen $new->init(); 238898184e3Ssthen $new; 239898184e3Ssthen} 240898184e3Ssthen 241898184e3Ssthen#.......................................................................... 242898184e3Ssthen 243898184e3Ssthensub aside { # If we're in -D or DEBUG mode, say this. 244898184e3Ssthen my $self = shift; 245898184e3Ssthen if( DEBUG or $self->opt_D ) { 246898184e3Ssthen my $out = join( '', 247898184e3Ssthen DEBUG ? do { 248898184e3Ssthen my $callsub = (caller(1))[3]; 249898184e3Ssthen my $package = quotemeta(__PACKAGE__ . '::'); 250898184e3Ssthen $callsub =~ s/^$package/'/os; 251898184e3Ssthen # the o is justified, as $package really won't change. 252898184e3Ssthen $callsub . ": "; 253898184e3Ssthen } : '', 254898184e3Ssthen @_, 255898184e3Ssthen ); 256898184e3Ssthen if(DEBUG) { print $out } else { print STDERR $out } 257898184e3Ssthen } 258898184e3Ssthen return; 259898184e3Ssthen} 260898184e3Ssthen 261898184e3Ssthen#.......................................................................... 262898184e3Ssthen 263898184e3Ssthensub usage { 264898184e3Ssthen my $self = shift; 265898184e3Ssthen $self->warn( "@_\n" ) if @_; 266898184e3Ssthen 267898184e3Ssthen # Erase evidence of previous errors (if any), so exit status is simple. 268898184e3Ssthen $! = 0; 269898184e3Ssthen 270898184e3Ssthen CORE::die( <<EOF ); 271898184e3Ssthenperldoc [options] PageName|ModuleName|ProgramName|URL... 272898184e3Ssthenperldoc [options] -f BuiltinFunction 273898184e3Ssthenperldoc [options] -q FAQRegex 274898184e3Ssthenperldoc [options] -v PerlVariable 275898184e3Ssthen 276898184e3SsthenOptions: 277898184e3Ssthen -h Display this help message 278898184e3Ssthen -V Report version 279898184e3Ssthen -r Recursive search (slow) 280898184e3Ssthen -i Ignore case 281898184e3Ssthen -t Display pod using pod2text instead of Pod::Man and groff 282898184e3Ssthen (-t is the default on win32 unless -n is specified) 283898184e3Ssthen -u Display unformatted pod text 284898184e3Ssthen -m Display module's file in its entirety 285898184e3Ssthen -n Specify replacement for groff 286898184e3Ssthen -l Display the module's file name 2879f11ffb7Safresh1 -U Don't attempt to drop privs for security 2889f11ffb7Safresh1 -F Arguments are file names, not modules (implies -U) 289898184e3Ssthen -D Verbosely describe what's going on 290898184e3Ssthen -T Send output to STDOUT without any pager 291898184e3Ssthen -d output_filename_to_send_to 292898184e3Ssthen -o output_format_name 293898184e3Ssthen -M FormatterModuleNameToUse 294898184e3Ssthen -w formatter_option:option_value 295898184e3Ssthen -L translation_code Choose doc translation (if any) 296898184e3Ssthen -X Use index if present (looks for pod.idx at $Config{archlib}) 297898184e3Ssthen -q Search the text of questions (not answers) in perlfaq[1-9] 298898184e3Ssthen -f Search Perl built-in functions 2996fb12b70Safresh1 -a Search Perl API 300898184e3Ssthen -v Search predefined Perl variables 301898184e3Ssthen 302898184e3SsthenPageName|ModuleName|ProgramName|URL... 303898184e3Ssthen is the name of a piece of documentation that you want to look at. You 304898184e3Ssthen may either give a descriptive name of the page (as in the case of 305898184e3Ssthen `perlfunc') the name of a module, either like `Term::Info' or like 306898184e3Ssthen `Term/Info', or the name of a program, like `perldoc', or a URL 307898184e3Ssthen starting with http(s). 308898184e3Ssthen 309898184e3SsthenBuiltinFunction 310898184e3Ssthen is the name of a perl function. Will extract documentation from 311898184e3Ssthen `perlfunc' or `perlop'. 312898184e3Ssthen 313898184e3SsthenFAQRegex 314898184e3Ssthen is a regex. Will search perlfaq[1-9] for and extract any 315898184e3Ssthen questions that match. 316898184e3Ssthen 317898184e3SsthenAny switches in the PERLDOC environment variable will be used before the 318898184e3Ssthencommand line arguments. The optional pod index file contains a list of 319898184e3Ssthenfilenames, one per line. 320898184e3Ssthen [Perldoc v$VERSION] 321898184e3SsthenEOF 322898184e3Ssthen 323898184e3Ssthen} 324898184e3Ssthen 325898184e3Ssthen#.......................................................................... 326898184e3Ssthen 327898184e3Ssthensub program_name { 328898184e3Ssthen my( $self ) = @_; 329898184e3Ssthen 330898184e3Ssthen if( my $link = readlink( $0 ) ) { 331898184e3Ssthen $self->debug( "The value in $0 is a symbolic link to $link\n" ); 332898184e3Ssthen } 333898184e3Ssthen 334898184e3Ssthen my $basename = basename( $0 ); 335898184e3Ssthen 336898184e3Ssthen $self->debug( "\$0 is [$0]\nbasename is [$basename]\n" ); 337898184e3Ssthen # possible name forms 338898184e3Ssthen # perldoc 339898184e3Ssthen # perldoc-v5.14 340898184e3Ssthen # perldoc-5.14 341898184e3Ssthen # perldoc-5.14.2 342898184e3Ssthen # perlvar # an alias mentioned in Camel 3 343898184e3Ssthen { 344898184e3Ssthen my( $untainted ) = $basename =~ m/( 345898184e3Ssthen \A 346898184e3Ssthen perl 347898184e3Ssthen (?: doc | func | faq | help | op | toc | var # Camel 3 348898184e3Ssthen ) 349898184e3Ssthen (?: -? v? \d+ \. \d+ (?:\. \d+)? )? # possible version 350898184e3Ssthen (?: \. (?: bat | exe | com ) )? # possible extension 351898184e3Ssthen \z 352898184e3Ssthen ) 353898184e3Ssthen /x; 354898184e3Ssthen 355898184e3Ssthen $self->debug($untainted); 356898184e3Ssthen return $untainted if $untainted; 357898184e3Ssthen } 358898184e3Ssthen 359898184e3Ssthen $self->warn(<<"HERE"); 360898184e3SsthenYou called the perldoc command with a name that I didn't recognize. 361898184e3SsthenThis might mean that someone is tricking you into running a 362898184e3Ssthenprogram you don't intend to use, but it also might mean that you 363898184e3Ssthencreated your own link to perldoc. I think your program name is 364898184e3Ssthen[$basename]. 365898184e3Ssthen 366898184e3SsthenI'll allow this if the filename only has [a-zA-Z0-9._-]. 367898184e3SsthenHERE 368898184e3Ssthen 369898184e3Ssthen { 370898184e3Ssthen my( $untainted ) = $basename =~ m/( 371898184e3Ssthen \A [a-zA-Z0-9._-]+ \z 372898184e3Ssthen )/x; 373898184e3Ssthen 374898184e3Ssthen $self->debug($untainted); 375898184e3Ssthen return $untainted if $untainted; 376898184e3Ssthen } 377898184e3Ssthen 378898184e3Ssthen $self->die(<<"HERE"); 379898184e3SsthenI think that your name for perldoc is potentially unsafe, so I'm 380898184e3Ssthengoing to disallow it. I'd rather you be safe than sorry. If you 381898184e3Ssthenintended to use the name I'm disallowing, please tell the maintainers 382898184e3Ssthenabout it. Write to: 383898184e3Ssthen 384898184e3Ssthen Pod-Perldoc\@rt.cpan.org 385898184e3Ssthen 386898184e3SsthenHERE 387898184e3Ssthen} 388898184e3Ssthen 389898184e3Ssthen#.......................................................................... 390898184e3Ssthen 391898184e3Ssthensub usage_brief { 392898184e3Ssthen my $self = shift; 393898184e3Ssthen my $program_name = $self->program_name; 394898184e3Ssthen 395898184e3Ssthen CORE::die( <<"EOUSAGE" ); 3969f11ffb7Safresh1Usage: $program_name [-hVriDtumUFXlT] [-n nroffer_program] 397898184e3Ssthen [-d output_filename] [-o output_format] [-M FormatterModule] 398898184e3Ssthen [-w formatter_option:option_value] [-L translation_code] 399898184e3Ssthen PageName|ModuleName|ProgramName 400898184e3Ssthen 401898184e3SsthenExamples: 402898184e3Ssthen 403898184e3Ssthen $program_name -f PerlFunc 404898184e3Ssthen $program_name -q FAQKeywords 405898184e3Ssthen $program_name -v PerlVar 4066fb12b70Safresh1 $program_name -a PerlAPI 407898184e3Ssthen 408898184e3SsthenThe -h option prints more help. Also try "$program_name perldoc" to get 409898184e3Ssthenacquainted with the system. [Perldoc v$VERSION] 410898184e3SsthenEOUSAGE 411898184e3Ssthen 412898184e3Ssthen} 413898184e3Ssthen 414898184e3Ssthen#.......................................................................... 415898184e3Ssthen 416898184e3Ssthensub pagers { @{ shift->{'pagers'} } } 417898184e3Ssthen 418898184e3Ssthen#.......................................................................... 419898184e3Ssthen 420898184e3Ssthensub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_) 421898184e3Ssthen if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] } 422898184e3Ssthen else { return $_[0]{ $_[1] } } 423898184e3Ssthen} 424898184e3Ssthen#.......................................................................... 425898184e3Ssthen########################################################################### 426898184e3Ssthen# 427898184e3Ssthen# Init formatter switches, and start it off with __bindir and all that 428898184e3Ssthen# other stuff that ToMan.pm needs. 429898184e3Ssthen# 430898184e3Ssthen 431898184e3Ssthensub init { 432898184e3Ssthen my $self = shift; 433898184e3Ssthen 434898184e3Ssthen # Make sure creat()s are neither too much nor too little 435898184e3Ssthen eval { umask(0077) }; # doubtless someone has no mask 436898184e3Ssthen 437b8851fccSafresh1 if ( $] < 5.008 ) { 438b8851fccSafresh1 $self->aside("Your old perl doesn't have proper unicode support."); 439b8851fccSafresh1 } 440b8851fccSafresh1 else { 441b8851fccSafresh1 # http://www.perl.com/pub/2012/04/perlunicookbook-decode-argv-as-utf8.html 442b8851fccSafresh1 # Decode command line arguments as UTF-8. See RT#98906 for example problem. 443b8851fccSafresh1 use Encode qw(decode_utf8); 444b8851fccSafresh1 @ARGV = map { decode_utf8($_, 1) } @ARGV; 445b8851fccSafresh1 } 446b8851fccSafresh1 447898184e3Ssthen $self->{'args'} ||= \@ARGV; 448898184e3Ssthen $self->{'found'} ||= []; 449898184e3Ssthen $self->{'temp_file_list'} ||= []; 450898184e3Ssthen 451898184e3Ssthen 452898184e3Ssthen $self->{'target'} = undef; 453898184e3Ssthen 454898184e3Ssthen $self->init_formatter_class_list; 455898184e3Ssthen 456898184e3Ssthen $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; 457898184e3Ssthen $self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; 458898184e3Ssthen $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; 4596fb12b70Safresh1 $self->{'search_path'} = [ ] unless exists $self->{'search_path'}; 460898184e3Ssthen 461898184e3Ssthen push @{ $self->{'formatter_switches'} = [] }, ( 462898184e3Ssthen # Yeah, we could use a hashref, but maybe there's some class where options 463898184e3Ssthen # have to be ordered; so we'll use an arrayref. 464898184e3Ssthen 465898184e3Ssthen [ '__bindir' => $self->{'bindir' } ], 466898184e3Ssthen [ '__pod2man' => $self->{'pod2man'} ], 467898184e3Ssthen ); 468898184e3Ssthen 469898184e3Ssthen DEBUG > 3 and printf "Formatter switches now: [%s]\n", 470898184e3Ssthen join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; 471898184e3Ssthen 472898184e3Ssthen $self->{'translators'} = []; 473898184e3Ssthen $self->{'extra_search_dirs'} = []; 474898184e3Ssthen 475898184e3Ssthen return; 476898184e3Ssthen} 477898184e3Ssthen 478898184e3Ssthen#.......................................................................... 479898184e3Ssthen 480898184e3Ssthensub init_formatter_class_list { 481898184e3Ssthen my $self = shift; 482898184e3Ssthen $self->{'formatter_classes'} ||= []; 483898184e3Ssthen 484898184e3Ssthen # Remember, no switches have been read yet, when 485898184e3Ssthen # we've started this routine. 486898184e3Ssthen 487898184e3Ssthen $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru 488898184e3Ssthen $self->opt_o_with('text'); 489*9dc91179Safresh1 $self->opt_o_with('man') 490*9dc91179Safresh1 if $ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i; 491898184e3Ssthen 492898184e3Ssthen return; 493898184e3Ssthen} 494898184e3Ssthen 495898184e3Ssthen#.......................................................................... 496898184e3Ssthen 497898184e3Ssthensub process { 498898184e3Ssthen # if this ever returns, its retval will be used for exit(RETVAL) 499898184e3Ssthen 500898184e3Ssthen my $self = shift; 501898184e3Ssthen DEBUG > 1 and print " Beginning process.\n"; 502898184e3Ssthen DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n"; 503898184e3Ssthen if(DEBUG > 3) { 504898184e3Ssthen print "Object contents:\n"; 505898184e3Ssthen my @x = %$self; 506898184e3Ssthen while(@x) { 507898184e3Ssthen $x[1] = '<undef>' unless defined $x[1]; 508898184e3Ssthen $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; 509898184e3Ssthen print " [$x[0]] => [$x[1]]\n"; 510898184e3Ssthen splice @x,0,2; 511898184e3Ssthen } 512898184e3Ssthen print "\n"; 513898184e3Ssthen } 514898184e3Ssthen 515898184e3Ssthen # TODO: make it deal with being invoked as various different things 516898184e3Ssthen # such as perlfaq". 517898184e3Ssthen 518898184e3Ssthen return $self->usage_brief unless @{ $self->{'args'} }; 519898184e3Ssthen $self->options_reading; 5206fb12b70Safresh1 $self->pagers_guessing; 521898184e3Ssthen $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); 5229f11ffb7Safresh1 $self->drop_privs_maybe unless ($self->opt_U || $self->opt_F); 523898184e3Ssthen $self->options_processing; 524898184e3Ssthen 525898184e3Ssthen # Hm, we have @pages and @found, but we only really act on one 526898184e3Ssthen # file per call, with the exception of the opt_q hack, and with 527898184e3Ssthen # -l things 528898184e3Ssthen 529898184e3Ssthen $self->aside("\n"); 530898184e3Ssthen 531898184e3Ssthen my @pages; 532898184e3Ssthen $self->{'pages'} = \@pages; 533898184e3Ssthen if( $self->opt_f) { @pages = qw(perlfunc perlop) } 534898184e3Ssthen elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } 535898184e3Ssthen elsif( $self->opt_v) { @pages = ("perlvar") } 5366fb12b70Safresh1 elsif( $self->opt_a) { @pages = ("perlapi") } 537898184e3Ssthen else { @pages = @{$self->{'args'}}; 538898184e3Ssthen # @pages = __FILE__ 539898184e3Ssthen # if @pages == 1 and $pages[0] eq 'perldoc'; 540898184e3Ssthen } 541898184e3Ssthen 542898184e3Ssthen return $self->usage_brief unless @pages; 543898184e3Ssthen 544898184e3Ssthen $self->find_good_formatter_class(); 545898184e3Ssthen $self->formatter_sanity_check(); 546898184e3Ssthen 5476fb12b70Safresh1 $self->maybe_extend_searchpath(); 548898184e3Ssthen # for when we're apparently in a module or extension directory 549898184e3Ssthen 550898184e3Ssthen my @found = $self->grand_search_init(\@pages); 551898184e3Ssthen exit ($self->is_vms ? 98962 : 1) unless @found; 552898184e3Ssthen 553898184e3Ssthen if ($self->opt_l and not $self->opt_q ) { 554898184e3Ssthen DEBUG and print "We're in -l mode, so byebye after this:\n"; 555898184e3Ssthen print join("\n", @found), "\n"; 556898184e3Ssthen return; 557898184e3Ssthen } 558898184e3Ssthen 559898184e3Ssthen $self->tweak_found_pathnames(\@found); 560898184e3Ssthen $self->assert_closing_stdout; 561898184e3Ssthen return $self->page_module_file(@found) if $self->opt_m; 562898184e3Ssthen DEBUG > 2 and print "Found: [@found]\n"; 563898184e3Ssthen 564898184e3Ssthen return $self->render_and_page(\@found); 565898184e3Ssthen} 566898184e3Ssthen 567898184e3Ssthen#.......................................................................... 568898184e3Ssthen{ 569898184e3Ssthen 570898184e3Ssthenmy( %class_seen, %class_loaded ); 571898184e3Ssthensub find_good_formatter_class { 572898184e3Ssthen my $self = $_[0]; 573898184e3Ssthen my @class_list = @{ $self->{'formatter_classes'} || [] }; 574898184e3Ssthen $self->die( "WHAT? Nothing in the formatter class list!?" ) unless @class_list; 575898184e3Ssthen 5760b7734b3Safresh1 local @INC = @INC; 5770b7734b3Safresh1 pop @INC if $INC[-1] eq '.'; 5780b7734b3Safresh1 579898184e3Ssthen my $good_class_found; 580898184e3Ssthen foreach my $c (@class_list) { 581898184e3Ssthen DEBUG > 4 and print "Trying to load $c...\n"; 582898184e3Ssthen if($class_loaded{$c}) { 583898184e3Ssthen DEBUG > 4 and print "OK, the already-loaded $c it is!\n"; 584898184e3Ssthen $good_class_found = $c; 585898184e3Ssthen last; 586898184e3Ssthen } 587898184e3Ssthen 588898184e3Ssthen if($class_seen{$c}) { 589898184e3Ssthen DEBUG > 4 and print 590898184e3Ssthen "I've tried $c before, and it's no good. Skipping.\n"; 591898184e3Ssthen next; 592898184e3Ssthen } 593898184e3Ssthen 594898184e3Ssthen $class_seen{$c} = 1; 595898184e3Ssthen 596898184e3Ssthen if( $c->can('parse_from_file') ) { 597898184e3Ssthen DEBUG > 4 and print 598898184e3Ssthen "Interesting, the formatter class $c is already loaded!\n"; 599898184e3Ssthen 600898184e3Ssthen } elsif( 601898184e3Ssthen ( $self->is_os2 or $self->is_mswin32 or $self->is_dos or $self->is_os2) 602898184e3Ssthen # the always case-insensitive filesystems 603898184e3Ssthen and $class_seen{lc("~$c")}++ 604898184e3Ssthen ) { 605898184e3Ssthen DEBUG > 4 and print 606898184e3Ssthen "We already used something quite like \"\L$c\E\", so no point using $c\n"; 607898184e3Ssthen # This avoids redefining the package. 608898184e3Ssthen } else { 609898184e3Ssthen DEBUG > 4 and print "Trying to eval 'require $c'...\n"; 610898184e3Ssthen 611898184e3Ssthen local $^W = $^W; 612898184e3Ssthen if(DEBUG() or $self->opt_D) { 613898184e3Ssthen # feh, let 'em see it 614898184e3Ssthen } else { 615898184e3Ssthen $^W = 0; 616898184e3Ssthen # The average user just has no reason to be seeing 6176fb12b70Safresh1 # $^W-suppressible warnings from the require! 618898184e3Ssthen } 619898184e3Ssthen 620898184e3Ssthen eval "require $c"; 621898184e3Ssthen if($@) { 622898184e3Ssthen DEBUG > 4 and print "Couldn't load $c: $!\n"; 623898184e3Ssthen next; 624898184e3Ssthen } 625898184e3Ssthen } 626898184e3Ssthen 627898184e3Ssthen if( $c->can('parse_from_file') ) { 628898184e3Ssthen DEBUG > 4 and print "Settling on $c\n"; 629898184e3Ssthen my $v = $c->VERSION; 630898184e3Ssthen $v = ( defined $v and length $v ) ? " version $v" : ''; 631898184e3Ssthen $self->aside("Formatter class $c$v successfully loaded!\n"); 632898184e3Ssthen $good_class_found = $c; 633898184e3Ssthen last; 634898184e3Ssthen } else { 635898184e3Ssthen DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; 636898184e3Ssthen } 637898184e3Ssthen } 638898184e3Ssthen 639898184e3Ssthen $self->die( "Can't find any loadable formatter class in @class_list?!\nAborting" ) 640898184e3Ssthen unless $good_class_found; 641898184e3Ssthen 642898184e3Ssthen $self->{'formatter_class'} = $good_class_found; 643898184e3Ssthen $self->aside("Will format with the class $good_class_found\n"); 644898184e3Ssthen 645898184e3Ssthen return; 646898184e3Ssthen} 647898184e3Ssthen 648898184e3Ssthen} 649898184e3Ssthen#.......................................................................... 650898184e3Ssthen 651898184e3Ssthensub formatter_sanity_check { 652898184e3Ssthen my $self = shift; 653898184e3Ssthen my $formatter_class = $self->{'formatter_class'} 654898184e3Ssthen || $self->die( "NO FORMATTER CLASS YET!?" ); 655898184e3Ssthen 656898184e3Ssthen if(!$self->opt_T # so -T can FORCE sending to STDOUT 657898184e3Ssthen and $formatter_class->can('is_pageable') 658898184e3Ssthen and !$formatter_class->is_pageable 659898184e3Ssthen and !$formatter_class->can('page_for_perldoc') 660898184e3Ssthen ) { 661898184e3Ssthen my $ext = 662898184e3Ssthen ($formatter_class->can('output_extension') 663898184e3Ssthen && $formatter_class->output_extension 664898184e3Ssthen ) || ''; 665898184e3Ssthen $ext = ".$ext" if length $ext; 666898184e3Ssthen 667898184e3Ssthen my $me = $self->program_name; 668898184e3Ssthen $self->die( 669898184e3Ssthen "When using Perldoc to format with $formatter_class, you have to\n" 670898184e3Ssthen . "specify -T or -dsomefile$ext\n" 671898184e3Ssthen . "See `$me perldoc' for more information on those switches.\n" ) 672898184e3Ssthen ; 673898184e3Ssthen } 674898184e3Ssthen} 675898184e3Ssthen 676898184e3Ssthen#.......................................................................... 677898184e3Ssthen 678898184e3Ssthensub render_and_page { 679898184e3Ssthen my($self, $found_list) = @_; 680898184e3Ssthen 681898184e3Ssthen $self->maybe_generate_dynamic_pod($found_list); 682898184e3Ssthen 683898184e3Ssthen my($out, $formatter) = $self->render_findings($found_list); 684898184e3Ssthen 685898184e3Ssthen if($self->opt_d) { 686898184e3Ssthen printf "Perldoc (%s) output saved to %s\n", 687898184e3Ssthen $self->{'formatter_class'} || ref($self), 688898184e3Ssthen $out; 689898184e3Ssthen print "But notice that it's 0 bytes long!\n" unless -s $out; 690898184e3Ssthen 691898184e3Ssthen 692898184e3Ssthen } elsif( # Allow the formatter to "page" itself, if it wants. 693898184e3Ssthen $formatter->can('page_for_perldoc') 694898184e3Ssthen and do { 695898184e3Ssthen $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n"); 696898184e3Ssthen if( $formatter->page_for_perldoc($out, $self) ) { 697898184e3Ssthen $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n"); 698898184e3Ssthen 1; 699898184e3Ssthen } else { 700898184e3Ssthen $self->aside("page_for_perldoc returned false, so paging with $self instead.\n"); 701898184e3Ssthen ''; 702898184e3Ssthen } 703898184e3Ssthen } 704898184e3Ssthen ) { 705898184e3Ssthen # Do nothing, since the formatter has "paged" it for itself. 706898184e3Ssthen 707898184e3Ssthen } else { 708898184e3Ssthen # Page it normally (internally) 709898184e3Ssthen 710898184e3Ssthen if( -s $out ) { # Usual case: 711898184e3Ssthen $self->page($out, $self->{'output_to_stdout'}, $self->pagers); 712898184e3Ssthen 713898184e3Ssthen } else { 714898184e3Ssthen # Odd case: 715898184e3Ssthen $self->aside("Skipping $out (from $$found_list[0] " 716898184e3Ssthen . "via $$self{'formatter_class'}) as it is 0-length.\n"); 717898184e3Ssthen 718898184e3Ssthen push @{ $self->{'temp_file_list'} }, $out; 719898184e3Ssthen $self->unlink_if_temp_file($out); 720898184e3Ssthen } 721898184e3Ssthen } 722898184e3Ssthen 723898184e3Ssthen $self->after_rendering(); # any extra cleanup or whatever 724898184e3Ssthen 725898184e3Ssthen return; 726898184e3Ssthen} 727898184e3Ssthen 728898184e3Ssthen#.......................................................................... 729898184e3Ssthen 730898184e3Ssthensub options_reading { 731898184e3Ssthen my $self = shift; 732898184e3Ssthen 733898184e3Ssthen if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { 734898184e3Ssthen require Text::ParseWords; 735898184e3Ssthen $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); 736898184e3Ssthen # Yes, appends to the beginning 737898184e3Ssthen unshift @{ $self->{'args'} }, 738898184e3Ssthen Text::ParseWords::shellwords( $ENV{"PERLDOC"} ) 739898184e3Ssthen ; 740898184e3Ssthen DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n"; 741898184e3Ssthen } else { 742898184e3Ssthen DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n"; 743898184e3Ssthen } 744898184e3Ssthen 745898184e3Ssthen DEBUG > 1 746898184e3Ssthen and print " Args right before switch processing: @{$self->{'args'}}\n"; 747898184e3Ssthen 748898184e3Ssthen Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' ) 749898184e3Ssthen or return $self->usage; 750898184e3Ssthen 751898184e3Ssthen DEBUG > 1 752898184e3Ssthen and print " Args after switch processing: @{$self->{'args'}}\n"; 753898184e3Ssthen 754898184e3Ssthen return $self->usage if $self->opt_h; 755898184e3Ssthen 756898184e3Ssthen return; 757898184e3Ssthen} 758898184e3Ssthen 759898184e3Ssthen#.......................................................................... 760898184e3Ssthen 761898184e3Ssthensub options_processing { 762898184e3Ssthen my $self = shift; 763898184e3Ssthen 764898184e3Ssthen if ($self->opt_X) { 765898184e3Ssthen my $podidx = "$Config{'archlib'}/pod.idx"; 766898184e3Ssthen $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; 767898184e3Ssthen $self->{'podidx'} = $podidx; 768898184e3Ssthen } 769898184e3Ssthen 770898184e3Ssthen $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT; 771898184e3Ssthen 772898184e3Ssthen $self->options_sanity; 773898184e3Ssthen 774898184e3Ssthen # This used to set a default, but that's now moved into any 775898184e3Ssthen # formatter that cares to have a default. 776898184e3Ssthen if( $self->opt_n ) { 777898184e3Ssthen $self->add_formatter_option( '__nroffer' => $self->opt_n ); 778898184e3Ssthen } 779898184e3Ssthen 780898184e3Ssthen # Get language from PERLDOC_POD2 environment variable 781898184e3Ssthen if ( ! $self->opt_L && $ENV{PERLDOC_POD2} ) { 782898184e3Ssthen if ( $ENV{PERLDOC_POD2} eq '1' ) { 783898184e3Ssthen $self->_elem('opt_L',(split(/\_/, $ENV{LC_ALL} || $ENV{LC_LANG} || $ENV{LANG}))[0] ); 784898184e3Ssthen } 785898184e3Ssthen else { 786898184e3Ssthen $self->_elem('opt_L', $ENV{PERLDOC_POD2}); 787898184e3Ssthen } 788898184e3Ssthen }; 789898184e3Ssthen 790898184e3Ssthen # Adjust for using translation packages 791898184e3Ssthen $self->add_translator(split(/\s+/,$self->opt_L)) if $self->opt_L; 792898184e3Ssthen 793898184e3Ssthen return; 794898184e3Ssthen} 795898184e3Ssthen 796898184e3Ssthen#.......................................................................... 797898184e3Ssthen 798898184e3Ssthensub options_sanity { 799898184e3Ssthen my $self = shift; 800898184e3Ssthen 801898184e3Ssthen # The opts-counting stuff interacts quite badly with 802898184e3Ssthen # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"} 803898184e3Ssthen # set to -t, and I specify -u on the command line, I don't want 804898184e3Ssthen # to be hectored at that -u and -t don't make sense together. 805898184e3Ssthen 806898184e3Ssthen #my $opts = grep $_ && 1, # yes, the count of the set ones 807898184e3Ssthen # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l 808898184e3Ssthen #; 809898184e3Ssthen # 810898184e3Ssthen #$self->usage("only one of -t, -u, -m or -l") if $opts > 1; 811898184e3Ssthen 812898184e3Ssthen 813898184e3Ssthen # Any sanity-checking need doing here? 814898184e3Ssthen 815898184e3Ssthen # But does not make sense to set either -f or -q in $ENV{"PERLDOC"} 8166fb12b70Safresh1 if( $self->opt_f or $self->opt_q or $self->opt_a) { 8176fb12b70Safresh1 my $count; 8186fb12b70Safresh1 $count++ if $self->opt_f; 8196fb12b70Safresh1 $count++ if $self->opt_q; 8206fb12b70Safresh1 $count++ if $self->opt_a; 8216fb12b70Safresh1 $self->usage("Only one of -f or -q or -a") if $count > 1; 822898184e3Ssthen $self->warn( 82391f110e0Safresh1 "Perldoc is meant for reading one file at a time.\n", 824898184e3Ssthen "So these parameters are being ignored: ", 825898184e3Ssthen join(' ', @{$self->{'args'}}), 826898184e3Ssthen "\n" ) 827898184e3Ssthen if @{$self->{'args'}} 828898184e3Ssthen } 829898184e3Ssthen return; 830898184e3Ssthen} 831898184e3Ssthen 832898184e3Ssthen#.......................................................................... 833898184e3Ssthen 834898184e3Ssthensub grand_search_init { 835898184e3Ssthen my($self, $pages, @found) = @_; 836898184e3Ssthen 837898184e3Ssthen foreach (@$pages) { 838898184e3Ssthen if (/^http(s)?:\/\//) { 839898184e3Ssthen require HTTP::Tiny; 840898184e3Ssthen require File::Temp; 841898184e3Ssthen my $response = HTTP::Tiny->new->get($_); 842898184e3Ssthen if ($response->{success}) { 843898184e3Ssthen my ($fh, $filename) = File::Temp::tempfile(UNLINK => 1); 844898184e3Ssthen $fh->print($response->{content}); 845898184e3Ssthen push @found, $filename; 846898184e3Ssthen ($self->{podnames}{$filename} = 847898184e3Ssthen m{.*/([^/#?]+)} ? uc $1 : "UNKNOWN") 848898184e3Ssthen =~ s/\.P(?:[ML]|OD)\z//; 849898184e3Ssthen } 850898184e3Ssthen else { 851898184e3Ssthen print STDERR "No " . 852898184e3Ssthen ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; 8539f11ffb7Safresh1 if ( /^https/ ) { 8549f11ffb7Safresh1 print STDERR "You may need an SSL library (such as IO::Socket::SSL) for that URL.\n"; 8559f11ffb7Safresh1 } 856898184e3Ssthen } 857898184e3Ssthen next; 858898184e3Ssthen } 859898184e3Ssthen if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { 860898184e3Ssthen my $searchfor = catfile split '::', $_; 861898184e3Ssthen $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); 862898184e3Ssthen local $_; 863898184e3Ssthen while (<PODIDX>) { 864898184e3Ssthen chomp; 865898184e3Ssthen push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; 866898184e3Ssthen } 867898184e3Ssthen close(PODIDX) or $self->die( "Can't close $$self{'podidx'}: $!" ); 868898184e3Ssthen next; 869898184e3Ssthen } 870898184e3Ssthen 871898184e3Ssthen $self->aside( "Searching for $_\n" ); 872898184e3Ssthen 873898184e3Ssthen if ($self->opt_F) { 874898184e3Ssthen next unless -r; 875898184e3Ssthen push @found, $_ if $self->opt_l or $self->opt_m or $self->containspod($_); 876898184e3Ssthen next; 877898184e3Ssthen } 878898184e3Ssthen 879898184e3Ssthen my @searchdirs; 880898184e3Ssthen 881898184e3Ssthen # prepend extra search directories (including language specific) 882898184e3Ssthen push @searchdirs, @{ $self->{'extra_search_dirs'} }; 883898184e3Ssthen 884898184e3Ssthen # We must look both in @INC for library modules and in $bindir 885898184e3Ssthen # for executables, like h2xs or perldoc itself. 8866fb12b70Safresh1 push @searchdirs, ($self->{'bindir'}, @{$self->{search_path}}, @INC); 887898184e3Ssthen unless ($self->opt_m) { 888898184e3Ssthen if ($self->is_vms) { 889898184e3Ssthen my($i,$trn); 890898184e3Ssthen for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { 891898184e3Ssthen push(@searchdirs,$trn); 892898184e3Ssthen } 893898184e3Ssthen push(@searchdirs,'perl_root:[lib.pods]') # installed pods 894898184e3Ssthen } 895898184e3Ssthen else { 896898184e3Ssthen push(@searchdirs, grep(-d, split($Config{path_sep}, 897898184e3Ssthen $ENV{'PATH'}))); 898898184e3Ssthen } 899898184e3Ssthen } 900898184e3Ssthen my @files = $self->searchfor(0,$_,@searchdirs); 901898184e3Ssthen if (@files) { 902898184e3Ssthen $self->aside( "Found as @files\n" ); 903898184e3Ssthen } 904898184e3Ssthen # add "perl" prefix, so "perldoc foo" may find perlfoo.pod 905898184e3Ssthen elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) { 906898184e3Ssthen $self->aside( "Loosely found as @files\n" ); 907898184e3Ssthen } 908898184e3Ssthen else { 909898184e3Ssthen # no match, try recursive search 910898184e3Ssthen @searchdirs = grep(!/^\.\z/s,@INC); 911898184e3Ssthen @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r; 912898184e3Ssthen if (@files) { 913898184e3Ssthen $self->aside( "Loosely found as @files\n" ); 914898184e3Ssthen } 915898184e3Ssthen else { 916898184e3Ssthen print STDERR "No " . 917898184e3Ssthen ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; 918898184e3Ssthen if ( @{ $self->{'found'} } ) { 919898184e3Ssthen print STDERR "However, try\n"; 920898184e3Ssthen my $me = $self->program_name; 921898184e3Ssthen for my $dir (@{ $self->{'found'} }) { 922898184e3Ssthen opendir(DIR, $dir) or $self->die( "opendir $dir: $!" ); 923898184e3Ssthen while (my $file = readdir(DIR)) { 924898184e3Ssthen next if ($file =~ /^\./s); 925898184e3Ssthen $file =~ s/\.(pm|pod)\z//; # XXX: badfs 926898184e3Ssthen print STDERR "\t$me $_\::$file\n"; 927898184e3Ssthen } 928898184e3Ssthen closedir(DIR) or $self->die( "closedir $dir: $!" ); 929898184e3Ssthen } 930898184e3Ssthen } 931898184e3Ssthen } 932898184e3Ssthen } 933898184e3Ssthen push(@found,@files); 934898184e3Ssthen } 935898184e3Ssthen return @found; 936898184e3Ssthen} 937898184e3Ssthen 938898184e3Ssthen#.......................................................................... 939898184e3Ssthen 940898184e3Ssthensub maybe_generate_dynamic_pod { 941898184e3Ssthen my($self, $found_things) = @_; 942898184e3Ssthen my @dynamic_pod; 943898184e3Ssthen 9446fb12b70Safresh1 $self->search_perlapi($found_things, \@dynamic_pod) if $self->opt_a; 9456fb12b70Safresh1 946898184e3Ssthen $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; 947898184e3Ssthen 948898184e3Ssthen $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v; 949898184e3Ssthen 950898184e3Ssthen $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; 951898184e3Ssthen 9526fb12b70Safresh1 if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v and ! $self->opt_a) { 953898184e3Ssthen DEBUG > 4 and print "That's a non-dynamic pod search.\n"; 954898184e3Ssthen } elsif ( @dynamic_pod ) { 955898184e3Ssthen $self->aside("Hm, I found some Pod from that search!\n"); 956898184e3Ssthen my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); 9576fb12b70Safresh1 if ( $] >= 5.008 && $self->opt_L ) { 958b8851fccSafresh1 binmode($buffd, ":encoding(UTF-8)"); 9596fb12b70Safresh1 print $buffd "=encoding utf8\n\n"; 9606fb12b70Safresh1 } 961898184e3Ssthen 962898184e3Ssthen push @{ $self->{'temp_file_list'} }, $buffer; 963898184e3Ssthen # I.e., it MIGHT be deleted at the end. 964898184e3Ssthen 9656fb12b70Safresh1 my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v || $self->opt_a; 966898184e3Ssthen 967898184e3Ssthen print $buffd "=over 8\n\n" if $in_list; 968898184e3Ssthen print $buffd @dynamic_pod or $self->die( "Can't print $buffer: $!" ); 969898184e3Ssthen print $buffd "=back\n" if $in_list; 970898184e3Ssthen 971898184e3Ssthen close $buffd or $self->die( "Can't close $buffer: $!" ); 972898184e3Ssthen 973898184e3Ssthen @$found_things = $buffer; 974898184e3Ssthen # Yes, so found_things never has more than one thing in 975898184e3Ssthen # it, by time we leave here 976898184e3Ssthen 977898184e3Ssthen $self->add_formatter_option('__filter_nroff' => 1); 978898184e3Ssthen 979898184e3Ssthen } else { 980898184e3Ssthen @$found_things = (); 981898184e3Ssthen $self->aside("I found no Pod from that search!\n"); 982898184e3Ssthen } 983898184e3Ssthen 984898184e3Ssthen return; 985898184e3Ssthen} 986898184e3Ssthen 987898184e3Ssthen#.......................................................................... 988898184e3Ssthen 989898184e3Ssthensub not_dynamic { 990898184e3Ssthen my ($self,$value) = @_; 991898184e3Ssthen $self->{__not_dynamic} = $value if @_ == 2; 992898184e3Ssthen return $self->{__not_dynamic}; 993898184e3Ssthen} 994898184e3Ssthen 995898184e3Ssthen#.......................................................................... 996898184e3Ssthen 997898184e3Ssthensub add_formatter_option { # $self->add_formatter_option('key' => 'value'); 998898184e3Ssthen my $self = shift; 999898184e3Ssthen push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; 1000898184e3Ssthen 1001898184e3Ssthen DEBUG > 3 and printf "Formatter switches now: [%s]\n", 1002898184e3Ssthen join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; 1003898184e3Ssthen 1004898184e3Ssthen return; 1005898184e3Ssthen} 1006898184e3Ssthen 1007898184e3Ssthen#......................................................................... 1008898184e3Ssthen 1009898184e3Ssthensub new_translator { # $tr = $self->new_translator($lang); 1010898184e3Ssthen my $self = shift; 1011898184e3Ssthen my $lang = shift; 1012898184e3Ssthen 10130b7734b3Safresh1 local @INC = @INC; 10140b7734b3Safresh1 pop @INC if $INC[-1] eq '.'; 1015898184e3Ssthen my $pack = 'POD2::' . uc($lang); 1016898184e3Ssthen eval "require $pack"; 1017898184e3Ssthen if ( !$@ && $pack->can('new') ) { 1018898184e3Ssthen return $pack->new(); 1019898184e3Ssthen } 1020898184e3Ssthen 1021898184e3Ssthen eval { require POD2::Base }; 1022898184e3Ssthen return if $@; 1023898184e3Ssthen 1024898184e3Ssthen return POD2::Base->new({ lang => $lang }); 1025898184e3Ssthen} 1026898184e3Ssthen 1027898184e3Ssthen#......................................................................... 1028898184e3Ssthen 1029898184e3Ssthensub add_translator { # $self->add_translator($lang); 1030898184e3Ssthen my $self = shift; 1031898184e3Ssthen for my $lang (@_) { 1032898184e3Ssthen my $tr = $self->new_translator($lang); 1033898184e3Ssthen if ( defined $tr ) { 1034898184e3Ssthen push @{ $self->{'translators'} }, $tr; 1035898184e3Ssthen push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs; 1036898184e3Ssthen 1037898184e3Ssthen $self->aside( "translator for '$lang' loaded\n" ); 1038898184e3Ssthen } else { 1039898184e3Ssthen # non-installed or bad translator package 1040898184e3Ssthen $self->warn( "Perldoc cannot load translator package for '$lang': ignored\n" ); 1041898184e3Ssthen } 1042898184e3Ssthen 1043898184e3Ssthen } 1044898184e3Ssthen return; 1045898184e3Ssthen} 1046898184e3Ssthen 1047898184e3Ssthen#.......................................................................... 1048898184e3Ssthen 1049b8851fccSafresh1sub open_fh { 1050b8851fccSafresh1 my ($self, $op, $path) = @_; 1051b8851fccSafresh1 1052b8851fccSafresh1 open my $fh, $op, $path or $self->die("Couldn't open $path: $!"); 1053b8851fccSafresh1 return $fh; 1054b8851fccSafresh1} 1055b8851fccSafresh1 1056b8851fccSafresh1sub set_encoding { 1057b8851fccSafresh1 my ($self, $fh, $encoding) = @_; 1058b8851fccSafresh1 1059b8851fccSafresh1 if ( $encoding =~ /utf-?8/i ) { 1060b8851fccSafresh1 $encoding = ":encoding(UTF-8)"; 1061b8851fccSafresh1 } 1062b8851fccSafresh1 else { 1063b8851fccSafresh1 $encoding = ":encoding($encoding)"; 1064b8851fccSafresh1 } 1065b8851fccSafresh1 1066b8851fccSafresh1 if ( $] < 5.008 ) { 1067b8851fccSafresh1 $self->aside("Your old perl doesn't have proper unicode support."); 1068b8851fccSafresh1 } 1069b8851fccSafresh1 else { 1070b8851fccSafresh1 binmode($fh, $encoding); 1071b8851fccSafresh1 } 1072b8851fccSafresh1 1073b8851fccSafresh1 return $fh; 1074b8851fccSafresh1} 1075b8851fccSafresh1 1076898184e3Ssthensub search_perlvar { 1077898184e3Ssthen my($self, $found_things, $pod) = @_; 1078898184e3Ssthen 1079898184e3Ssthen my $opt = $self->opt_v; 1080898184e3Ssthen 1081898184e3Ssthen if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) { 1082898184e3Ssthen CORE::die( "'$opt' does not look like a Perl variable\n" ); 1083898184e3Ssthen } 1084898184e3Ssthen 1085898184e3Ssthen DEBUG > 2 and print "Search: @$found_things\n"; 1086898184e3Ssthen 1087898184e3Ssthen my $perlvar = shift @$found_things; 1088b8851fccSafresh1 my $fh = $self->open_fh("<", $perlvar); 1089898184e3Ssthen 1090898184e3Ssthen if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ... 1091898184e3Ssthen $opt = '$<I<digits>>'; 1092898184e3Ssthen } 1093898184e3Ssthen my $search_re = quotemeta($opt); 1094898184e3Ssthen 1095898184e3Ssthen DEBUG > 2 and 1096898184e3Ssthen print "Going to perlvar-scan for $search_re in $perlvar\n"; 1097898184e3Ssthen 1098898184e3Ssthen # Skip introduction 1099898184e3Ssthen local $_; 1100b8851fccSafresh1 my $enc; 1101b8851fccSafresh1 while (<$fh>) { 1102b8851fccSafresh1 $enc = $1 if /^=encoding\s+(\S+)/; 1103898184e3Ssthen last if /^=over 8/; 1104898184e3Ssthen } 1105898184e3Ssthen 1106b8851fccSafresh1 $fh = $self->set_encoding($fh, $enc) if $enc; 1107b8851fccSafresh1 1108898184e3Ssthen # Look for our variable 1109898184e3Ssthen my $found = 0; 1110898184e3Ssthen my $inheader = 1; 1111898184e3Ssthen my $inlist = 0; 1112b8851fccSafresh1 while (<$fh>) { 1113898184e3Ssthen last if /^=head2 Error Indicators/; 1114898184e3Ssthen # \b at the end of $` and friends borks things! 1115898184e3Ssthen if ( m/^=item\s+$search_re\s/ ) { 1116898184e3Ssthen $found = 1; 1117898184e3Ssthen } 1118898184e3Ssthen elsif (/^=item/) { 1119898184e3Ssthen last if $found && !$inheader && !$inlist; 1120898184e3Ssthen } 1121898184e3Ssthen elsif (!/^\s+$/) { # not a blank line 1122898184e3Ssthen if ( $found ) { 1123898184e3Ssthen $inheader = 0; # don't accept more =item (unless inlist) 1124898184e3Ssthen } 1125898184e3Ssthen else { 1126898184e3Ssthen @$pod = (); # reset 1127898184e3Ssthen $inheader = 1; # start over 1128898184e3Ssthen next; 1129898184e3Ssthen } 1130898184e3Ssthen } 1131898184e3Ssthen 1132898184e3Ssthen if (/^=over/) { 1133898184e3Ssthen ++$inlist; 1134898184e3Ssthen } 1135898184e3Ssthen elsif (/^=back/) { 1136898184e3Ssthen last if $found && !$inheader && !$inlist; 1137898184e3Ssthen --$inlist; 1138898184e3Ssthen } 1139898184e3Ssthen push @$pod, $_; 1140898184e3Ssthen# ++$found if /^\w/; # found descriptive text 1141898184e3Ssthen } 1142898184e3Ssthen @$pod = () unless $found; 1143898184e3Ssthen if (!@$pod) { 1144898184e3Ssthen CORE::die( "No documentation for perl variable '$opt' found\n" ); 1145898184e3Ssthen } 1146b8851fccSafresh1 close $fh or $self->die( "Can't close $perlvar: $!" ); 1147898184e3Ssthen 1148898184e3Ssthen return; 1149898184e3Ssthen} 1150898184e3Ssthen 1151898184e3Ssthen#.......................................................................... 1152898184e3Ssthen 1153898184e3Ssthensub search_perlop { 1154898184e3Ssthen my ($self,$found_things,$pod) = @_; 1155898184e3Ssthen 1156898184e3Ssthen $self->not_dynamic( 1 ); 1157898184e3Ssthen 1158898184e3Ssthen my $perlop = shift @$found_things; 11596fb12b70Safresh1 # XXX FIXME: getting filehandles should probably be done in a single place 11606fb12b70Safresh1 # especially since we need to support UTF8 or other encoding when dealing 11616fb12b70Safresh1 # with perlop, perlfunc, perlapi, perlfaq[1-9] 1162b8851fccSafresh1 my $fh = $self->open_fh('<', $perlop); 1163898184e3Ssthen 1164898184e3Ssthen my $thing = $self->opt_f; 11656fb12b70Safresh1 11666fb12b70Safresh1 my $previous_line; 11676fb12b70Safresh1 my $push = 0; 11686fb12b70Safresh1 my $seen_item = 0; 11696fb12b70Safresh1 my $skip = 1; 1170898184e3Ssthen 1171b8851fccSafresh1 while( my $line = <$fh> ) { 1172b8851fccSafresh1 $line =~ /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); 11736fb12b70Safresh1 # only start search after we hit the operator section 11746fb12b70Safresh1 if ($line =~ m!^X<operator, regexp>!) { 11756fb12b70Safresh1 $skip = 0; 1176898184e3Ssthen } 1177898184e3Ssthen 11786fb12b70Safresh1 next if $skip; 11796fb12b70Safresh1 11806fb12b70Safresh1 # strategy is to capture the previous line until we get a match on X<$thingy> 11816fb12b70Safresh1 # if the current line contains X<$thingy>, then we push "=over", the previous line, 11826fb12b70Safresh1 # the current line and keep pushing current line until we see a ^X<some-other-thing>, 11836fb12b70Safresh1 # then we chop off final line from @$pod and add =back 11846fb12b70Safresh1 # 11856fb12b70Safresh1 # At that point, Bob's your uncle. 11866fb12b70Safresh1 11876fb12b70Safresh1 if ( $line =~ m!X<+\s*\Q$thing\E\s*>+!) { 11886fb12b70Safresh1 if ( $previous_line ) { 11896fb12b70Safresh1 push @$pod, "=over 8\n\n", $previous_line; 11906fb12b70Safresh1 $previous_line = ""; 11916fb12b70Safresh1 } 11926fb12b70Safresh1 push @$pod, $line; 11936fb12b70Safresh1 $push = 1; 11946fb12b70Safresh1 11956fb12b70Safresh1 } 11966fb12b70Safresh1 elsif ( $push and $line =~ m!^=item\s*.*$! ) { 11976fb12b70Safresh1 $seen_item = 1; 11986fb12b70Safresh1 } 11996fb12b70Safresh1 elsif ( $push and $seen_item and $line =~ m!^X<+\s*[ a-z,?-]+\s*>+!) { 12006fb12b70Safresh1 $push = 0; 12016fb12b70Safresh1 $seen_item = 0; 12026fb12b70Safresh1 last; 12036fb12b70Safresh1 } 12046fb12b70Safresh1 elsif ( $push ) { 12056fb12b70Safresh1 push @$pod, $line; 1206898184e3Ssthen } 1207898184e3Ssthen 12086fb12b70Safresh1 else { 12096fb12b70Safresh1 $previous_line = $line; 1210898184e3Ssthen } 1211898184e3Ssthen 12126fb12b70Safresh1 } #end while 1213898184e3Ssthen 12146fb12b70Safresh1 # we overfilled by 1 line, so pop off final array element if we have any 12156fb12b70Safresh1 if ( scalar @$pod ) { 12166fb12b70Safresh1 pop @$pod; 1217898184e3Ssthen 12186fb12b70Safresh1 # and add the =back 12196fb12b70Safresh1 push @$pod, "\n\n=back\n"; 12206fb12b70Safresh1 DEBUG > 8 and print "PERLOP POD --->" . (join "", @$pod) . "<---\n"; 12216fb12b70Safresh1 } 12226fb12b70Safresh1 else { 12236fb12b70Safresh1 DEBUG > 4 and print "No pod from perlop\n"; 1224898184e3Ssthen } 1225898184e3Ssthen 1226b8851fccSafresh1 close $fh; 1227898184e3Ssthen 1228898184e3Ssthen return; 1229898184e3Ssthen} 1230898184e3Ssthen 1231898184e3Ssthen#.......................................................................... 1232898184e3Ssthen 12336fb12b70Safresh1sub search_perlapi { 1234898184e3Ssthen my($self, $found_things, $pod) = @_; 1235898184e3Ssthen 1236898184e3Ssthen DEBUG > 2 and print "Search: @$found_things\n"; 1237898184e3Ssthen 12386fb12b70Safresh1 my $perlapi = shift @$found_things; 1239b8851fccSafresh1 my $fh = $self->open_fh('<', $perlapi); 1240898184e3Ssthen 12416fb12b70Safresh1 my $search_re = quotemeta($self->opt_a); 1242898184e3Ssthen 1243898184e3Ssthen DEBUG > 2 and 12446fb12b70Safresh1 print "Going to perlapi-scan for $search_re in $perlapi\n"; 1245898184e3Ssthen 1246898184e3Ssthen local $_; 1247898184e3Ssthen 1248898184e3Ssthen # Look for our function 1249898184e3Ssthen my $found = 0; 1250898184e3Ssthen my $inlist = 0; 1251898184e3Ssthen 1252898184e3Ssthen my @related; 1253898184e3Ssthen my $related_re; 1254b8851fccSafresh1 while (<$fh>) { 1255b8851fccSafresh1 /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); 1256b8851fccSafresh1 1257898184e3Ssthen if ( m/^=item\s+$search_re\b/ ) { 1258898184e3Ssthen $found = 1; 1259898184e3Ssthen } 1260898184e3Ssthen elsif (@related > 1 and /^=item/) { 1261898184e3Ssthen $related_re ||= join "|", @related; 1262898184e3Ssthen if (m/^=item\s+(?:$related_re)\b/) { 1263898184e3Ssthen $found = 1; 1264898184e3Ssthen } 1265898184e3Ssthen else { 1266898184e3Ssthen last; 1267898184e3Ssthen } 1268898184e3Ssthen } 1269898184e3Ssthen elsif (/^=item/) { 1270898184e3Ssthen last if $found > 1 and not $inlist; 1271898184e3Ssthen } 1272898184e3Ssthen elsif ($found and /^X<[^>]+>/) { 1273898184e3Ssthen push @related, m/X<([^>]+)>/g; 1274898184e3Ssthen } 1275898184e3Ssthen next unless $found; 1276898184e3Ssthen if (/^=over/) { 1277898184e3Ssthen ++$inlist; 1278898184e3Ssthen } 1279898184e3Ssthen elsif (/^=back/) { 1280898184e3Ssthen last if $found > 1 and not $inlist; 1281898184e3Ssthen --$inlist; 1282898184e3Ssthen } 1283898184e3Ssthen push @$pod, $_; 1284898184e3Ssthen ++$found if /^\w/; # found descriptive text 1285898184e3Ssthen } 1286898184e3Ssthen 1287898184e3Ssthen if (!@$pod) { 12886fb12b70Safresh1 CORE::die( sprintf 12896fb12b70Safresh1 "No documentation for perl api function '%s' found\n", 12906fb12b70Safresh1 $self->opt_a ) 12916fb12b70Safresh1 ; 12926fb12b70Safresh1 } 1293b8851fccSafresh1 close $fh or $self->die( "Can't open $perlapi: $!" ); 12946fb12b70Safresh1 12956fb12b70Safresh1 return; 12966fb12b70Safresh1} 12976fb12b70Safresh1 12986fb12b70Safresh1#.......................................................................... 12996fb12b70Safresh1 13006fb12b70Safresh1sub search_perlfunc { 13016fb12b70Safresh1 my($self, $found_things, $pod) = @_; 13026fb12b70Safresh1 13036fb12b70Safresh1 DEBUG > 2 and print "Search: @$found_things\n"; 13046fb12b70Safresh1 1305b8851fccSafresh1 my $pfunc = shift @$found_things; 1306b8851fccSafresh1 my $fh = $self->open_fh("<", $pfunc); # "Funk is its own reward" 13076fb12b70Safresh1 13086fb12b70Safresh1 # Functions like -r, -e, etc. are listed under `-X'. 13096fb12b70Safresh1 my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) 13106fb12b70Safresh1 ? '(?:I<)?-X' : quotemeta($self->opt_f) ; 13116fb12b70Safresh1 13126fb12b70Safresh1 DEBUG > 2 and 1313b8851fccSafresh1 print "Going to perlfunc-scan for $search_re in $pfunc\n"; 13146fb12b70Safresh1 13156fb12b70Safresh1 my $re = 'Alphabetical Listing of Perl Functions'; 13166fb12b70Safresh1 13176fb12b70Safresh1 # Check available translator or backup to default (english) 13186fb12b70Safresh1 if ( $self->opt_L && defined $self->{'translators'}->[0] ) { 13196fb12b70Safresh1 my $tr = $self->{'translators'}->[0]; 13206fb12b70Safresh1 $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re'); 13216fb12b70Safresh1 if ( $] < 5.008 ) { 13226fb12b70Safresh1 $self->aside("Your old perl doesn't really have proper unicode support."); 13236fb12b70Safresh1 } 13246fb12b70Safresh1 } 13256fb12b70Safresh1 13266fb12b70Safresh1 # Skip introduction 13276fb12b70Safresh1 local $_; 1328b8851fccSafresh1 while (<$fh>) { 1329b8851fccSafresh1 /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); 13309f11ffb7Safresh1 last if /^=head2 (?:$re|Alphabetical Listing of Perl Functions)/; 13316fb12b70Safresh1 } 13326fb12b70Safresh1 13336fb12b70Safresh1 # Look for our function 13346fb12b70Safresh1 my $found = 0; 13356fb12b70Safresh1 my $inlist = 0; 13366fb12b70Safresh1 13376fb12b70Safresh1 my @perlops = qw(m q qq qr qx qw s tr y); 13386fb12b70Safresh1 13396fb12b70Safresh1 my @related; 13406fb12b70Safresh1 my $related_re; 1341b8851fccSafresh1 while (<$fh>) { # "The Mothership Connection is here!" 13426fb12b70Safresh1 last if( grep{ $self->opt_f eq $_ }@perlops ); 13436fb12b70Safresh1 13446fb12b70Safresh1 if ( /^=over/ and not $found ) { 13456fb12b70Safresh1 ++$inlist; 13466fb12b70Safresh1 } 13476fb12b70Safresh1 elsif ( /^=back/ and not $found and $inlist ) { 13486fb12b70Safresh1 --$inlist; 13496fb12b70Safresh1 } 13506fb12b70Safresh1 13516fb12b70Safresh1 13526fb12b70Safresh1 if ( m/^=item\s+$search_re\b/ and $inlist < 2 ) { 13536fb12b70Safresh1 $found = 1; 13546fb12b70Safresh1 } 13556fb12b70Safresh1 elsif (@related > 1 and /^=item/) { 13566fb12b70Safresh1 $related_re ||= join "|", @related; 13576fb12b70Safresh1 if (m/^=item\s+(?:$related_re)\b/) { 13586fb12b70Safresh1 $found = 1; 13596fb12b70Safresh1 } 13606fb12b70Safresh1 else { 13616fb12b70Safresh1 last if $found > 1 and $inlist < 2; 13626fb12b70Safresh1 } 13636fb12b70Safresh1 } 13649f11ffb7Safresh1 elsif (/^=item|^=back/) { 13656fb12b70Safresh1 last if $found > 1 and $inlist < 2; 13666fb12b70Safresh1 } 13676fb12b70Safresh1 elsif ($found and /^X<[^>]+>/) { 13686fb12b70Safresh1 push @related, m/X<([^>]+)>/g; 13696fb12b70Safresh1 } 13706fb12b70Safresh1 next unless $found; 13716fb12b70Safresh1 if (/^=over/) { 13726fb12b70Safresh1 ++$inlist; 13736fb12b70Safresh1 } 13746fb12b70Safresh1 elsif (/^=back/) { 13756fb12b70Safresh1 --$inlist; 13766fb12b70Safresh1 } 13776fb12b70Safresh1 push @$pod, $_; 13786fb12b70Safresh1 ++$found if /^\w/; # found descriptive text 13796fb12b70Safresh1 } 13806fb12b70Safresh1 13816fb12b70Safresh1 if( !@$pod ){ 1382898184e3Ssthen $self->search_perlop( $found_things, $pod ); 1383898184e3Ssthen } 1384898184e3Ssthen 1385898184e3Ssthen if (!@$pod) { 1386898184e3Ssthen CORE::die( sprintf 1387898184e3Ssthen "No documentation for perl function '%s' found\n", 1388898184e3Ssthen $self->opt_f ) 1389898184e3Ssthen ; 1390898184e3Ssthen } 1391b8851fccSafresh1 close $fh or $self->die( "Can't close $pfunc: $!" ); 1392898184e3Ssthen 1393898184e3Ssthen return; 1394898184e3Ssthen} 1395898184e3Ssthen 1396898184e3Ssthen#.......................................................................... 1397898184e3Ssthen 1398898184e3Ssthensub search_perlfaqs { 1399898184e3Ssthen my( $self, $found_things, $pod) = @_; 1400898184e3Ssthen 1401898184e3Ssthen my $found = 0; 1402898184e3Ssthen my %found_in; 1403898184e3Ssthen my $search_key = $self->opt_q; 1404898184e3Ssthen 1405898184e3Ssthen my $rx = eval { qr/$search_key/ } 1406898184e3Ssthen or $self->die( <<EOD ); 1407898184e3SsthenInvalid regular expression '$search_key' given as -q pattern: 1408898184e3Ssthen$@ 1409898184e3SsthenDid you mean \\Q$search_key ? 1410898184e3Ssthen 1411898184e3SsthenEOD 1412898184e3Ssthen 1413898184e3Ssthen local $_; 1414898184e3Ssthen foreach my $file (@$found_things) { 1415898184e3Ssthen $self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/; 1416b8851fccSafresh1 my $fh = $self->open_fh("<", $file); 1417b8851fccSafresh1 while (<$fh>) { 1418b8851fccSafresh1 /^=encoding\s+(\S+)/ && $self->set_encoding($fh, $1); 1419898184e3Ssthen if ( m/^=head2\s+.*(?:$search_key)/i ) { 1420898184e3Ssthen $found = 1; 1421898184e3Ssthen push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++; 1422898184e3Ssthen } 1423898184e3Ssthen elsif (/^=head[12]/) { 1424898184e3Ssthen $found = 0; 1425898184e3Ssthen } 1426898184e3Ssthen next unless $found; 1427898184e3Ssthen push @$pod, $_; 1428898184e3Ssthen } 1429b8851fccSafresh1 close($fh); 1430898184e3Ssthen } 1431898184e3Ssthen CORE::die("No documentation for perl FAQ keyword '$search_key' found\n") 1432898184e3Ssthen unless @$pod; 1433898184e3Ssthen 1434898184e3Ssthen if ( $self->opt_l ) { 1435898184e3Ssthen CORE::die((join "\n", keys %found_in) . "\n"); 1436898184e3Ssthen } 1437898184e3Ssthen return; 1438898184e3Ssthen} 1439898184e3Ssthen 1440898184e3Ssthen 1441898184e3Ssthen#.......................................................................... 1442898184e3Ssthen 1443898184e3Ssthensub render_findings { 1444898184e3Ssthen # Return the filename to open 1445898184e3Ssthen 1446898184e3Ssthen my($self, $found_things) = @_; 1447898184e3Ssthen 1448898184e3Ssthen my $formatter_class = $self->{'formatter_class'} 1449898184e3Ssthen || $self->die( "No formatter class set!?" ); 1450898184e3Ssthen my $formatter = $formatter_class->can('new') 1451898184e3Ssthen ? $formatter_class->new 1452898184e3Ssthen : $formatter_class 1453898184e3Ssthen ; 1454898184e3Ssthen 1455898184e3Ssthen if(! @$found_things) { 1456898184e3Ssthen $self->die( "Nothing found?!" ); 1457898184e3Ssthen # should have been caught before here 1458898184e3Ssthen } elsif(@$found_things > 1) { 1459898184e3Ssthen $self->warn( 1460898184e3Ssthen "Perldoc is only really meant for reading one document at a time.\n", 1461898184e3Ssthen "So these parameters are being ignored: ", 1462898184e3Ssthen join(' ', @$found_things[1 .. $#$found_things] ), 1463898184e3Ssthen "\n" ); 1464898184e3Ssthen } 1465898184e3Ssthen 1466898184e3Ssthen my $file = $found_things->[0]; 1467898184e3Ssthen 1468898184e3Ssthen DEBUG > 3 and printf "Formatter switches now: [%s]\n", 1469898184e3Ssthen join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; 1470898184e3Ssthen 1471898184e3Ssthen # Set formatter options: 1472898184e3Ssthen if( ref $formatter ) { 1473898184e3Ssthen foreach my $f (@{ $self->{'formatter_switches'} || [] }) { 1474898184e3Ssthen my($switch, $value, $silent_fail) = @$f; 1475898184e3Ssthen if( $formatter->can($switch) ) { 1476898184e3Ssthen eval { $formatter->$switch( defined($value) ? $value : () ) }; 1477898184e3Ssthen $self->warn( "Got an error when setting $formatter_class\->$switch:\n$@\n" ) 1478898184e3Ssthen if $@; 1479898184e3Ssthen } else { 1480898184e3Ssthen if( $silent_fail or $switch =~ m/^__/s ) { 1481898184e3Ssthen DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; 1482898184e3Ssthen } else { 1483898184e3Ssthen $self->warn( "$formatter_class doesn't recognize the $switch switch.\n" ); 1484898184e3Ssthen } 1485898184e3Ssthen } 1486898184e3Ssthen } 1487898184e3Ssthen } 1488898184e3Ssthen 1489898184e3Ssthen $self->{'output_is_binary'} = 1490898184e3Ssthen $formatter->can('write_with_binmode') && $formatter->write_with_binmode; 1491898184e3Ssthen 1492898184e3Ssthen if( $self->{podnames} and exists $self->{podnames}{$file} and 1493898184e3Ssthen $formatter->can('name') ) { 1494898184e3Ssthen $formatter->name($self->{podnames}{$file}); 1495898184e3Ssthen } 1496898184e3Ssthen 1497898184e3Ssthen my ($out_fh, $out) = $self->new_output_file( 1498898184e3Ssthen ( $formatter->can('output_extension') && $formatter->output_extension ) 1499898184e3Ssthen || undef, 1500898184e3Ssthen $self->useful_filename_bit, 1501898184e3Ssthen ); 1502898184e3Ssthen 1503898184e3Ssthen # Now, finally, do the formatting! 1504898184e3Ssthen { 1505898184e3Ssthen local $^W = $^W; 1506898184e3Ssthen if(DEBUG() or $self->opt_D) { 1507898184e3Ssthen # feh, let 'em see it 1508898184e3Ssthen } else { 1509898184e3Ssthen $^W = 0; 1510898184e3Ssthen # The average user just has no reason to be seeing 1511898184e3Ssthen # $^W-suppressible warnings from the formatting! 1512898184e3Ssthen } 1513898184e3Ssthen 1514898184e3Ssthen eval { $formatter->parse_from_file( $file, $out_fh ) }; 1515898184e3Ssthen } 1516898184e3Ssthen 1517898184e3Ssthen $self->warn( "Error while formatting with $formatter_class:\n $@\n" ) if $@; 1518898184e3Ssthen DEBUG > 2 and print "Back from formatting with $formatter_class\n"; 1519898184e3Ssthen 1520898184e3Ssthen close $out_fh 1521898184e3Ssthen or $self->warn( "Can't close $out: $!\n(Did $formatter already close it?)" ); 1522898184e3Ssthen sleep 0; sleep 0; sleep 0; 1523898184e3Ssthen # Give the system a few timeslices to meditate on the fact 1524898184e3Ssthen # that the output file does in fact exist and is closed. 1525898184e3Ssthen 1526898184e3Ssthen $self->unlink_if_temp_file($file); 1527898184e3Ssthen 1528898184e3Ssthen unless( -s $out ) { 1529898184e3Ssthen if( $formatter->can( 'if_zero_length' ) ) { 1530898184e3Ssthen # Basically this is just a hook for Pod::Simple::Checker; since 1531898184e3Ssthen # what other class could /happily/ format an input file with Pod 1532898184e3Ssthen # as a 0-length output file? 1533898184e3Ssthen $formatter->if_zero_length( $file, $out, $out_fh ); 1534898184e3Ssthen } else { 1535898184e3Ssthen $self->warn( "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" ); 1536898184e3Ssthen } 1537898184e3Ssthen } 1538898184e3Ssthen 1539898184e3Ssthen DEBUG and print "Finished writing to $out.\n"; 1540898184e3Ssthen return($out, $formatter) if wantarray; 1541898184e3Ssthen return $out; 1542898184e3Ssthen} 1543898184e3Ssthen 1544898184e3Ssthen#.......................................................................... 1545898184e3Ssthen 1546898184e3Ssthensub unlink_if_temp_file { 1547898184e3Ssthen # Unlink the specified file IFF it's in the list of temp files. 1548898184e3Ssthen # Really only used in the case of -f / -q things when we can 1549898184e3Ssthen # throw away the dynamically generated source pod file once 1550898184e3Ssthen # we've formatted it. 1551898184e3Ssthen # 1552898184e3Ssthen my($self, $file) = @_; 1553898184e3Ssthen return unless defined $file and length $file; 1554898184e3Ssthen 1555898184e3Ssthen my $temp_file_list = $self->{'temp_file_list'} || return; 1556898184e3Ssthen if(grep $_ eq $file, @$temp_file_list) { 1557898184e3Ssthen $self->aside("Unlinking $file\n"); 1558898184e3Ssthen unlink($file) or $self->warn( "Odd, couldn't unlink $file: $!" ); 1559898184e3Ssthen } else { 1560898184e3Ssthen DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; 1561898184e3Ssthen } 1562898184e3Ssthen return; 1563898184e3Ssthen} 1564898184e3Ssthen 1565898184e3Ssthen#.......................................................................... 1566898184e3Ssthen 1567898184e3Ssthen 1568898184e3Ssthensub after_rendering { 1569898184e3Ssthen my $self = $_[0]; 1570898184e3Ssthen $self->after_rendering_VMS if $self->is_vms; 1571898184e3Ssthen $self->after_rendering_MSWin32 if $self->is_mswin32; 1572898184e3Ssthen $self->after_rendering_Dos if $self->is_dos; 1573898184e3Ssthen $self->after_rendering_OS2 if $self->is_os2; 1574898184e3Ssthen return; 1575898184e3Ssthen} 1576898184e3Ssthen 1577898184e3Ssthensub after_rendering_VMS { return } 1578898184e3Ssthensub after_rendering_Dos { return } 1579898184e3Ssthensub after_rendering_OS2 { return } 1580898184e3Ssthensub after_rendering_MSWin32 { return } 1581898184e3Ssthen 1582898184e3Ssthen#.......................................................................... 1583898184e3Ssthen# : : : : : : : : : 1584898184e3Ssthen#.......................................................................... 1585898184e3Ssthen 1586898184e3Ssthensub minus_f_nocase { # i.e., do like -f, but without regard to case 1587898184e3Ssthen 1588898184e3Ssthen my($self, $dir, $file) = @_; 1589898184e3Ssthen my $path = catfile($dir,$file); 1590898184e3Ssthen return $path if -f $path and -r _; 1591898184e3Ssthen 1592898184e3Ssthen if(!$self->opt_i 1593898184e3Ssthen or $self->is_vms or $self->is_mswin32 159491f110e0Safresh1 or $self->is_dos or $self->is_os2 1595898184e3Ssthen ) { 1596898184e3Ssthen # On a case-forgiving file system, or if case is important, 1597898184e3Ssthen # that is it, all we can do. 1598898184e3Ssthen $self->warn( "Ignored $path: unreadable\n" ) if -f _; 1599898184e3Ssthen return ''; 1600898184e3Ssthen } 1601898184e3Ssthen 1602898184e3Ssthen local *DIR; 1603898184e3Ssthen my @p = ($dir); 1604898184e3Ssthen my($p,$cip); 1605898184e3Ssthen foreach $p (splitdir $file){ 1606898184e3Ssthen my $try = catfile @p, $p; 1607898184e3Ssthen $self->aside("Scrutinizing $try...\n"); 1608898184e3Ssthen stat $try; 1609898184e3Ssthen if (-d _) { 1610898184e3Ssthen push @p, $p; 1611898184e3Ssthen if ( $p eq $self->{'target'} ) { 1612898184e3Ssthen my $tmp_path = catfile @p; 1613898184e3Ssthen my $path_f = 0; 1614898184e3Ssthen for (@{ $self->{'found'} }) { 1615898184e3Ssthen $path_f = 1 if $_ eq $tmp_path; 1616898184e3Ssthen } 1617898184e3Ssthen push (@{ $self->{'found'} }, $tmp_path) unless $path_f; 1618898184e3Ssthen $self->aside( "Found as $tmp_path but directory\n" ); 1619898184e3Ssthen } 1620898184e3Ssthen } 1621898184e3Ssthen elsif (-f _ && -r _ && lc($try) eq lc($path)) { 1622898184e3Ssthen return $try; 1623898184e3Ssthen } 1624898184e3Ssthen elsif (-f _) { 1625898184e3Ssthen $self->warn( "Ignored $try: unreadable or file/dir mismatch\n" ); 1626898184e3Ssthen } 1627898184e3Ssthen elsif (-d catdir(@p)) { # at least we see the containing directory! 1628898184e3Ssthen my $found = 0; 1629898184e3Ssthen my $lcp = lc $p; 1630898184e3Ssthen my $p_dirspec = catdir(@p); 1631898184e3Ssthen opendir DIR, $p_dirspec or $self->die( "opendir $p_dirspec: $!" ); 1632898184e3Ssthen while(defined( $cip = readdir(DIR) )) { 1633898184e3Ssthen if (lc $cip eq $lcp){ 1634898184e3Ssthen $found++; 1635898184e3Ssthen last; # XXX stop at the first? what if there's others? 1636898184e3Ssthen } 1637898184e3Ssthen } 1638898184e3Ssthen closedir DIR or $self->die( "closedir $p_dirspec: $!" ); 1639898184e3Ssthen return "" unless $found; 1640898184e3Ssthen 1641898184e3Ssthen push @p, $cip; 1642898184e3Ssthen my $p_filespec = catfile(@p); 1643898184e3Ssthen return $p_filespec if -f $p_filespec and -r _; 1644898184e3Ssthen $self->warn( "Ignored $p_filespec: unreadable\n" ) if -f _; 1645898184e3Ssthen } 1646898184e3Ssthen } 1647898184e3Ssthen return ""; 1648898184e3Ssthen} 1649898184e3Ssthen 1650898184e3Ssthen#.......................................................................... 1651898184e3Ssthen 1652898184e3Ssthensub pagers_guessing { 1653b8851fccSafresh1 # TODO: This whole subroutine needs to be rewritten. It's semi-insane 1654b8851fccSafresh1 # right now. 1655b8851fccSafresh1 1656898184e3Ssthen my $self = shift; 1657898184e3Ssthen 1658898184e3Ssthen my @pagers; 1659898184e3Ssthen push @pagers, $self->pagers; 1660898184e3Ssthen $self->{'pagers'} = \@pagers; 1661898184e3Ssthen 1662898184e3Ssthen if ($self->is_mswin32) { 1663898184e3Ssthen push @pagers, qw( more< less notepad ); 1664898184e3Ssthen unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; 1665898184e3Ssthen } 1666898184e3Ssthen elsif ($self->is_vms) { 1667898184e3Ssthen push @pagers, qw( most more less type/page ); 1668898184e3Ssthen } 1669898184e3Ssthen elsif ($self->is_dos) { 1670898184e3Ssthen push @pagers, qw( less.exe more.com< ); 1671898184e3Ssthen unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; 1672898184e3Ssthen } 1673b8851fccSafresh1 elsif ( $self->is_amigaos) { 1674b8851fccSafresh1 push @pagers, qw( /SYS/Utilities/MultiView /SYS/Utilities/More /C/TYPE ); 1675b8851fccSafresh1 unshift @pagers, "$ENV{PAGER}" if $ENV{PAGER}; 1676b8851fccSafresh1 } 1677898184e3Ssthen else { 1678898184e3Ssthen if ($self->is_os2) { 1679898184e3Ssthen unshift @pagers, 'less', 'cmd /c more <'; 1680898184e3Ssthen } 1681898184e3Ssthen push @pagers, qw( more less pg view cat ); 1682898184e3Ssthen unshift @pagers, "$ENV{PAGER} <" if $ENV{PAGER}; 1683898184e3Ssthen } 1684898184e3Ssthen 1685898184e3Ssthen if ($self->is_cygwin) { 1686898184e3Ssthen if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) { 1687898184e3Ssthen unshift @pagers, '/usr/bin/less -isrR'; 1688898184e3Ssthen unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; 1689898184e3Ssthen } 1690898184e3Ssthen } 1691898184e3Ssthen 16926fb12b70Safresh1 if ( $self->opt_m ) { 16936fb12b70Safresh1 unshift @pagers, "$ENV{PERLDOC_SRC_PAGER}" if $ENV{PERLDOC_SRC_PAGER} 16946fb12b70Safresh1 } 16956fb12b70Safresh1 else { 1696b8851fccSafresh1 unshift @pagers, "$ENV{MANPAGER} <" if $ENV{MANPAGER}; 169791f110e0Safresh1 unshift @pagers, "$ENV{PERLDOC_PAGER} <" if $ENV{PERLDOC_PAGER}; 16986fb12b70Safresh1 } 16996fb12b70Safresh1 17009f11ffb7Safresh1 $self->aside("Pagers: ", (join ", ", @pagers)); 1701898184e3Ssthen 1702898184e3Ssthen return; 1703898184e3Ssthen} 1704898184e3Ssthen 1705898184e3Ssthen#.......................................................................... 1706898184e3Ssthen 1707898184e3Ssthensub page_module_file { 1708898184e3Ssthen my($self, @found) = @_; 1709898184e3Ssthen 1710898184e3Ssthen # Security note: 1711898184e3Ssthen # Don't ever just pass this off to anything like MSWin's "start.exe", 1712898184e3Ssthen # since we might be calling on a .pl file, and we wouldn't want that 1713898184e3Ssthen # to actually /execute/ the file that we just want to page thru! 1714898184e3Ssthen # Also a consideration if one were to use a web browser as a pager; 1715898184e3Ssthen # doing so could trigger the browser's MIME mapping for whatever 1716898184e3Ssthen # it thinks .pm/.pl/whatever is. Probably just a (useless and 1717898184e3Ssthen # annoying) "Save as..." dialog, but potentially executing the file 1718898184e3Ssthen # in question -- particularly in the case of MSIE and it's, ahem, 1719898184e3Ssthen # occasionally hazy distinction between OS-local extension 1720898184e3Ssthen # associations, and browser-specific MIME mappings. 1721898184e3Ssthen 1722898184e3Ssthen if(@found > 1) { 1723898184e3Ssthen $self->warn( 1724898184e3Ssthen "Perldoc is only really meant for reading one document at a time.\n" . 1725898184e3Ssthen "So these files are being ignored: " . 1726898184e3Ssthen join(' ', @found[1 .. $#found] ) . 1727898184e3Ssthen "\n" ) 1728898184e3Ssthen } 1729898184e3Ssthen 1730898184e3Ssthen return $self->page($found[0], $self->{'output_to_stdout'}, $self->pagers); 1731898184e3Ssthen 1732898184e3Ssthen} 1733898184e3Ssthen 1734898184e3Ssthen#.......................................................................... 1735898184e3Ssthen 1736898184e3Ssthensub check_file { 1737898184e3Ssthen my($self, $dir, $file) = @_; 1738898184e3Ssthen 1739898184e3Ssthen unless( ref $self ) { 1740898184e3Ssthen # Should never get called: 1741898184e3Ssthen $Carp::Verbose = 1; 1742898184e3Ssthen require Carp; 1743898184e3Ssthen Carp::croak( join '', 1744898184e3Ssthen "Crazy ", __PACKAGE__, " error:\n", 1745898184e3Ssthen "check_file must be an object_method!\n", 1746898184e3Ssthen "Aborting" 1747898184e3Ssthen ); 1748898184e3Ssthen } 1749898184e3Ssthen 1750898184e3Ssthen if(length $dir and not -d $dir) { 1751898184e3Ssthen DEBUG > 3 and print " No dir $dir -- skipping.\n"; 1752898184e3Ssthen return ""; 1753898184e3Ssthen } 1754898184e3Ssthen 1755898184e3Ssthen my $path = $self->minus_f_nocase($dir,$file); 1756898184e3Ssthen if( length $path and ($self->opt_m ? $self->isprintable($path) 1757898184e3Ssthen : $self->containspod($path)) ) { 1758898184e3Ssthen DEBUG > 3 and print 1759898184e3Ssthen " The file $path indeed looks promising!\n"; 1760898184e3Ssthen return $path; 1761898184e3Ssthen } 1762898184e3Ssthen DEBUG > 3 and print " No good: $file in $dir\n"; 1763898184e3Ssthen 1764898184e3Ssthen return ""; 1765898184e3Ssthen} 1766898184e3Ssthen 1767898184e3Ssthensub isprintable { 1768898184e3Ssthen my($self, $file, $readit) = @_; 1769898184e3Ssthen my $size= 1024; 1770898184e3Ssthen my $maxunprintfrac= 0.2; # tolerate some unprintables for UTF-8 comments etc. 1771898184e3Ssthen 1772898184e3Ssthen return 1 if !$readit && $file =~ /\.(?:pl|pm|pod|cmd|com|bat)\z/i; 1773898184e3Ssthen 1774898184e3Ssthen my $data; 1775898184e3Ssthen local($_); 1776b8851fccSafresh1 my $fh = $self->open_fh("<", $file); 1777b8851fccSafresh1 read $fh, $data, $size; 1778b8851fccSafresh1 close $fh; 1779898184e3Ssthen $size= length($data); 1780898184e3Ssthen $data =~ tr/\x09-\x0D\x20-\x7E//d; 1781898184e3Ssthen return length($data) <= $size*$maxunprintfrac; 1782898184e3Ssthen} 1783898184e3Ssthen 1784898184e3Ssthen#.......................................................................... 1785898184e3Ssthen 1786898184e3Ssthensub containspod { 1787898184e3Ssthen my($self, $file, $readit) = @_; 1788898184e3Ssthen return 1 if !$readit && $file =~ /\.pod\z/i; 1789898184e3Ssthen 1790898184e3Ssthen 1791898184e3Ssthen # Under cygwin the /usr/bin/perl is legal executable, but 1792898184e3Ssthen # you cannot open a file with that name. It must be spelled 1793898184e3Ssthen # out as "/usr/bin/perl.exe". 1794898184e3Ssthen # 1795898184e3Ssthen # The following if-case under cygwin prevents error 1796898184e3Ssthen # 1797898184e3Ssthen # $ perldoc perl 1798898184e3Ssthen # Cannot open /usr/bin/perl: no such file or directory 1799898184e3Ssthen # 1800898184e3Ssthen # This would work though 1801898184e3Ssthen # 1802898184e3Ssthen # $ perldoc perl.pod 1803898184e3Ssthen 1804898184e3Ssthen if ( $self->is_cygwin and -x $file and -f "$file.exe" ) 1805898184e3Ssthen { 1806898184e3Ssthen $self->warn( "Cygwin $file.exe search skipped\n" ) if DEBUG or $self->opt_D; 1807898184e3Ssthen return 0; 1808898184e3Ssthen } 1809898184e3Ssthen 1810898184e3Ssthen local($_); 1811b8851fccSafresh1 my $fh = $self->open_fh("<", $file); 1812b8851fccSafresh1 while (<$fh>) { 1813898184e3Ssthen if (/^=head/) { 1814b8851fccSafresh1 close($fh) or $self->die( "Can't close $file: $!" ); 1815898184e3Ssthen return 1; 1816898184e3Ssthen } 1817898184e3Ssthen } 1818b8851fccSafresh1 close($fh) or $self->die( "Can't close $file: $!" ); 1819898184e3Ssthen return 0; 1820898184e3Ssthen} 1821898184e3Ssthen 1822898184e3Ssthen#.......................................................................... 1823898184e3Ssthen 18246fb12b70Safresh1sub maybe_extend_searchpath { 1825898184e3Ssthen my $self = shift; 1826898184e3Ssthen 1827898184e3Ssthen # Does this look like a module or extension directory? 1828898184e3Ssthen 1829898184e3Ssthen if (-f "Makefile.PL" || -f "Build.PL") { 1830898184e3Ssthen 18316fb12b70Safresh1 push @{$self->{search_path} }, '.','lib'; 1832898184e3Ssthen 1833898184e3Ssthen # don't add if superuser 1834898184e3Ssthen if ($< && $> && -d "blib") { # don't be looking too hard now! 18356fb12b70Safresh1 push @{ $self->{search_path} }, 'blib'; 1836898184e3Ssthen $self->warn( $@ ) if $@ && $self->opt_D; 1837898184e3Ssthen } 1838898184e3Ssthen } 1839898184e3Ssthen 1840898184e3Ssthen return; 1841898184e3Ssthen} 1842898184e3Ssthen 1843898184e3Ssthen#.......................................................................... 1844898184e3Ssthen 1845898184e3Ssthensub new_output_file { 1846898184e3Ssthen my $self = shift; 1847898184e3Ssthen my $outspec = $self->opt_d; # Yes, -d overrides all else! 1848898184e3Ssthen # So don't call this twice per format-job! 1849898184e3Ssthen 1850898184e3Ssthen return $self->new_tempfile(@_) unless defined $outspec and length $outspec; 1851898184e3Ssthen 1852898184e3Ssthen # Otherwise open a write-handle on opt_d!f 1853898184e3Ssthen 1854898184e3Ssthen DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; 1855b8851fccSafresh1 my $fh = $self->open_fh(">", $outspec); 1856898184e3Ssthen 1857898184e3Ssthen DEBUG > 3 and print "Successfully opened $outspec\n"; 1858898184e3Ssthen binmode($fh) if $self->{'output_is_binary'}; 1859898184e3Ssthen return($fh, $outspec); 1860898184e3Ssthen} 1861898184e3Ssthen 1862898184e3Ssthen#.......................................................................... 1863898184e3Ssthen 1864898184e3Ssthensub useful_filename_bit { 1865898184e3Ssthen # This tries to provide a meaningful bit of text to do with the query, 1866898184e3Ssthen # such as can be used in naming the file -- since if we're going to be 1867898184e3Ssthen # opening windows on temp files (as a "pager" may well do!) then it's 1868898184e3Ssthen # better if the temp file's name (which may well be used as the window 1869898184e3Ssthen # title) isn't ALL just random garbage! 1870898184e3Ssthen # In other words "perldoc_LWPSimple_2371981429" is a better temp file 1871898184e3Ssthen # name than "perldoc_2371981429". So this routine is what tries to 1872898184e3Ssthen # provide the "LWPSimple" bit. 1873898184e3Ssthen # 1874898184e3Ssthen my $self = shift; 1875898184e3Ssthen my $pages = $self->{'pages'} || return undef; 1876898184e3Ssthen return undef unless @$pages; 1877898184e3Ssthen 1878898184e3Ssthen my $chunk = $pages->[0]; 1879898184e3Ssthen return undef unless defined $chunk; 1880898184e3Ssthen $chunk =~ s/:://g; 1881898184e3Ssthen $chunk =~ s/\.\w+$//g; # strip any extension 1882898184e3Ssthen if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file 1883898184e3Ssthen $chunk = $1; 1884898184e3Ssthen } else { 1885898184e3Ssthen return undef; 1886898184e3Ssthen } 1887898184e3Ssthen $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things! 1888898184e3Ssthen $chunk = substr($chunk, -10) if length($chunk) > 10; 1889898184e3Ssthen return $chunk; 1890898184e3Ssthen} 1891898184e3Ssthen 1892898184e3Ssthen#.......................................................................... 1893898184e3Ssthen 1894898184e3Ssthensub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) 1895898184e3Ssthen my $self = shift; 1896898184e3Ssthen 1897898184e3Ssthen ++$Temp_Files_Created; 1898898184e3Ssthen 1899898184e3Ssthen require File::Temp; 1900898184e3Ssthen return File::Temp::tempfile(UNLINK => 1); 1901898184e3Ssthen} 1902898184e3Ssthen 1903898184e3Ssthen#.......................................................................... 1904898184e3Ssthen 1905898184e3Ssthensub page { # apply a pager to the output file 1906898184e3Ssthen my ($self, $output, $output_to_stdout, @pagers) = @_; 1907898184e3Ssthen if ($output_to_stdout) { 1908898184e3Ssthen $self->aside("Sending unpaged output to STDOUT.\n"); 1909b8851fccSafresh1 my $fh = $self->open_fh("<", $output); 1910898184e3Ssthen local $_; 1911b8851fccSafresh1 while (<$fh>) { 1912898184e3Ssthen print or $self->die( "Can't print to stdout: $!" ); 1913898184e3Ssthen } 1914b8851fccSafresh1 close $fh or $self->die( "Can't close while $output: $!" ); 1915898184e3Ssthen $self->unlink_if_temp_file($output); 1916898184e3Ssthen } else { 1917898184e3Ssthen # On VMS, quoting prevents logical expansion, and temp files with no 1918898184e3Ssthen # extension get the wrong default extension (such as .LIS for TYPE) 1919898184e3Ssthen 1920898184e3Ssthen $output = VMS::Filespec::rmsexpand($output, '.') if $self->is_vms; 1921898184e3Ssthen 1922898184e3Ssthen $output =~ s{/}{\\}g if $self->is_mswin32 || $self->is_dos; 1923898184e3Ssthen # Altho "/" under MSWin is in theory good as a pathsep, 1924898184e3Ssthen # many many corners of the OS don't like it. So we 1925898184e3Ssthen # have to force it to be "\" to make everyone happy. 1926898184e3Ssthen 1927b8851fccSafresh1 # if we are on an amiga convert unix path to an amiga one 1928b8851fccSafresh1 $output =~ s/^\/(.*)\/(.*)/$1:$2/ if $self->is_amigaos; 1929b8851fccSafresh1 1930898184e3Ssthen foreach my $pager (@pagers) { 1931898184e3Ssthen $self->aside("About to try calling $pager $output\n"); 1932898184e3Ssthen if ($self->is_vms) { 1933898184e3Ssthen last if system("$pager $output") == 0; 1934b8851fccSafresh1 } elsif($self->is_amigaos) { 1935b8851fccSafresh1 last if system($pager, $output) == 0; 1936898184e3Ssthen } else { 1937898184e3Ssthen last if system("$pager \"$output\"") == 0; 1938898184e3Ssthen } 1939898184e3Ssthen } 1940898184e3Ssthen } 1941898184e3Ssthen return; 1942898184e3Ssthen} 1943898184e3Ssthen 1944898184e3Ssthen#.......................................................................... 1945898184e3Ssthen 1946898184e3Ssthensub searchfor { 1947898184e3Ssthen my($self, $recurse,$s,@dirs) = @_; 1948898184e3Ssthen $s =~ s!::!/!g; 1949898184e3Ssthen $s = VMS::Filespec::unixify($s) if $self->is_vms; 1950898184e3Ssthen return $s if -f $s && $self->containspod($s); 1951898184e3Ssthen $self->aside( "Looking for $s in @dirs\n" ); 1952898184e3Ssthen my $ret; 1953898184e3Ssthen my $i; 1954898184e3Ssthen my $dir; 1955898184e3Ssthen $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename? 1956898184e3Ssthen for ($i=0; $i<@dirs; $i++) { 1957898184e3Ssthen $dir = $dirs[$i]; 1958898184e3Ssthen next unless -d $dir; 1959898184e3Ssthen ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $self->is_vms; 1960898184e3Ssthen if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) 1961898184e3Ssthen or ( $ret = $self->check_file($dir,"$s.pm")) 1962898184e3Ssthen or ( $ret = $self->check_file($dir,$s)) 1963898184e3Ssthen or ( $self->is_vms and 1964898184e3Ssthen $ret = $self->check_file($dir,"$s.com")) 1965898184e3Ssthen or ( $self->is_os2 and 1966898184e3Ssthen $ret = $self->check_file($dir,"$s.cmd")) 1967898184e3Ssthen or ( ($self->is_mswin32 or $self->is_dos or $self->is_os2) and 1968898184e3Ssthen $ret = $self->check_file($dir,"$s.bat")) 1969898184e3Ssthen or ( $ret = $self->check_file("$dir/pod","$s.pod")) 1970898184e3Ssthen or ( $ret = $self->check_file("$dir/pod",$s)) 1971898184e3Ssthen or ( $ret = $self->check_file("$dir/pods","$s.pod")) 1972898184e3Ssthen or ( $ret = $self->check_file("$dir/pods",$s)) 1973898184e3Ssthen ) { 1974898184e3Ssthen DEBUG > 1 and print " Found $ret\n"; 1975898184e3Ssthen return $ret; 1976898184e3Ssthen } 1977898184e3Ssthen 1978898184e3Ssthen if ($recurse) { 1979898184e3Ssthen opendir(D,$dir) or $self->die( "Can't opendir $dir: $!" ); 1980898184e3Ssthen my @newdirs = map catfile($dir, $_), grep { 1981898184e3Ssthen not /^\.\.?\z/s and 1982898184e3Ssthen not /^auto\z/s and # save time! don't search auto dirs 1983898184e3Ssthen -d catfile($dir, $_) 1984898184e3Ssthen } readdir D; 1985898184e3Ssthen closedir(D) or $self->die( "Can't closedir $dir: $!" ); 1986898184e3Ssthen next unless @newdirs; 1987898184e3Ssthen # what a wicked map! 1988898184e3Ssthen @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $self->is_vms; 1989898184e3Ssthen $self->aside( "Also looking in @newdirs\n" ); 1990898184e3Ssthen push(@dirs,@newdirs); 1991898184e3Ssthen } 1992898184e3Ssthen } 1993898184e3Ssthen return (); 1994898184e3Ssthen} 1995898184e3Ssthen 1996898184e3Ssthen#.......................................................................... 1997898184e3Ssthen{ 1998898184e3Ssthen my $already_asserted; 1999898184e3Ssthen sub assert_closing_stdout { 2000898184e3Ssthen my $self = shift; 2001898184e3Ssthen 2002898184e3Ssthen return if $already_asserted; 2003898184e3Ssthen 2004898184e3Ssthen eval q~ END { close(STDOUT) || CORE::die "Can't close STDOUT: $!" } ~; 2005898184e3Ssthen # What for? to let the pager know that nothing more will come? 2006898184e3Ssthen 2007898184e3Ssthen $self->die( $@ ) if $@; 2008898184e3Ssthen $already_asserted = 1; 2009898184e3Ssthen return; 2010898184e3Ssthen } 2011898184e3Ssthen} 2012898184e3Ssthen 2013898184e3Ssthen#.......................................................................... 2014898184e3Ssthen 2015898184e3Ssthensub tweak_found_pathnames { 2016898184e3Ssthen my($self, $found) = @_; 2017898184e3Ssthen if ($self->is_mswin32) { 2018898184e3Ssthen foreach (@$found) { s,/,\\,g } 2019898184e3Ssthen } 2020898184e3Ssthen foreach (@$found) { s,',\\',g } # RT 37347 2021898184e3Ssthen return; 2022898184e3Ssthen} 2023898184e3Ssthen 2024898184e3Ssthen#.......................................................................... 2025898184e3Ssthen# : : : : : : : : : 2026898184e3Ssthen#.......................................................................... 2027898184e3Ssthen 2028898184e3Ssthensub am_taint_checking { 2029898184e3Ssthen my $self = shift; 2030898184e3Ssthen $self->die( "NO ENVIRONMENT?!?!" ) unless keys %ENV; # reset iterator along the way 2031898184e3Ssthen my($k,$v) = each %ENV; 2032898184e3Ssthen return is_tainted($v); 2033898184e3Ssthen} 2034898184e3Ssthen 2035898184e3Ssthen#.......................................................................... 2036898184e3Ssthen 2037898184e3Ssthensub is_tainted { # just a function 2038898184e3Ssthen my $arg = shift; 2039898184e3Ssthen my $nada = substr($arg, 0, 0); # zero-length! 2040898184e3Ssthen local $@; # preserve the caller's version of $@ 2041898184e3Ssthen eval { eval "# $nada" }; 2042898184e3Ssthen return length($@) != 0; 2043898184e3Ssthen} 2044898184e3Ssthen 2045898184e3Ssthen#.......................................................................... 2046898184e3Ssthen 2047898184e3Ssthensub drop_privs_maybe { 2048898184e3Ssthen my $self = shift; 2049898184e3Ssthen 20506fb12b70Safresh1 DEBUG and print "Attempting to drop privs...\n"; 20516fb12b70Safresh1 2052898184e3Ssthen # Attempt to drop privs if we should be tainting and aren't 2053898184e3Ssthen if (!( $self->is_vms || $self->is_mswin32 || $self->is_dos 2054898184e3Ssthen || $self->is_os2 2055898184e3Ssthen ) 2056898184e3Ssthen && ($> == 0 || $< == 0) 2057898184e3Ssthen && !$self->am_taint_checking() 2058898184e3Ssthen ) { 2059898184e3Ssthen my $id = eval { getpwnam("nobody") }; 2060898184e3Ssthen $id = eval { getpwnam("nouser") } unless defined $id; 2061898184e3Ssthen $id = -2 unless defined $id; 2062898184e3Ssthen # 2063898184e3Ssthen # According to Stevens' APUE and various 2064898184e3Ssthen # (BSD, Solaris, HP-UX) man pages, setting 2065898184e3Ssthen # the real uid first and effective uid second 2066898184e3Ssthen # is the way to go if one wants to drop privileges, 2067898184e3Ssthen # because if one changes into an effective uid of 2068898184e3Ssthen # non-zero, one cannot change the real uid any more. 2069898184e3Ssthen # 2070898184e3Ssthen # Actually, it gets even messier. There is 2071898184e3Ssthen # a third uid, called the saved uid, and as 2072898184e3Ssthen # long as that is zero, one can get back to 2073898184e3Ssthen # uid of zero. Setting the real-effective *twice* 2074898184e3Ssthen # helps in *most* systems (FreeBSD and Solaris) 2075898184e3Ssthen # but apparently in HP-UX even this doesn't help: 2076898184e3Ssthen # the saved uid stays zero (apparently the only way 2077898184e3Ssthen # in HP-UX to change saved uid is to call setuid() 2078898184e3Ssthen # when the effective uid is zero). 2079898184e3Ssthen # 2080898184e3Ssthen eval { 2081898184e3Ssthen $< = $id; # real uid 2082898184e3Ssthen $> = $id; # effective uid 2083898184e3Ssthen $< = $id; # real uid 2084898184e3Ssthen $> = $id; # effective uid 2085898184e3Ssthen }; 2086898184e3Ssthen if( !$@ && $< && $> ) { 2087898184e3Ssthen DEBUG and print "OK, I dropped privileges.\n"; 2088898184e3Ssthen } elsif( $self->opt_U ) { 2089898184e3Ssthen DEBUG and print "Couldn't drop privileges, but in -U mode, so feh." 2090898184e3Ssthen } else { 2091898184e3Ssthen DEBUG and print "Hm, couldn't drop privileges. Ah well.\n"; 2092898184e3Ssthen # We used to die here; but that seemed pointless. 2093898184e3Ssthen } 2094898184e3Ssthen } 2095898184e3Ssthen return; 2096898184e3Ssthen} 2097898184e3Ssthen 2098898184e3Ssthen#.......................................................................... 2099898184e3Ssthen 2100898184e3Ssthen1; 2101898184e3Ssthen 2102898184e3Ssthen__END__ 2103898184e3Ssthen 2104898184e3Ssthen=head1 NAME 2105898184e3Ssthen 2106898184e3SsthenPod::Perldoc - Look up Perl documentation in Pod format. 2107898184e3Ssthen 2108898184e3Ssthen=head1 SYNOPSIS 2109898184e3Ssthen 2110898184e3Ssthen use Pod::Perldoc (); 2111898184e3Ssthen 2112898184e3Ssthen Pod::Perldoc->run(); 2113898184e3Ssthen 2114898184e3Ssthen=head1 DESCRIPTION 2115898184e3Ssthen 2116898184e3SsthenThe guts of L<perldoc> utility. 2117898184e3Ssthen 2118898184e3Ssthen=head1 SEE ALSO 2119898184e3Ssthen 2120898184e3SsthenL<perldoc> 2121898184e3Ssthen 2122898184e3Ssthen=head1 COPYRIGHT AND DISCLAIMERS 2123898184e3Ssthen 2124898184e3SsthenCopyright (c) 2002-2007 Sean M. Burke. 2125898184e3Ssthen 2126898184e3SsthenThis library is free software; you can redistribute it and/or modify it 2127898184e3Ssthenunder the same terms as Perl itself. 2128898184e3Ssthen 2129898184e3SsthenThis program is distributed in the hope that it will be useful, but 2130898184e3Ssthenwithout any warranty; without even the implied warranty of 2131898184e3Ssthenmerchantability or fitness for a particular purpose. 2132898184e3Ssthen 2133898184e3Ssthen=head1 AUTHOR 2134898184e3Ssthen 2135898184e3SsthenCurrent maintainer: Mark Allen C<< <mallen@cpan.org> >> 2136898184e3Ssthen 2137898184e3SsthenPast contributions from: 2138898184e3Ssthenbrian d foy C<< <bdfoy@cpan.org> >> 2139898184e3SsthenAdriano R. Ferreira C<< <ferreira@cpan.org> >>, 2140898184e3SsthenSean M. Burke C<< <sburke@cpan.org> >> 2141898184e3Ssthen 2142898184e3Ssthen=cut 2143