From e5833079aa4f6224797302925c72d129b795ef95 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Sat, 12 Sep 2009 22:34:14 +0100 Subject: Move Pod::Perldoc from lib to ext. --- lib/Pod/Perldoc.pm | 1952 ---------------------------------- lib/Pod/Perldoc/BaseTo.pm | 81 -- lib/Pod/Perldoc/GetOptsOO.pm | 148 --- lib/Pod/Perldoc/ToChecker.pm | 75 -- lib/Pod/Perldoc/ToMan.pm | 190 ---- lib/Pod/Perldoc/ToNroff.pm | 103 -- lib/Pod/Perldoc/ToPod.pm | 93 -- lib/Pod/Perldoc/ToRtf.pm | 88 -- lib/Pod/Perldoc/ToText.pm | 95 -- lib/Pod/Perldoc/ToTk.pm | 132 --- lib/Pod/Perldoc/ToXml.pm | 66 -- lib/Pod/Perldoc/t/01_about_verbose.t | 87 -- lib/Pod/Perldoc/t/checkerbasic.t | 9 - lib/Pod/Perldoc/t/perldocbasic.t | 9 - lib/Pod/Perldoc/t/textbasic.t | 9 - 15 files changed, 3137 deletions(-) delete mode 100644 lib/Pod/Perldoc.pm delete mode 100644 lib/Pod/Perldoc/BaseTo.pm delete mode 100644 lib/Pod/Perldoc/GetOptsOO.pm delete mode 100644 lib/Pod/Perldoc/ToChecker.pm delete mode 100644 lib/Pod/Perldoc/ToMan.pm delete mode 100644 lib/Pod/Perldoc/ToNroff.pm delete mode 100644 lib/Pod/Perldoc/ToPod.pm delete mode 100644 lib/Pod/Perldoc/ToRtf.pm delete mode 100644 lib/Pod/Perldoc/ToText.pm delete mode 100644 lib/Pod/Perldoc/ToTk.pm delete mode 100644 lib/Pod/Perldoc/ToXml.pm delete mode 100644 lib/Pod/Perldoc/t/01_about_verbose.t delete mode 100644 lib/Pod/Perldoc/t/checkerbasic.t delete mode 100644 lib/Pod/Perldoc/t/perldocbasic.t delete mode 100644 lib/Pod/Perldoc/t/textbasic.t (limited to 'lib/Pod') diff --git a/lib/Pod/Perldoc.pm b/lib/Pod/Perldoc.pm deleted file mode 100644 index ef54796ad8..0000000000 --- a/lib/Pod/Perldoc.pm +++ /dev/null @@ -1,1952 +0,0 @@ - -require 5; -use 5.006; # we use some open(X, "<", $y) syntax -package Pod::Perldoc; -use strict; -use warnings; -use Config '%Config'; - -use Fcntl; # for sysopen -use File::Spec::Functions qw(catfile catdir splitdir); - -use vars qw($VERSION @Pagers $Bindir $Pod2man - $Temp_Files_Created $Temp_File_Lifetime -); -$VERSION = '3.15'; -#.......................................................................... - -BEGIN { # Make a DEBUG constant very first thing... - unless(defined &DEBUG) { - if(($ENV{'PERLDOCDEBUG'} || '') =~ m/^(\d+)/) { # untaint - eval("sub DEBUG () {$1}"); - die "WHAT? Couldn't eval-up a DEBUG constant!? $@" if $@; - } else { - *DEBUG = sub () {0}; - } - } -} - -use Pod::Perldoc::GetOptsOO; # uses the DEBUG. - -#.......................................................................... - -sub TRUE () {1} -sub FALSE () {return} -sub BE_LENIENT () {1} - -BEGIN { - *IS_VMS = $^O eq 'VMS' ? \&TRUE : \&FALSE unless defined &IS_VMS; - *IS_MSWin32 = $^O eq 'MSWin32' ? \&TRUE : \&FALSE unless defined &IS_MSWin32; - *IS_Dos = $^O eq 'dos' ? \&TRUE : \&FALSE unless defined &IS_Dos; - *IS_OS2 = $^O eq 'os2' ? \&TRUE : \&FALSE unless defined &IS_OS2; - *IS_Cygwin = $^O eq 'cygwin' ? \&TRUE : \&FALSE unless defined &IS_Cygwin; - *IS_Linux = $^O eq 'linux' ? \&TRUE : \&FALSE unless defined &IS_Linux; - *IS_HPUX = $^O =~ m/hpux/ ? \&TRUE : \&FALSE unless defined &IS_HPUX; -} - -$Temp_File_Lifetime ||= 60 * 60 * 24 * 5; - # If it's older than five days, it's quite unlikely - # that anyone's still looking at it!! - # (Currently used only by the MSWin cleanup routine) - - -#.......................................................................... -{ my $pager = $Config{'pager'}; - push @Pagers, $pager if -x (split /\s+/, $pager)[0] or IS_VMS; -} -$Bindir = $Config{'scriptdirexp'}; -$Pod2man = "pod2man" . ( $Config{'versiononly'} ? $Config{'version'} : '' ); - -# End of class-init stuff -# -########################################################################### -# -# Option accessors... - -foreach my $subname (map "opt_$_", split '', q{mhlDriFfXqnTdULv}) { - no strict 'refs'; - *$subname = do{ use strict 'refs'; sub () { shift->_elem($subname, @_) } }; -} - -# And these are so that GetOptsOO knows they take options: -sub opt_f_with { shift->_elem('opt_f', @_) } -sub opt_q_with { shift->_elem('opt_q', @_) } -sub opt_d_with { shift->_elem('opt_d', @_) } -sub opt_L_with { shift->_elem('opt_L', @_) } -sub opt_v_with { shift->_elem('opt_v', @_) } - -sub opt_w_with { # Specify an option for the formatter subclass - my($self, $value) = @_; - if($value =~ m/^([-_a-zA-Z][-_a-zA-Z0-9]*)(?:[=\:](.*?))?$/s) { - my $option = $1; - my $option_value = defined($2) ? $2 : "TRUE"; - $option =~ tr/\-/_/s; # tolerate "foo-bar" for "foo_bar" - $self->add_formatter_option( $option, $option_value ); - } else { - warn "\"$value\" isn't a good formatter option name. I'm ignoring it!\n"; - } - return; -} - -sub opt_M_with { # specify formatter class name(s) - my($self, $classes) = @_; - return unless defined $classes and length $classes; - DEBUG > 4 and print "Considering new formatter classes -M$classes\n"; - my @classes_to_add; - foreach my $classname (split m/[,;]+/s, $classes) { - next unless $classname =~ m/\S/; - if( $classname =~ m/^(\w+(::\w+)+)$/s ) { - # A mildly restrictive concept of what modulenames are valid. - push @classes_to_add, $1; # untaint - } else { - warn "\"$classname\" isn't a valid classname. Ignoring.\n"; - } - } - - unshift @{ $self->{'formatter_classes'} }, @classes_to_add; - - DEBUG > 3 and print( - "Adding @classes_to_add to the list of formatter classes, " - . "making them @{ $self->{'formatter_classes'} }.\n" - ); - - return; -} - -sub opt_V { # report version and exit - print join '', - "Perldoc v$VERSION, under perl v$] for $^O", - - (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) - ? (" (win32 build ", &Win32::BuildNumber(), ")") : (), - - (chr(65) eq 'A') ? () : " (non-ASCII)", - - "\n", - ; - exit; -} - -sub opt_t { # choose plaintext as output format - my $self = shift; - $self->opt_o_with('text') if @_ and $_[0]; - return $self->_elem('opt_t', @_); -} - -sub opt_u { # choose raw pod as output format - my $self = shift; - $self->opt_o_with('pod') if @_ and $_[0]; - return $self->_elem('opt_u', @_); -} - -sub opt_n_with { - # choose man as the output format, and specify the proggy to run - my $self = shift; - $self->opt_o_with('man') if @_ and $_[0]; - $self->_elem('opt_n', @_); -} - -sub opt_o_with { # "o" for output format - my($self, $rest) = @_; - return unless defined $rest and length $rest; - if($rest =~ m/^(\w+)$/s) { - $rest = $1; #untaint - } else { - warn "\"$rest\" isn't a valid output format. Skipping.\n"; - return; - } - - $self->aside("Noting \"$rest\" as desired output format...\n"); - - # Figure out what class(es) that could actually mean... - - my @classes; - foreach my $prefix ("Pod::Perldoc::To", "Pod::Simple::", "Pod::") { - # Messy but smart: - foreach my $stem ( - $rest, # Yes, try it first with the given capitalization - "\L$rest", "\L\u$rest", "\U$rest" # And then try variations - - ) { - push @classes, $prefix . $stem; - #print "Considering $prefix$stem\n"; - } - - # Tidier, but misses too much: - #push @classes, $prefix . ucfirst(lc($rest)); - } - $self->opt_M_with( join ";", @classes ); - return; -} - -########################################################################### -# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % - -sub run { # to be called by the "perldoc" executable - my $class = shift; - if(DEBUG > 3) { - print "Parameters to $class\->run:\n"; - my @x = @_; - while(@x) { - $x[1] = '' unless defined $x[1]; - $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; - print " [$x[0]] => [$x[1]]\n"; - splice @x,0,2; - } - print "\n"; - } - return $class -> new(@_) -> process() || 0; -} - -# % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % % -########################################################################### - -sub new { # yeah, nothing fancy - my $class = shift; - my $new = bless {@_}, (ref($class) || $class); - DEBUG > 1 and print "New $class object $new\n"; - $new->init(); - $new; -} - -#.......................................................................... - -sub aside { # If we're in -D or DEBUG mode, say this. - my $self = shift; - if( DEBUG or $self->opt_D ) { - my $out = join( '', - DEBUG ? do { - my $callsub = (caller(1))[3]; - my $package = quotemeta(__PACKAGE__ . '::'); - $callsub =~ s/^$package/'/os; - # the o is justified, as $package really won't change. - $callsub . ": "; - } : '', - @_, - ); - if(DEBUG) { print $out } else { print STDERR $out } - } - return; -} - -#.......................................................................... - -sub usage { - my $self = shift; - warn "@_\n" if @_; - - # Erase evidence of previous errors (if any), so exit status is simple. - $! = 0; - - die <{'pagers'} } } - -#.......................................................................... - -sub _elem { # handy scalar meta-accessor: shift->_elem("foo", @_) - if(@_ > 2) { return $_[0]{ $_[1] } = $_[2] } - else { return $_[0]{ $_[1] } } -} -#.......................................................................... -########################################################################### -# -# Init formatter switches, and start it off with __bindir and all that -# other stuff that ToMan.pm needs. -# - -sub init { - my $self = shift; - - # Make sure creat()s are neither too much nor too little - eval { umask(0077) }; # doubtless someone has no mask - - $self->{'args'} ||= \@ARGV; - $self->{'found'} ||= []; - $self->{'temp_file_list'} ||= []; - - - $self->{'target'} = undef; - - $self->init_formatter_class_list; - - $self->{'pagers' } = [@Pagers] unless exists $self->{'pagers'}; - $self->{'bindir' } = $Bindir unless exists $self->{'bindir'}; - $self->{'pod2man'} = $Pod2man unless exists $self->{'pod2man'}; - - push @{ $self->{'formatter_switches'} = [] }, ( - # Yeah, we could use a hashref, but maybe there's some class where options - # have to be ordered; so we'll use an arrayref. - - [ '__bindir' => $self->{'bindir' } ], - [ '__pod2man' => $self->{'pod2man'} ], - ); - - DEBUG > 3 and printf "Formatter switches now: [%s]\n", - join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; - - $self->{'translators'} = []; - $self->{'extra_search_dirs'} = []; - - return; -} - -#.......................................................................... - -sub init_formatter_class_list { - my $self = shift; - $self->{'formatter_classes'} ||= []; - - # Remember, no switches have been read yet, when - # we've started this routine. - - $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru - $self->opt_o_with('text'); - $self->opt_o_with('man') unless IS_MSWin32 || IS_Dos - || !($ENV{TERM} && ( - ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i - )); - - return; -} - -#.......................................................................... - -sub process { - # if this ever returns, its retval will be used for exit(RETVAL) - - my $self = shift; - DEBUG > 1 and print " Beginning process.\n"; - DEBUG > 1 and print " Args: @{$self->{'args'}}\n\n"; - if(DEBUG > 3) { - print "Object contents:\n"; - my @x = %$self; - while(@x) { - $x[1] = '' unless defined $x[1]; - $x[1] = "@{$x[1]}" if ref( $x[1] ) eq 'ARRAY'; - print " [$x[0]] => [$x[1]]\n"; - splice @x,0,2; - } - print "\n"; - } - - # TODO: make it deal with being invoked as various different things - # such as perlfaq". - - return $self->usage_brief unless @{ $self->{'args'} }; - $self->pagers_guessing; - $self->options_reading; - $self->aside(sprintf "$0 => %s v%s\n", ref($self), $self->VERSION); - $self->drop_privs_maybe; - $self->options_processing; - - # Hm, we have @pages and @found, but we only really act on one - # file per call, with the exception of the opt_q hack, and with - # -l things - - $self->aside("\n"); - - my @pages; - $self->{'pages'} = \@pages; - if( $self->opt_f) { @pages = ("perlfunc") } - elsif( $self->opt_q) { @pages = ("perlfaq1" .. "perlfaq9") } - elsif( $self->opt_v) { @pages = ("perlvar") } - else { @pages = @{$self->{'args'}}; - # @pages = __FILE__ - # if @pages == 1 and $pages[0] eq 'perldoc'; - } - - return $self->usage_brief unless @pages; - - $self->find_good_formatter_class(); - $self->formatter_sanity_check(); - - $self->maybe_diddle_INC(); - # for when we're apparently in a module or extension directory - - my @found = $self->grand_search_init(\@pages); - exit (IS_VMS ? 98962 : 1) unless @found; - - if ($self->opt_l) { - DEBUG and print "We're in -l mode, so byebye after this:\n"; - print join("\n", @found), "\n"; - return; - } - - $self->tweak_found_pathnames(\@found); - $self->assert_closing_stdout; - return $self->page_module_file(@found) if $self->opt_m; - DEBUG > 2 and print "Found: [@found]\n"; - - return $self->render_and_page(\@found); -} - -#.......................................................................... -{ - -my( %class_seen, %class_loaded ); -sub find_good_formatter_class { - my $self = $_[0]; - my @class_list = @{ $self->{'formatter_classes'} || [] }; - die "WHAT? Nothing in the formatter class list!?" unless @class_list; - - my $good_class_found; - foreach my $c (@class_list) { - DEBUG > 4 and print "Trying to load $c...\n"; - if($class_loaded{$c}) { - DEBUG > 4 and print "OK, the already-loaded $c it is!\n"; - $good_class_found = $c; - last; - } - - if($class_seen{$c}) { - DEBUG > 4 and print - "I've tried $c before, and it's no good. Skipping.\n"; - next; - } - - $class_seen{$c} = 1; - - if( $c->can('parse_from_file') ) { - DEBUG > 4 and print - "Interesting, the formatter class $c is already loaded!\n"; - - } elsif( - (IS_VMS or IS_MSWin32 or IS_Dos or IS_OS2) - # the alway case-insensitive fs's - and $class_seen{lc("~$c")}++ - ) { - DEBUG > 4 and print - "We already used something quite like \"\L$c\E\", so no point using $c\n"; - # This avoids redefining the package. - } else { - DEBUG > 4 and print "Trying to eval 'require $c'...\n"; - - local $^W = $^W; - if(DEBUG() or $self->opt_D) { - # feh, let 'em see it - } else { - $^W = 0; - # The average user just has no reason to be seeing - # $^W-suppressable warnings from the the require! - } - - eval "require $c"; - if($@) { - DEBUG > 4 and print "Couldn't load $c: $!\n"; - next; - } - } - - if( $c->can('parse_from_file') ) { - DEBUG > 4 and print "Settling on $c\n"; - my $v = $c->VERSION; - $v = ( defined $v and length $v ) ? " version $v" : ''; - $self->aside("Formatter class $c$v successfully loaded!\n"); - $good_class_found = $c; - last; - } else { - DEBUG > 4 and print "Class $c isn't a formatter?! Skipping.\n"; - } - } - - die "Can't find any loadable formatter class in @class_list?!\nAborting" - unless $good_class_found; - - $self->{'formatter_class'} = $good_class_found; - $self->aside("Will format with the class $good_class_found\n"); - - return; -} - -} -#.......................................................................... - -sub formatter_sanity_check { - my $self = shift; - my $formatter_class = $self->{'formatter_class'} - || die "NO FORMATTER CLASS YET!?"; - - if(!$self->opt_T # so -T can FORCE sending to STDOUT - and $formatter_class->can('is_pageable') - and !$formatter_class->is_pageable - and !$formatter_class->can('page_for_perldoc') - ) { - my $ext = - ($formatter_class->can('output_extension') - && $formatter_class->output_extension - ) || ''; - $ext = ".$ext" if length $ext; - - die - "When using Perldoc to format with $formatter_class, you have to\n" - . "specify -T or -dsomefile$ext\n" - . "See `perldoc perldoc' for more information on those switches.\n" - ; - } -} - -#.......................................................................... - -sub render_and_page { - my($self, $found_list) = @_; - - $self->maybe_generate_dynamic_pod($found_list); - - my($out, $formatter) = $self->render_findings($found_list); - - if($self->opt_d) { - printf "Perldoc (%s) output saved to %s\n", - $self->{'formatter_class'} || ref($self), - $out; - print "But notice that it's 0 bytes long!\n" unless -s $out; - - - } elsif( # Allow the formatter to "page" itself, if it wants. - $formatter->can('page_for_perldoc') - and do { - $self->aside("Going to call $formatter\->page_for_perldoc(\"$out\")\n"); - if( $formatter->page_for_perldoc($out, $self) ) { - $self->aside("page_for_perldoc returned true, so NOT paging with $self.\n"); - 1; - } else { - $self->aside("page_for_perldoc returned false, so paging with $self instead.\n"); - ''; - } - } - ) { - # Do nothing, since the formatter has "paged" it for itself. - - } else { - # Page it normally (internally) - - if( -s $out ) { # Usual case: - $self->page($out, $self->{'output_to_stdout'}, $self->pagers); - - } else { - # Odd case: - $self->aside("Skipping $out (from $$found_list[0] " - . "via $$self{'formatter_class'}) as it is 0-length.\n"); - - push @{ $self->{'temp_file_list'} }, $out; - $self->unlink_if_temp_file($out); - } - } - - $self->after_rendering(); # any extra cleanup or whatever - - return; -} - -#.......................................................................... - -sub options_reading { - my $self = shift; - - if( defined $ENV{"PERLDOC"} and length $ENV{"PERLDOC"} ) { - require Text::ParseWords; - $self->aside("Noting env PERLDOC setting of $ENV{'PERLDOC'}\n"); - # Yes, appends to the beginning - unshift @{ $self->{'args'} }, - Text::ParseWords::shellwords( $ENV{"PERLDOC"} ) - ; - DEBUG > 1 and print " Args now: @{$self->{'args'}}\n\n"; - } else { - DEBUG > 1 and print " Okay, no PERLDOC setting in ENV.\n"; - } - - DEBUG > 1 - and print " Args right before switch processing: @{$self->{'args'}}\n"; - - Pod::Perldoc::GetOptsOO::getopts( $self, $self->{'args'}, 'YES' ) - or return $self->usage; - - DEBUG > 1 - and print " Args after switch processing: @{$self->{'args'}}\n"; - - return $self->usage if $self->opt_h; - - return; -} - -#.......................................................................... - -sub options_processing { - my $self = shift; - - if ($self->opt_X) { - my $podidx = "$Config{'archlib'}/pod.idx"; - $podidx = "" unless -f $podidx && -r _ && -M _ <= 7; - $self->{'podidx'} = $podidx; - } - - $self->{'output_to_stdout'} = 1 if $self->opt_T or ! -t STDOUT; - - $self->options_sanity; - - $self->opt_n("nroff") unless $self->opt_n; - $self->add_formatter_option( '__nroffer' => $self->opt_n ); - - # Adjust for using translation packages - $self->add_translator($self->opt_L) if $self->opt_L; - - return; -} - -#.......................................................................... - -sub options_sanity { - my $self = shift; - - # The opts-counting stuff interacts quite badly with - # the $ENV{"PERLDOC"} stuff. I.e., if I have $ENV{"PERLDOC"} - # set to -t, and I specify -u on the command line, I don't want - # to be hectored at that -u and -t don't make sense together. - - #my $opts = grep $_ && 1, # yes, the count of the set ones - # $self->opt_t, $self->opt_u, $self->opt_m, $self->opt_l - #; - # - #$self->usage("only one of -t, -u, -m or -l") if $opts > 1; - - - # Any sanity-checking need doing here? - - # But does not make sense to set either -f or -q in $ENV{"PERLDOC"} - if( $self->opt_f or $self->opt_q ) { - $self->usage("Only one of -f -or -q") if $self->opt_f and $self->opt_q; - warn - "Perldoc is only really meant for reading one word at a time.\n", - "So these parameters are being ignored: ", - join(' ', @{$self->{'args'}}), - "\n" - if @{$self->{'args'}} - } - return; -} - -#.......................................................................... - -sub grand_search_init { - my($self, $pages, @found) = @_; - - foreach (@$pages) { - if ($self->{'podidx'} && open(PODIDX, $self->{'podidx'})) { - my $searchfor = catfile split '::', $_; - $self->aside( "Searching for '$searchfor' in $self->{'podidx'}\n" ); - local $_; - while () { - chomp; - push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i; - } - close(PODIDX) or die "Can't close $$self{'podidx'}: $!"; - next; - } - - $self->aside( "Searching for $_\n" ); - - if ($self->opt_F) { - next unless -r; - push @found, $_ if $self->opt_m or $self->containspod($_); - next; - } - - my @searchdirs; - - # prepend extra search directories (including language specific) - push @searchdirs, @{ $self->{'extra_search_dirs'} }; - - # We must look both in @INC for library modules and in $bindir - # for executables, like h2xs or perldoc itself. - push @searchdirs, ($self->{'bindir'}, @INC); - unless ($self->opt_m) { - if (IS_VMS) { - my($i,$trn); - for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) { - push(@searchdirs,$trn); - } - push(@searchdirs,'perl_root:[lib.pod]') # installed pods - } - else { - push(@searchdirs, grep(-d, split($Config{path_sep}, - $ENV{'PATH'}))); - } - } - my @files = $self->searchfor(0,$_,@searchdirs); - if (@files) { - $self->aside( "Found as @files\n" ); - } - # add "perl" prefix, so "perldoc foo" may find perlfoo.pod - elsif (BE_LENIENT and !/\W/ and @files = $self->searchfor(0, "perl$_", @searchdirs)) { - $self->aside( "Loosely found as @files\n" ); - } - else { - # no match, try recursive search - @searchdirs = grep(!/^\.\z/s,@INC); - @files= $self->searchfor(1,$_,@searchdirs) if $self->opt_r; - if (@files) { - $self->aside( "Loosely found as @files\n" ); - } - else { - print STDERR "No " . - ($self->opt_m ? "module" : "documentation") . " found for \"$_\".\n"; - if ( @{ $self->{'found'} } ) { - print STDERR "However, try\n"; - for my $dir (@{ $self->{'found'} }) { - opendir(DIR, $dir) or die "opendir $dir: $!"; - while (my $file = readdir(DIR)) { - next if ($file =~ /^\./s); - $file =~ s/\.(pm|pod)\z//; # XXX: badfs - print STDERR "\tperldoc $_\::$file\n"; - } - closedir(DIR) or die "closedir $dir: $!"; - } - } - } - } - push(@found,@files); - } - return @found; -} - -#.......................................................................... - -sub maybe_generate_dynamic_pod { - my($self, $found_things) = @_; - my @dynamic_pod; - - $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f; - - $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v; - - $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q; - - if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v ) { - DEBUG > 4 and print "That's a non-dynamic pod search.\n"; - } elsif ( @dynamic_pod ) { - $self->aside("Hm, I found some Pod from that search!\n"); - my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); - - push @{ $self->{'temp_file_list'} }, $buffer; - # I.e., it MIGHT be deleted at the end. - - my $in_list = $self->opt_f || $self->opt_v; - - print $buffd "=over 8\n\n" if $in_list; - print $buffd @dynamic_pod or die "Can't print $buffer: $!"; - print $buffd "=back\n" if $in_list; - - close $buffd or die "Can't close $buffer: $!"; - - @$found_things = $buffer; - # Yes, so found_things never has more than one thing in - # it, by time we leave here - - $self->add_formatter_option('__filter_nroff' => 1); - - } else { - @$found_things = (); - $self->aside("I found no Pod from that search!\n"); - } - - return; -} - -#.......................................................................... - -sub add_formatter_option { # $self->add_formatter_option('key' => 'value'); - my $self = shift; - push @{ $self->{'formatter_switches'} }, [ @_ ] if @_; - - DEBUG > 3 and printf "Formatter switches now: [%s]\n", - join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; - - return; -} - -#......................................................................... - -sub new_translator { # $tr = $self->new_translator($lang); - my $self = shift; - my $lang = shift; - - my $pack = 'POD2::' . uc($lang); - eval "require $pack"; - if ( !$@ && $pack->can('new') ) { - return $pack->new(); - } - - eval { require POD2::Base }; - return if $@; - - return POD2::Base->new({ lang => $lang }); -} - -#......................................................................... - -sub add_translator { # $self->add_translator($lang); - my $self = shift; - for my $lang (@_) { - my $tr = $self->new_translator($lang); - if ( defined $tr ) { - push @{ $self->{'translators'} }, $tr; - push @{ $self->{'extra_search_dirs'} }, $tr->pod_dirs; - - $self->aside( "translator for '$lang' loaded\n" ); - } else { - # non-installed or bad translator package - warn "Perldoc cannot load translator package for '$lang': ignored\n"; - } - - } - return; -} - -#.......................................................................... - -sub search_perlvar { - my($self, $found_things, $pod) = @_; - - my $opt = $self->opt_v; - - if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) { - die "'$opt' does not look like a Perl variable\n"; - } - - DEBUG > 2 and print "Search: @$found_things\n"; - - my $perlvar = shift @$found_things; - open(PVAR, "<", $perlvar) # "Funk is its own reward" - or die("Can't open $perlvar: $!"); - - if ( $opt =~ /^\$\d+$/ ) { # handle $1, $2, ..., $9 - $opt = '$>'; - } - my $search_re = quotemeta($opt); - - DEBUG > 2 and - print "Going to perlvar-scan for $search_re in $perlvar\n"; - - # Skip introduction - local $_; - while () { - last if /^=over 8/; - } - - # Look for our variable - my $found = 0; - my $inheader = 1; - my $inlist = 0; - while () { # "The Mothership Connection is here!" - last if /^=head2 Error Indicators/; - # \b at the end of $` and friends borks things! - if ( m/^=item\s+$search_re\s/ ) { - $found = 1; - } - elsif (/^=item/) { - last if $found && !$inheader && !$inlist; - } - elsif (!/^\s+$/) { # not a blank line - if ( $found ) { - $inheader = 0; # don't accept more =item (unless inlist) - } - else { - @$pod = (); # reset - $inheader = 1; # start over - next; - } - } - - if (/^=over/) { - ++$inlist; - } - elsif (/^=back/) { - --$inlist; - } - push @$pod, $_; -# ++$found if /^\w/; # found descriptive text - } - @$pod = () unless $found; - if (!@$pod) { - die "No documentation for perl variable '$opt' found\n"; - } - close PVAR or die "Can't open $perlvar: $!"; - - return; -} - -#.......................................................................... - -sub search_perlfunc { - my($self, $found_things, $pod) = @_; - - DEBUG > 2 and print "Search: @$found_things\n"; - - my $perlfunc = shift @$found_things; - open(PFUNC, "<", $perlfunc) # "Funk is its own reward" - or die("Can't open $perlfunc: $!"); - - # Functions like -r, -e, etc. are listed under `-X'. - my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/) - ? '(?:I<)?-X' : quotemeta($self->opt_f) ; - - DEBUG > 2 and - print "Going to perlfunc-scan for $search_re in $perlfunc\n"; - - my $re = 'Alphabetical Listing of Perl Functions'; - if ( $self->opt_L ) { - my $tr = $self->{'translators'}->[0]; - $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re'); - } - - # Skip introduction - local $_; - while () { - last if /^=head2 $re/; - } - - # Look for our function - my $found = 0; - my $inlist = 0; - while () { # "The Mothership Connection is here!" - if ( m/^=item\s+$search_re\b/ ) { - $found = 1; - } - elsif (/^=item/) { - last if $found > 1 and not $inlist; - } - next unless $found; - if (/^=over/) { - ++$inlist; - } - elsif (/^=back/) { - --$inlist; - } - push @$pod, $_; - ++$found if /^\w/; # found descriptive text - } - if (!@$pod) { - die sprintf - "No documentation for perl function `%s' found\n", - $self->opt_f - ; - } - close PFUNC or die "Can't open $perlfunc: $!"; - - return; -} - -#.......................................................................... - -sub search_perlfaqs { - my( $self, $found_things, $pod) = @_; - - my $found = 0; - my %found_in; - my $search_key = $self->opt_q; - - my $rx = eval { qr/$search_key/ } - or die <|]/; - open(INFAQ, "<", $file) # XXX 5.6ism - or die "Can't read-open $file: $!\nAborting"; - while () { - if ( m/^=head2\s+.*(?:$search_key)/i ) { - $found = 1; - push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++; - } - elsif (/^=head[12]/) { - $found = 0; - } - next unless $found; - push @$pod, $_; - } - close(INFAQ); - } - die("No documentation for perl FAQ keyword `$search_key' found\n") - unless @$pod; - - return; -} - - -#.......................................................................... - -sub render_findings { - # Return the filename to open - - my($self, $found_things) = @_; - - my $formatter_class = $self->{'formatter_class'} - || die "No formatter class set!?"; - my $formatter = $formatter_class->can('new') - ? $formatter_class->new - : $formatter_class - ; - - if(! @$found_things) { - die "Nothing found?!"; - # should have been caught before here - } elsif(@$found_things > 1) { - warn - "Perldoc is only really meant for reading one document at a time.\n", - "So these parameters are being ignored: ", - join(' ', @$found_things[1 .. $#$found_things] ), - "\n" - } - - my $file = $found_things->[0]; - - DEBUG > 3 and printf "Formatter switches now: [%s]\n", - join ' ', map "[@$_]", @{ $self->{'formatter_switches'} }; - - # Set formatter options: - if( ref $formatter ) { - foreach my $f (@{ $self->{'formatter_switches'} || [] }) { - my($switch, $value, $silent_fail) = @$f; - if( $formatter->can($switch) ) { - eval { $formatter->$switch( defined($value) ? $value : () ) }; - warn "Got an error when setting $formatter_class\->$switch:\n$@\n" - if $@; - } else { - if( $silent_fail or $switch =~ m/^__/s ) { - DEBUG > 2 and print "Formatter $formatter_class doesn't support $switch\n"; - } else { - warn "$formatter_class doesn't recognize the $switch switch.\n"; - } - } - } - } - - $self->{'output_is_binary'} = - $formatter->can('write_with_binmode') && $formatter->write_with_binmode; - - my ($out_fh, $out) = $self->new_output_file( - ( $formatter->can('output_extension') && $formatter->output_extension ) - || undef, - $self->useful_filename_bit, - ); - - # Now, finally, do the formatting! - { - local $^W = $^W; - if(DEBUG() or $self->opt_D) { - # feh, let 'em see it - } else { - $^W = 0; - # The average user just has no reason to be seeing - # $^W-suppressable warnings from the formatting! - } - - eval { $formatter->parse_from_file( $file, $out_fh ) }; - } - - warn "Error while formatting with $formatter_class:\n $@\n" if $@; - DEBUG > 2 and print "Back from formatting with $formatter_class\n"; - - close $out_fh - or warn "Can't close $out: $!\n(Did $formatter already close it?)"; - sleep 0; sleep 0; sleep 0; - # Give the system a few timeslices to meditate on the fact - # that the output file does in fact exist and is closed. - - $self->unlink_if_temp_file($file); - - unless( -s $out ) { - if( $formatter->can( 'if_zero_length' ) ) { - # Basically this is just a hook for Pod::Simple::Checker; since - # what other class could /happily/ format an input file with Pod - # as a 0-length output file? - $formatter->if_zero_length( $file, $out, $out_fh ); - } else { - warn "Got a 0-length file from $$found_things[0] via $formatter_class!?\n" - } - } - - DEBUG and print "Finished writing to $out.\n"; - return($out, $formatter) if wantarray; - return $out; -} - -#.......................................................................... - -sub unlink_if_temp_file { - # Unlink the specified file IFF it's in the list of temp files. - # Really only used in the case of -f / -q things when we can - # throw away the dynamically generated source pod file once - # we've formatted it. - # - my($self, $file) = @_; - return unless defined $file and length $file; - - my $temp_file_list = $self->{'temp_file_list'} || return; - if(grep $_ eq $file, @$temp_file_list) { - $self->aside("Unlinking $file\n"); - unlink($file) or warn "Odd, couldn't unlink $file: $!"; - } else { - DEBUG > 1 and print "$file isn't a temp file, so not unlinking.\n"; - } - return; -} - -#.......................................................................... - -sub MSWin_temp_cleanup { - - # Nothing particularly MSWin-specific in here, but I don't know if any - # other OS needs its temp dir policed like MSWin does! - - my $self = shift; - - my $tempdir = $ENV{'TEMP'}; - return unless defined $tempdir and length $tempdir - and -e $tempdir and -d _ and -w _; - - $self->aside( - "Considering whether any old files of mine in $tempdir need unlinking.\n" - ); - - opendir(TMPDIR, $tempdir) || return; - my @to_unlink; - - my $limit = time() - $Temp_File_Lifetime; - - DEBUG > 5 and printf "Looking for things pre-dating %s (%x)\n", - ($limit) x 2; - - my $filespec; - - while(defined($filespec = readdir(TMPDIR))) { - if( - $filespec =~ m{^perldoc_[a-zA-Z0-9]+_T([a-fA-F0-9]{7,})_[a-fA-F0-9]{3,}}s - ) { - if( hex($1) < $limit ) { - push @to_unlink, "$tempdir/$filespec"; - $self->aside( "Will unlink my old temp file $to_unlink[-1]\n" ); - } else { - DEBUG > 5 and - printf " $tempdir/$filespec is too recent (after %x)\n", $limit; - } - } else { - DEBUG > 5 and - print " $tempdir/$filespec doesn't look like a perldoc temp file.\n"; - } - } - closedir(TMPDIR); - $self->aside(sprintf "Unlinked %s items of mine in %s\n", - scalar(unlink(@to_unlink)), - $tempdir - ); - return; -} - -# . . . . . . . . . . . . . . . . . . . . . . . . . - -sub MSWin_perldoc_tempfile { - my($self, $suffix, $infix) = @_; - - my $tempdir = $ENV{'TEMP'}; - return unless defined $tempdir and length $tempdir - and -e $tempdir and -d _ and -w _; - - my $spec; - - do { - $spec = sprintf "%s\\perldoc_%s_T%x_%x%02x.%s", # used also in MSWin_temp_cleanup - # Yes, we embed the create-time in the filename! - $tempdir, - $infix || 'x', - time(), - $$, - defined( &Win32::GetTickCount ) - ? (Win32::GetTickCount() & 0xff) - : int(rand 256) - # Under MSWin, $$ values get reused quickly! So if we ran - # perldoc foo and then perldoc bar before there was time for - # time() to increment time."_$$" would likely be the same - # for each process! So we tack on the tick count's lower - # bits (or, in a pinch, rand) - , - $suffix || 'txt'; - ; - } while( -e $spec ); - - my $counter = 0; - - while($counter < 50) { - my $fh; - # If we are running before perl5.6.0, we can't autovivify - if ($] < 5.006) { - require Symbol; - $fh = Symbol::gensym(); - } - DEBUG > 3 and print "About to try making temp file $spec\n"; - return($fh, $spec) if open($fh, ">", $spec); # XXX 5.6ism - $self->aside("Can't create temp file $spec: $!\n"); - } - - $self->aside("Giving up on making a temp file!\n"); - die "Can't make a tempfile!?"; -} - -#.......................................................................... - - -sub after_rendering { - my $self = $_[0]; - $self->after_rendering_VMS if IS_VMS; - $self->after_rendering_MSWin32 if IS_MSWin32; - $self->after_rendering_Dos if IS_Dos; - $self->after_rendering_OS2 if IS_OS2; - return; -} - -sub after_rendering_VMS { return } -sub after_rendering_Dos { return } -sub after_rendering_OS2 { return } - -sub after_rendering_MSWin32 { - shift->MSWin_temp_cleanup() if $Temp_Files_Created; -} - -#.......................................................................... -# : : : : : : : : : -#.......................................................................... - - -sub minus_f_nocase { # i.e., do like -f, but without regard to case - - my($self, $dir, $file) = @_; - my $path = catfile($dir,$file); - return $path if -f $path and -r _; - - if(!$self->opt_i - or IS_VMS or IS_MSWin32 - or IS_Dos or IS_OS2 - ) { - # On a case-forgiving file system, or if case is important, - # that is it, all we can do. - warn "Ignored $path: unreadable\n" if -f _; - return ''; - } - - local *DIR; - my @p = ($dir); - my($p,$cip); - foreach $p (splitdir $file){ - my $try = catfile @p, $p; - $self->aside("Scrutinizing $try...\n"); - stat $try; - if (-d _) { - push @p, $p; - if ( $p eq $self->{'target'} ) { - my $tmp_path = catfile @p; - my $path_f = 0; - for (@{ $self->{'found'} }) { - $path_f = 1 if $_ eq $tmp_path; - } - push (@{ $self->{'found'} }, $tmp_path) unless $path_f; - $self->aside( "Found as $tmp_path but directory\n" ); - } - } - elsif (-f _ && -r _) { - return $try; - } - elsif (-f _) { - warn "Ignored $try: unreadable\n"; - } - elsif (-d catdir(@p)) { # at least we see the containing directory! - my $found = 0; - my $lcp = lc $p; - my $p_dirspec = catdir(@p); - opendir DIR, $p_dirspec or die "opendir $p_dirspec: $!"; - while(defined( $cip = readdir(DIR) )) { - if (lc $cip eq $lcp){ - $found++; - last; # XXX stop at the first? what if there's others? - } - } - closedir DIR or die "closedir $p_dirspec: $!"; - return "" unless $found; - - push @p, $cip; - my $p_filespec = catfile(@p); - return $p_filespec if -f $p_filespec and -r _; - warn "Ignored $p_filespec: unreadable\n" if -f _; - } - } - return ""; -} - -#.......................................................................... - -sub pagers_guessing { - my $self = shift; - - my @pagers; - push @pagers, $self->pagers; - $self->{'pagers'} = \@pagers; - - if (IS_MSWin32) { - push @pagers, qw( more< less notepad ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - } - elsif (IS_VMS) { - push @pagers, qw( most more less type/page ); - } - elsif (IS_Dos) { - push @pagers, qw( less.exe more.com< ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - } - else { - if (IS_OS2) { - unshift @pagers, 'less', 'cmd /c more <'; - } - push @pagers, qw( more less pg view cat ); - unshift @pagers, $ENV{PAGER} if $ENV{PAGER}; - } - - if (IS_Cygwin) { - if (($pagers[0] eq 'less') || ($pagers[0] eq '/usr/bin/less')) { - unshift @pagers, '/usr/bin/less -isrR'; - } - } - - unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER}; - - return; -} - -#.......................................................................... - -sub page_module_file { - my($self, @found) = @_; - - # Security note: - # Don't ever just pass this off to anything like MSWin's "start.exe", - # since we might be calling on a .pl file, and we wouldn't want that - # to actually /execute/ the file that we just want to page thru! - # Also a consideration if one were to use a web browser as a pager; - # doing so could trigger the browser's MIME mapping for whatever - # it thinks .pm/.pl/whatever is. Probably just a (useless and - # annoying) "Save as..." dialog, but potentially executing the file - # in question -- particularly in the case of MSIE and it's, ahem, - # occasionally hazy distinction between OS-local extension - # associations, and browser-specific MIME mappings. - - if ($self->{'output_to_stdout'}) { - $self->aside("Sending unpaged output to STDOUT.\n"); - local $_; - my $any_error = 0; - foreach my $output (@found) { - unless( open(TMP, "<", $output) ) { # XXX 5.6ism - warn("Can't open $output: $!"); - $any_error = 1; - next; - } - while () { - print or die "Can't print to stdout: $!"; - } - close TMP or die "Can't close while $output: $!"; - $self->unlink_if_temp_file($output); - } - return $any_error; # successful - } - - foreach my $pager ( $self->pagers ) { - $self->aside("About to try calling $pager @found\n"); - if (system($pager, @found) == 0) { - $self->aside("Yay, it worked.\n"); - return 0; - } - $self->aside("That didn't work.\n"); - - # Odd -- when it fails, under Win32, this seems to neither - # return with a fail nor return with a success!! - # That's discouraging! - } - - $self->aside( - sprintf "Can't manage to find a way to page [%s] via pagers [%s]\n", - join(' ', @found), - join(' ', $self->pagers), - ); - - if (IS_VMS) { - DEBUG > 1 and print "Bailing out in a VMSish way.\n"; - eval q{ - use vmsish qw(status exit); - exit $?; - 1; - } or die; - } - - return 1; - # i.e., an UNSUCCESSFUL return value! -} - -#.......................................................................... - -sub check_file { - my($self, $dir, $file) = @_; - - unless( ref $self ) { - # Should never get called: - $Carp::Verbose = 1; - require Carp; - Carp::croak( join '', - "Crazy ", __PACKAGE__, " error:\n", - "check_file must be an object_method!\n", - "Aborting" - ); - } - - if(length $dir and not -d $dir) { - DEBUG > 3 and print " No dir $dir -- skipping.\n"; - return ""; - } - - if ($self->opt_m) { - return $self->minus_f_nocase($dir,$file); - } - - else { - my $path = $self->minus_f_nocase($dir,$file); - if( length $path and $self->containspod($path) ) { - DEBUG > 3 and print - " The file $path indeed looks promising!\n"; - return $path; - } - } - DEBUG > 3 and print " No good: $file in $dir\n"; - - return ""; -} - -#.......................................................................... - -sub containspod { - my($self, $file, $readit) = @_; - return 1 if !$readit && $file =~ /\.pod\z/i; - - - # Under cygwin the /usr/bin/perl is legal executable, but - # you cannot open a file with that name. It must be spelled - # out as "/usr/bin/perl.exe". - # - # The following if-case under cygwin prevents error - # - # $ perldoc perl - # Cannot open /usr/bin/perl: no such file or directory - # - # This would work though - # - # $ perldoc perl.pod - - if ( IS_Cygwin and -x $file and -f "$file.exe" ) - { - warn "Cygwin $file.exe search skipped\n" if DEBUG or $self->opt_D; - return 0; - } - - local($_); - open(TEST,"<", $file) or die "Can't open $file: $!"; # XXX 5.6ism - while () { - if (/^=head/) { - close(TEST) or die "Can't close $file: $!"; - return 1; - } - } - close(TEST) or die "Can't close $file: $!"; - return 0; -} - -#.......................................................................... - -sub maybe_diddle_INC { - my $self = shift; - - # Does this look like a module or extension directory? - - if (-f "Makefile.PL" || -f "Build.PL") { - - # Add "." and "lib" to @INC (if they exist) - eval q{ use lib qw(. lib); 1; } or die; - - # don't add if superuser - if ($< && $> && -d "blib") { # don't be looking too hard now! - eval q{ use blib; 1 }; - warn $@ if $@ && $self->opt_D; - } - } - - return; -} - -#.......................................................................... - -sub new_output_file { - my $self = shift; - my $outspec = $self->opt_d; # Yes, -d overrides all else! - # So don't call this twice per format-job! - - return $self->new_tempfile(@_) unless defined $outspec and length $outspec; - - # Otherwise open a write-handle on opt_d!f - - my $fh; - # If we are running before perl5.6.0, we can't autovivify - if ($] < 5.006) { - require Symbol; - $fh = Symbol::gensym(); - } - DEBUG > 3 and print "About to try writing to specified output file $outspec\n"; - die "Can't write-open $outspec: $!" - unless open($fh, ">", $outspec); # XXX 5.6ism - - DEBUG > 3 and print "Successfully opened $outspec\n"; - binmode($fh) if $self->{'output_is_binary'}; - return($fh, $outspec); -} - -#.......................................................................... - -sub useful_filename_bit { - # This tries to provide a meaningful bit of text to do with the query, - # such as can be used in naming the file -- since if we're going to be - # opening windows on temp files (as a "pager" may well do!) then it's - # better if the temp file's name (which may well be used as the window - # title) isn't ALL just random garbage! - # In other words "perldoc_LWPSimple_2371981429" is a better temp file - # name than "perldoc_2371981429". So this routine is what tries to - # provide the "LWPSimple" bit. - # - my $self = shift; - my $pages = $self->{'pages'} || return undef; - return undef unless @$pages; - - my $chunk = $pages->[0]; - return undef unless defined $chunk; - $chunk =~ s/:://g; - $chunk =~ s/\.\w+$//g; # strip any extension - if( $chunk =~ m/([^\#\\:\/\$]+)$/s ) { # get basename, if it's a file - $chunk = $1; - } else { - return undef; - } - $chunk =~ s/[^a-zA-Z0-9]+//g; # leave ONLY a-zA-Z0-9 things! - $chunk = substr($chunk, -10) if length($chunk) > 10; - return $chunk; -} - -#.......................................................................... - -sub new_tempfile { # $self->new_tempfile( [$suffix, [$infix] ] ) - my $self = shift; - - ++$Temp_Files_Created; - - if( IS_MSWin32 ) { - my @out = $self->MSWin_perldoc_tempfile(@_); - return @out if @out; - # otherwise fall thru to the normal stuff below... - } - - require File::Temp; - return File::Temp::tempfile(UNLINK => 1); -} - -#.......................................................................... - -sub page { # apply a pager to the output file - my ($self, $output, $output_to_stdout, @pagers) = @_; - if ($output_to_stdout) { - $self->aside("Sending unpaged output to STDOUT.\n"); - open(TMP, "<", $output) or die "Can't open $output: $!"; # XXX 5.6ism - local $_; - while () { - print or die "Can't print to stdout: $!"; - } - close TMP or die "Can't close while $output: $!"; - $self->unlink_if_temp_file($output); - } else { - # On VMS, quoting prevents logical expansion, and temp files with no - # extension get the wrong default extension (such as .LIS for TYPE) - - $output = VMS::Filespec::rmsexpand($output, '.') if IS_VMS; - - $output =~ s{/}{\\}g if IS_MSWin32 || IS_Dos; - # Altho "/" under MSWin is in theory good as a pathsep, - # many many corners of the OS don't like it. So we - # have to force it to be "\" to make everyone happy. - - foreach my $pager (@pagers) { - $self->aside("About to try calling $pager $output\n"); - if (IS_VMS) { - last if system("$pager $output") == 0; - } else { - last if system("$pager \"$output\"") == 0; - } - } - } - return; -} - -#.......................................................................... - -sub searchfor { - my($self, $recurse,$s,@dirs) = @_; - $s =~ s!::!/!g; - $s = VMS::Filespec::unixify($s) if IS_VMS; - return $s if -f $s && $self->containspod($s); - $self->aside( "Looking for $s in @dirs\n" ); - my $ret; - my $i; - my $dir; - $self->{'target'} = (splitdir $s)[-1]; # XXX: why not use File::Basename? - for ($i=0; $i<@dirs; $i++) { - $dir = $dirs[$i]; - next unless -d $dir; - ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if IS_VMS; - if ( (! $self->opt_m && ( $ret = $self->check_file($dir,"$s.pod"))) - or ( $ret = $self->check_file($dir,"$s.pm")) - or ( $ret = $self->check_file($dir,$s)) - or ( IS_VMS and - $ret = $self->check_file($dir,"$s.com")) - or ( IS_OS2 and - $ret = $self->check_file($dir,"$s.cmd")) - or ( (IS_MSWin32 or IS_Dos or IS_OS2) and - $ret = $self->check_file($dir,"$s.bat")) - or ( $ret = $self->check_file("$dir/pod","$s.pod")) - or ( $ret = $self->check_file("$dir/pod",$s)) - or ( $ret = $self->check_file("$dir/pods","$s.pod")) - or ( $ret = $self->check_file("$dir/pods",$s)) - ) { - DEBUG > 1 and print " Found $ret\n"; - return $ret; - } - - if ($recurse) { - opendir(D,$dir) or die "Can't opendir $dir: $!"; - my @newdirs = map catfile($dir, $_), grep { - not /^\.\.?\z/s and - not /^auto\z/s and # save time! don't search auto dirs - -d catfile($dir, $_) - } readdir D; - closedir(D) or die "Can't closedir $dir: $!"; - next unless @newdirs; - # what a wicked map! - @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if IS_VMS; - $self->aside( "Also looking in @newdirs\n" ); - push(@dirs,@newdirs); - } - } - return (); -} - -#.......................................................................... -{ - my $already_asserted; - sub assert_closing_stdout { - my $self = shift; - - return if $already_asserted; - - eval q~ END { close(STDOUT) || die "Can't close STDOUT: $!" } ~; - # What for? to let the pager know that nothing more will come? - - die $@ if $@; - $already_asserted = 1; - return; - } -} - -#.......................................................................... - -sub tweak_found_pathnames { - my($self, $found) = @_; - if (IS_MSWin32) { - foreach (@$found) { s,/,\\,g } - } - return; -} - -#.......................................................................... -# : : : : : : : : : -#.......................................................................... - -sub am_taint_checking { - my $self = shift; - die "NO ENVIRONMENT?!?!" unless keys %ENV; # reset iterator along the way - my($k,$v) = each %ENV; - return is_tainted($v); -} - -#.......................................................................... - -sub is_tainted { # just a function - my $arg = shift; - my $nada = substr($arg, 0, 0); # zero-length! - local $@; # preserve the caller's version of $@ - eval { eval "# $nada" }; - return length($@) != 0; -} - -#.......................................................................... - -sub drop_privs_maybe { - my $self = shift; - - # Attempt to drop privs if we should be tainting and aren't - if (!(IS_VMS || IS_MSWin32 || IS_Dos - || IS_OS2 - ) - && ($> == 0 || $< == 0) - && !$self->am_taint_checking() - ) { - my $id = eval { getpwnam("nobody") }; - $id = eval { getpwnam("nouser") } unless defined $id; - $id = -2 unless defined $id; - # - # According to Stevens' APUE and various - # (BSD, Solaris, HP-UX) man pages, setting - # the real uid first and effective uid second - # is the way to go if one wants to drop privileges, - # because if one changes into an effective uid of - # non-zero, one cannot change the real uid any more. - # - # Actually, it gets even messier. There is - # a third uid, called the saved uid, and as - # long as that is zero, one can get back to - # uid of zero. Setting the real-effective *twice* - # helps in *most* systems (FreeBSD and Solaris) - # but apparently in HP-UX even this doesn't help: - # the saved uid stays zero (apparently the only way - # in HP-UX to change saved uid is to call setuid() - # when the effective uid is zero). - # - eval { - $< = $id; # real uid - $> = $id; # effective uid - $< = $id; # real uid - $> = $id; # effective uid - }; - if( !$@ && $< && $> ) { - DEBUG and print "OK, I dropped privileges.\n"; - } elsif( $self->opt_U ) { - DEBUG and print "Couldn't drop privileges, but in -U mode, so feh." - } else { - DEBUG and print "Hm, couldn't drop privileges. Ah well.\n"; - # We used to die here; but that seemed pointless. - } - } - return; -} - -#.......................................................................... - -1; - -__END__ - -=head1 NAME - -Pod::Perldoc - Look up Perl documentation in Pod format. - -=head1 SYNOPSIS - - use Pod::Perldoc (); - - Pod::Perldoc->run(); - -=head1 DESCRIPTION - -The guts of L utility. - -=head1 SEE ALSO - -L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002-2007 Sean M. Burke. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut - -# -# -# Perldoc -- look up a piece of documentation in .pod format that -# is embedded in the perl installation tree. -# -#~~~~~~ -# -# See ChangeLog in CPAN dist for Pod::Perldoc for later notes. -# -# Version 3.01: Sun Nov 10 21:38:09 MST 2002 -# Sean M. Burke -# Massive refactoring and code-tidying. -# Now it's a module(-family)! -# Formatter-specific stuff pulled out into Pod::Perldoc::To(Whatever).pm -# Added -T, -d, -o, -M, -w. -# Added some improved MSWin funk. -# -#~~~~~~ -# -# Version 2.05: Sat Oct 12 16:09:00 CEST 2002 -# Hugo van der Sanden -# Made -U the default, based on patch from Simon Cozens -# Version 2.04: Sun Aug 18 13:27:12 BST 2002 -# Randy W. Sims -# allow -n to enable nroff under Win32 -# Version 2.03: Sun Apr 23 16:56:34 BST 2000 -# Hugo van der Sanden -# don't die when 'use blib' fails -# Version 2.02: Mon Mar 13 18:03:04 MST 2000 -# Tom Christiansen -# Added -U insecurity option -# Version 2.01: Sat Mar 11 15:22:33 MST 2000 -# Tom Christiansen , querulously. -# Security and correctness patches. -# What a twisted bit of distasteful spaghetti code. -# Version 2.0: ???? -# -#~~~~~~ -# -# Version 1.15: Tue Aug 24 01:50:20 EST 1999 -# Charles Wilson -# changed /pod/ directory to /pods/ for cygwin -# to support cygwin/win32 -# Version 1.14: Wed Jul 15 01:50:20 EST 1998 -# Robin Barker -# -strict, -w cleanups -# Version 1.13: Fri Feb 27 16:20:50 EST 1997 -# Gurusamy Sarathy -# -doc tweaks for -F and -X options -# Version 1.12: Sat Apr 12 22:41:09 EST 1997 -# Gurusamy Sarathy -# -various fixes for win32 -# Version 1.11: Tue Dec 26 09:54:33 EST 1995 -# Kenneth Albanowski -# -added Charles Bailey's further VMS patches, and -u switch -# -added -t switch, with pod2text support -# -# Version 1.10: Thu Nov 9 07:23:47 EST 1995 -# Kenneth Albanowski -# -added VMS support -# -added better error recognition (on no found pages, just exit. On -# missing nroff/pod2man, just display raw pod.) -# -added recursive/case-insensitive matching (thanks, Andreas). This -# slows things down a bit, unfortunately. Give a precise name, and -# it'll run faster. -# -# Version 1.01: Tue May 30 14:47:34 EDT 1995 -# Andy Dougherty -# -added pod documentation. -# -added PATH searching. -# -added searching pod/ subdirectory (mainly to pick up perlfunc.pod -# and friends. -# -#~~~~~~~ -# -# TODO: -# -# Cache the directories read during sloppy match -# (To disk, or just in-memory?) -# -# Backport this to perl 5.005? -# -# Implement at least part of the "perlman" interface described -# in Programming Perl 3e? diff --git a/lib/Pod/Perldoc/BaseTo.pm b/lib/Pod/Perldoc/BaseTo.pm deleted file mode 100644 index 29a3b7d108..0000000000 --- a/lib/Pod/Perldoc/BaseTo.pm +++ /dev/null @@ -1,81 +0,0 @@ - -require 5; -package Pod::Perldoc::BaseTo; -use strict; -use warnings; - -sub is_pageable { '' } -sub write_with_binmode { 1 } - -sub output_extension { 'txt' } # override in subclass! - -# sub new { my $self = shift; ... } -# sub parse_from_file( my($class, $in, $out) = ...; ... } - -#sub new { return bless {}, ref($_[0]) || $_[0] } - -sub _perldoc_elem { - my($self, $name) = splice @_,0,2; - if(@_) { - $self->{$name} = $_[0]; - } else { - $self->{$name}; - } -} - - -1; - -__END__ - -=head1 NAME - -Pod::Perldoc::BaseTo - Base for Pod::Perldoc formatters - -=head1 SYNOPSIS - - package Pod::Perldoc::ToMyFormat; - - use base qw( Pod::Perldoc::BaseTo ); - ... - -=head1 DESCRIPTION - -This package is meant as a base of Pod::Perldoc formatters, -like L, L, etc. - -It provides default implementations for the methods - - is_pageable - write_with_binmode - output_extension - _perldoc_elem - -The concrete formatter must implement - - new - parse_from_file - -=head1 SEE ALSO - -L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002-2007 Sean M. Burke. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut diff --git a/lib/Pod/Perldoc/GetOptsOO.pm b/lib/Pod/Perldoc/GetOptsOO.pm deleted file mode 100644 index fa83fb74cc..0000000000 --- a/lib/Pod/Perldoc/GetOptsOO.pm +++ /dev/null @@ -1,148 +0,0 @@ - -require 5; -package Pod::Perldoc::GetOptsOO; -use strict; - -# Rather like Getopt::Std's getopts -# Call Pod::Perldoc::GetOptsOO::getopts($object, \@ARGV, $truth) -# Given -n, if there's a opt_n_with, it'll call $object->opt_n_with( ARGUMENT ) -# (e.g., "-n foo" => $object->opt_n_with('foo'). Ditto "-nfoo") -# Otherwise (given -n) if there's an opt_n, we'll call it $object->opt_n($truth) -# (Truth defaults to 1) -# Otherwise we try calling $object->handle_unknown_option('n') -# (and we increment the error count by the return value of it) -# If there's no handle_unknown_option, then we just warn, and then increment -# the error counter -# -# The return value of Pod::Perldoc::GetOptsOO::getopts is true if no errors, -# otherwise it's false. -# -## sburke@cpan.org 2002-10-31 - -BEGIN { # Make a DEBUG constant ASAP - *DEBUG = defined( &Pod::Perldoc::DEBUG ) - ? \&Pod::Perldoc::DEBUG - : sub(){10}; -} - - -sub getopts { - my($target, $args, $truth) = @_; - - $args ||= \@ARGV; - - $target->aside( - "Starting switch processing. Scanning arguments [@$args]\n" - ) if $target->can('aside'); - - return unless @$args; - - $truth = 1 unless @_ > 2; - - DEBUG > 3 and print " Truth is $truth\n"; - - - my $error_count = 0; - - while( @$args and ($_ = $args->[0]) =~ m/^-(.)(.*)/s ) { - my($first,$rest) = ($1,$2); - if ($_ eq '--') { # early exit if "--" - shift @$args; - last; - } - my $method = "opt_${first}_with"; - if( $target->can($method) ) { # it's argumental - if($rest eq '') { # like -f bar - shift @$args; - warn "Option $first needs a following argument!\n" unless @$args; - $rest = shift @$args; - } else { # like -fbar (== -f bar) - shift @$args; - } - - DEBUG > 3 and print " $method => $rest\n"; - $target->$method( $rest ); - - # Otherwise, it's not argumental... - } else { - - if( $target->can( $method = "opt_$first" ) ) { - DEBUG > 3 and print " $method is true ($truth)\n"; - $target->$method( $truth ); - - # Otherwise it's an unknown option... - - } elsif( $target->can('handle_unknown_option') ) { - DEBUG > 3 - and print " calling handle_unknown_option('$first')\n"; - - $error_count += ( - $target->handle_unknown_option( $first ) || 0 - ); - - } else { - ++$error_count; - warn "Unknown option: $first\n"; - } - - if($rest eq '') { # like -f - shift @$args - } else { # like -fbar (== -f -bar ) - DEBUG > 2 and print " Setting args->[0] to \"-$rest\"\n"; - $args->[0] = "-$rest"; - } - } - } - - - $target->aside( - "Ending switch processing. Args are [@$args] with $error_count errors.\n" - ) if $target->can('aside'); - - $error_count == 0; -} - -1; - -__END__ - -=head1 NAME - -Pod::Perldoc::GetOptsOO - Customized option parser for Pod::Perldoc - -=head1 SYNOPSIS - - use Pod::Perldoc::GetOptsOO (); - - Pod::Perldoc::GetOptsOO::getopts( $obj, \@args, $truth ) - or die "wrong usage"; - - -=head1 DESCRIPTION - -Implements a customized option parser used for -L. - -=head1 SEE ALSO - - Pod::Perldoc - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002-2007 Sean M. Burke. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut diff --git a/lib/Pod/Perldoc/ToChecker.pm b/lib/Pod/Perldoc/ToChecker.pm deleted file mode 100644 index 10870109e6..0000000000 --- a/lib/Pod/Perldoc/ToChecker.pm +++ /dev/null @@ -1,75 +0,0 @@ - -require 5; -package Pod::Perldoc::ToChecker; -use strict; -use warnings; -use vars qw(@ISA); - -# Pick our superclass... -# -eval 'require Pod::Simple::Checker'; -if($@) { - require Pod::Checker; - @ISA = ('Pod::Checker'); -} else { - @ISA = ('Pod::Simple::Checker'); -} - -sub is_pageable { 1 } -sub write_with_binmode { 0 } -sub output_extension { 'txt' } - -sub if_zero_length { - my( $self, $file, $tmp, $tmpfd ) = @_; - print "No Pod errors in $file\n"; -} - - -1; - -__END__ - -=head1 NAME - -Pod::Perldoc::ToChecker - let Perldoc check Pod for errors - -=head1 SYNOPSIS - - % perldoc -o checker SomeFile.pod - No Pod errors in SomeFile.pod - (or an error report) - -=head1 DESCRIPTION - -This is a "plug-in" class that allows Perldoc to use -Pod::Simple::Checker as a "formatter" class (or if that is -not available, then Pod::Checker), to check for errors in a given -Pod file. - -This is actually a Pod::Simple::Checker (or Pod::Checker) subclass, and -inherits all its options. - -=head1 SEE ALSO - -L, L, L, L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002 Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut - diff --git a/lib/Pod/Perldoc/ToMan.pm b/lib/Pod/Perldoc/ToMan.pm deleted file mode 100644 index 09b0e81737..0000000000 --- a/lib/Pod/Perldoc/ToMan.pm +++ /dev/null @@ -1,190 +0,0 @@ - -require 5; -package Pod::Perldoc::ToMan; -use strict; -use warnings; - -# This class is unlike ToText.pm et al, because we're NOT paging thru -# the output in our particular format -- we make the output and -# then we run nroff (or whatever) on it, and then page thru the -# (plaintext) output of THAT! - -use base qw(Pod::Perldoc::BaseTo); -sub is_pageable { 1 } -sub write_with_binmode { 0 } -sub output_extension { 'txt' } - -sub __filter_nroff { shift->_perldoc_elem('__filter_nroff' , @_) } -sub __nroffer { shift->_perldoc_elem('__nroffer' , @_) } -sub __bindir { shift->_perldoc_elem('__bindir' , @_) } -sub __pod2man { shift->_perldoc_elem('__pod2man' , @_) } -sub __output_file { shift->_perldoc_elem('__output_file' , @_) } - -sub center { shift->_perldoc_elem('center' , @_) } -sub date { shift->_perldoc_elem('date' , @_) } -sub fixed { shift->_perldoc_elem('fixed' , @_) } -sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } -sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } -sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } -sub quotes { shift->_perldoc_elem('quotes' , @_) } -sub release { shift->_perldoc_elem('release' , @_) } -sub section { shift->_perldoc_elem('section' , @_) } - -sub new { return bless {}, ref($_[0]) || $_[0] } - -use File::Spec::Functions qw(catfile); - -sub parse_from_file { - my $self = shift; - my($file, $outfh) = @_; - - my $render = $self->{'__nroffer'} || die "no nroffer set!?"; - - # turn the switches into CLIs - my $switches = join ' ', - map qq{"--$_=$self->{$_}"}, - grep !m/^_/s, - keys %$self - ; - - my $pod2man = - catfile( - ($self->{'__bindir'} || die "no bindir set?!" ), - ($self->{'__pod2man'} || die "no pod2man set?!" ), - ) - ; - unless(-e $pod2man) { - # This is rarely needed, I think. - $pod2man = $self->{'__pod2man'} || die "no pod2man set?!"; - die "Can't find a pod2man?! (". $self->{'__pod2man'} .")\nAborting" - unless -e $pod2man; - } - - my $command = "$pod2man $switches --lax $file | $render -man"; - # no temp file, just a pipe! - - # Thanks to Brendan O'Dea for contributing the following block - if(Pod::Perldoc::IS_Linux and -t STDOUT - and my ($cols) = `stty -a` =~ m/\bcolumns\s+(\d+)/ - ) { - my $c = $cols * 39 / 40; - $cols = $c > $cols - 2 ? $c : $cols -2; - $command .= ' -rLL=' . (int $c) . 'n' if $cols > 80; - } - - if(Pod::Perldoc::IS_Cygwin) { - $command .= ' -c'; - } - - # I hear persistent reports that adding a -c switch to $render - # solves many people's problems. But I also hear that some mans - # don't have a -c switch, so that unconditionally adding it here - # would presumably be a Bad Thing -- sburke@cpan.org - - $command .= " | col -x" if Pod::Perldoc::IS_HPUX; - - defined(&Pod::Perldoc::DEBUG) - and Pod::Perldoc::DEBUG() - and print "About to run $command\n"; - ; - - my $rslt = `$command`; - - my $err; - - if( $self->{'__filter_nroff'} ) { - defined(&Pod::Perldoc::DEBUG) - and &Pod::Perldoc::DEBUG() - and print "filter_nroff is set, so filtering...\n"; - $rslt = $self->___Do_filter_nroff($rslt); - } else { - defined(&Pod::Perldoc::DEBUG) - and Pod::Perldoc::DEBUG() - and print "filter_nroff isn't set, so not filtering.\n"; - } - - if (($err = $?)) { - defined(&Pod::Perldoc::DEBUG) - and Pod::Perldoc::DEBUG() - and print "Nonzero exit ($?) while running $command.\n", - "Falling back to Pod::Perldoc::ToPod\n ", - ; - # A desperate fallthru: - require Pod::Perldoc::ToPod; - return Pod::Perldoc::ToPod->new->parse_from_file(@_); - - } else { - print $outfh $rslt - or die "Can't print to $$self{__output_file}: $!"; - } - - return; -} - - -sub ___Do_filter_nroff { - my $self = shift; - my @data = split /\n{2,}/, shift; - - shift @data while @data and $data[0] !~ /\S/; # Go to header - shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header - pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like - # 28/Jan/99 perl 5.005, patch 53 1 - join "\n\n", @data; -} - -1; - -__END__ - -=head1 NAME - -Pod::Perldoc::ToMan - let Perldoc render Pod as man pages - -=head1 SYNOPSIS - - perldoc -o man Some::Modulename - -=head1 DESCRIPTION - -This is a "plug-in" class that allows Perldoc to use -Pod::Man and C for reading Pod pages. - -The following options are supported: center, date, fixed, fixedbold, -fixeditalic, fixedbolditalic, quotes, release, section - -(Those options are explained in L.) - -For example: - - perldoc -o man -w center:Pod Some::Modulename - -=head1 CAVEAT - -This module may change to use a different pod-to-nroff formatter class -in the future, and this may change what options are supported. - -=head1 SEE ALSO - -L, L, L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002,3,4 Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut - diff --git a/lib/Pod/Perldoc/ToNroff.pm b/lib/Pod/Perldoc/ToNroff.pm deleted file mode 100644 index 991c1e3269..0000000000 --- a/lib/Pod/Perldoc/ToNroff.pm +++ /dev/null @@ -1,103 +0,0 @@ - -require 5; -package Pod::Perldoc::ToNroff; -use strict; -use warnings; - -# This is unlike ToMan.pm in that it emits the raw nroff source! - -use base qw(Pod::Perldoc::BaseTo); - -sub is_pageable { 1 } # well, if you ask for it... -sub write_with_binmode { 0 } -sub output_extension { 'man' } - -use Pod::Man (); - -sub center { shift->_perldoc_elem('center' , @_) } -sub date { shift->_perldoc_elem('date' , @_) } -sub fixed { shift->_perldoc_elem('fixed' , @_) } -sub fixedbold { shift->_perldoc_elem('fixedbold' , @_) } -sub fixeditalic { shift->_perldoc_elem('fixeditalic' , @_) } -sub fixedbolditalic { shift->_perldoc_elem('fixedbolditalic', @_) } -sub quotes { shift->_perldoc_elem('quotes' , @_) } -sub release { shift->_perldoc_elem('release' , @_) } -sub section { shift->_perldoc_elem('section' , @_) } - -sub new { return bless {}, ref($_[0]) || $_[0] } - -sub parse_from_file { - my $self = shift; - my $file = $_[0]; - - my @options = - map {; $_, $self->{$_} } - grep !m/^_/s, - keys %$self - ; - - defined(&Pod::Perldoc::DEBUG) - and Pod::Perldoc::DEBUG() - and print "About to call new Pod::Man ", - $Pod::Man::VERSION ? "(v$Pod::Man::VERSION) " : '', - "with options: ", - @options ? "[@options]" : "(nil)", "\n"; - ; - - Pod::Man->new(@options)->parse_from_file(@_); -} - -1; -__END__ - -=head1 NAME - -Pod::Perldoc::ToNroff - let Perldoc convert Pod to nroff - -=head1 SYNOPSIS - - perldoc -o nroff -d something.3 Some::Modulename - -=head1 DESCRIPTION - -This is a "plug-in" class that allows Perldoc to use -Pod::Man as a formatter class. - -The following options are supported: center, date, fixed, fixedbold, -fixeditalic, fixedbolditalic, quotes, release, section - -Those options are explained in L. - -For example: - - perldoc -o nroff -w center:Pod -d something.3 Some::Modulename - -=head1 CAVEAT - -This module may change to use a different pod-to-nroff formatter class -in the future, and this may change what options are supported. - -=head1 SEE ALSO - -L, L, L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002 Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut - diff --git a/lib/Pod/Perldoc/ToPod.pm b/lib/Pod/Perldoc/ToPod.pm deleted file mode 100644 index c3173d4370..0000000000 --- a/lib/Pod/Perldoc/ToPod.pm +++ /dev/null @@ -1,93 +0,0 @@ - -# This class is just a hack to act as a "formatter" for -# actually unformatted Pod. -# -# Note that this isn't the same as just passing thru whatever -# we're given -- we pass thru only the pod source, and suppress -# the Perl code (or whatever non-pod stuff is in the source file). - - -require 5; -package Pod::Perldoc::ToPod; -use strict; -use warnings; - -use base qw(Pod::Perldoc::BaseTo); -sub is_pageable { 1 } -sub write_with_binmode { 0 } -sub output_extension { 'pod' } - -sub new { return bless {}, ref($_[0]) || $_[0] } - -sub parse_from_file { - my( $self, $in, $outfh ) = @_; - - open(IN, "<", $in) or die "Can't read-open $in: $!\nAborting"; - - my $cut_mode = 1; - - # A hack for finding things between =foo and =cut, inclusive - local $_; - while () { - if( m/^=(\w+)/s ) { - if($cut_mode = ($1 eq 'cut')) { - print $outfh "\n=cut\n\n"; - # Pass thru the =cut line with some harmless - # (and occasionally helpful) padding - } - } - next if $cut_mode; - print $outfh $_ or die "Can't print to $outfh: $!"; - } - - close IN or die "Can't close $in: $!"; - return; -} - -1; -__END__ - -=head1 NAME - -Pod::Perldoc::ToPod - let Perldoc render Pod as ... Pod! - -=head1 SYNOPSIS - - perldoc -opod Some::Modulename - -(That's currently the same as the following:) - - perldoc -u Some::Modulename - -=head1 DESCRIPTION - -This is a "plug-in" class that allows Perldoc to display Pod source as -itself! Pretty Zen, huh? - -Currently this class works by just filtering out the non-Pod stuff from -a given input file. - -=head1 SEE ALSO - -L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002 Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut - diff --git a/lib/Pod/Perldoc/ToRtf.pm b/lib/Pod/Perldoc/ToRtf.pm deleted file mode 100644 index 14d419fc31..0000000000 --- a/lib/Pod/Perldoc/ToRtf.pm +++ /dev/null @@ -1,88 +0,0 @@ - -require 5; -package Pod::Perldoc::ToRtf; -use strict; -use warnings; -use vars qw($VERSION); - -use base qw( Pod::Simple::RTF ); - -$VERSION # so that ->VERSION is happy -# stop CPAN from seeing this - = -$Pod::Simple::RTF::VERSION; - - -sub is_pageable { 0 } -sub write_with_binmode { 0 } -sub output_extension { 'rtf' } - -sub page_for_perldoc { - my($self, $tempfile, $perldoc) = @_; - return unless $perldoc->IS_MSWin32; - - my $rtf_pager = $ENV{'RTFREADER'} || 'write.exe'; - - $perldoc->aside( "About to launch <\"$rtf_pager\" \"$tempfile\">\n" ); - - return 1 if system( qq{"$rtf_pager"}, qq{"$tempfile"} ) == 0; - return 0; -} - -1; -__END__ - -=head1 NAME - -Pod::Perldoc::ToRtf - let Perldoc render Pod as RTF - -=head1 SYNOPSIS - - perldoc -o rtf Some::Modulename - -=head1 DESCRIPTION - -This is a "plug-in" class that allows Perldoc to use -Pod::Simple::RTF as a formatter class. - -This is actually a Pod::Simple::RTF subclass, and inherits -all its options. - -You have to have Pod::Simple::RTF installed (from the Pod::Simple dist), -or this module won't work. - -If Perldoc is running under MSWin and uses this class as a formatter, -the output will be opened with F or whatever program is -specified in the environment variable C. For example, to -specify that RTF files should be opened the same as they are when you -double-click them, you would do C in your -F. - -Handy tip: put C in your F -and that will set this class as the default formatter to run when -you do C. - -=head1 SEE ALSO - -L, L, L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002 Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut - diff --git a/lib/Pod/Perldoc/ToText.pm b/lib/Pod/Perldoc/ToText.pm deleted file mode 100644 index 7d1784cd59..0000000000 --- a/lib/Pod/Perldoc/ToText.pm +++ /dev/null @@ -1,95 +0,0 @@ - -require 5; -package Pod::Perldoc::ToText; -use strict; -use warnings; - -use base qw(Pod::Perldoc::BaseTo); - -sub is_pageable { 1 } -sub write_with_binmode { 0 } -sub output_extension { 'txt' } - -use Pod::Text (); - -sub alt { shift->_perldoc_elem('alt' , @_) } -sub indent { shift->_perldoc_elem('indent' , @_) } -sub loose { shift->_perldoc_elem('loose' , @_) } -sub quotes { shift->_perldoc_elem('quotes' , @_) } -sub sentence { shift->_perldoc_elem('sentence', @_) } -sub width { shift->_perldoc_elem('width' , @_) } - -sub new { return bless {}, ref($_[0]) || $_[0] } - -sub parse_from_file { - my $self = shift; - - my @options = - map {; $_, $self->{$_} } - grep !m/^_/s, - keys %$self - ; - - defined(&Pod::Perldoc::DEBUG) - and Pod::Perldoc::DEBUG() - and print "About to call new Pod::Text ", - $Pod::Text::VERSION ? "(v$Pod::Text::VERSION) " : '', - "with options: ", - @options ? "[@options]" : "(nil)", "\n"; - ; - - Pod::Text->new(@options)->parse_from_file(@_); -} - -1; - -=head1 NAME - -Pod::Perldoc::ToText - let Perldoc render Pod as plaintext - -=head1 SYNOPSIS - - perldoc -o text Some::Modulename - -=head1 DESCRIPTION - -This is a "plug-in" class that allows Perldoc to use -Pod::Text as a formatter class. - -It supports the following options, which are explained in -L: alt, indent, loose, quotes, sentence, width - -For example: - - perldoc -o text -w indent:5 Some::Modulename - -=head1 CAVEAT - -This module may change to use a different text formatter class in the -future, and this may change what options are supported. - -=head1 SEE ALSO - -L, L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002 Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - - -=cut - diff --git a/lib/Pod/Perldoc/ToTk.pm b/lib/Pod/Perldoc/ToTk.pm deleted file mode 100644 index 1562ec8bb3..0000000000 --- a/lib/Pod/Perldoc/ToTk.pm +++ /dev/null @@ -1,132 +0,0 @@ - -require 5; -package Pod::Perldoc::ToTk; -use strict; -use warnings; - -use base qw(Pod::Perldoc::BaseTo); - -sub is_pageable { 1 } -sub write_with_binmode { 0 } -sub output_extension { 'txt' } # doesn't matter -sub if_zero_length { } # because it will be 0-length! -sub new { return bless {}, ref($_[0]) || $_[0] } - -# TODO: document these and their meanings... -sub tree { shift->_perldoc_elem('tree' , @_) } -sub tk_opt { shift->_perldoc_elem('tk_opt' , @_) } -sub forky { shift->_perldoc_elem('forky' , @_) } - -use Pod::Perldoc (); -use File::Spec::Functions qw(catfile); - -use Tk; -die join '', __PACKAGE__, " doesn't work nice with Tk.pm verison $Tk::VERSION" - if $Tk::VERSION eq '800.003'; - -BEGIN { eval { require Tk::FcyEntry; }; }; -use Tk::Pod; - -# The following was adapted from "tkpod" in the Tk-Pod dist. - -sub parse_from_file { - - my($self, $Input_File) = @_; - if($self->{'forky'}) { - return if fork; # i.e., parent process returns - } - - $Input_File =~ s{\\}{/}g - if Pod::Perldoc::IS_MSWin32 or Pod::Perldoc::IS_Dos - # and maybe OS/2 - ; - - my($tk_opt, $tree); - $tree = $self->{'tree' }; - $tk_opt = $self->{'tk_opt'}; - - #require Tk::ErrorDialog; - - # Add 'Tk' subdirectories to search path so, e.g., - # 'Scrolled' will find doc in 'Tk/Scrolled' - - if( $tk_opt ) { - push @INC, grep -d $_, map catfile($_,'Tk'), @INC; - } - - my $mw = MainWindow->new(); - #eval 'use blib "/home/e/eserte/src/perl/Tk-App";require Tk::App::Debug'; - $mw->withdraw; - - # CDE use Font Settings if available - my $ufont = $mw->optionGet('userFont','UserFont'); # fixed width - my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional - if (defined($ufont) and defined($sfont)) { - foreach ($ufont, $sfont) { s/:$//; }; - $mw->optionAdd('*Font', $sfont); - $mw->optionAdd('*Entry.Font', $ufont); - $mw->optionAdd('*Text.Font', $ufont); - } - - $mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0); - - $mw->Pod( - '-file' => $Input_File, - (($Tk::Pod::VERSION >= 4) ? ('-tree' => $tree) : ()) - )->focusNext; - - # xxx dirty but it works. A simple $mw->destroy if $mw->children - # does not work because Tk::ErrorDialogs could be created. - # (they are withdrawn after Ok instead of destory'ed I guess) - - if ($mw->children) { - $mw->repeat(1000, sub { - # ErrorDialog is withdrawn not deleted :-( - foreach ($mw->children) { - return if "$_" =~ /^Tk::Pod/ # ->isa('Tk::Pod') - } - $mw->destroy; - }); - } else { - $mw->destroy; - } - #$mw->WidgetDump; - MainLoop(); - - exit if $self->{'forky'}; # we were the child! so exit now! - return; -} - -1; -__END__ - - -=head1 NAME - -Pod::Perldoc::ToTk - let Perldoc use Tk::Pod to render Pod - -=head1 SYNOPSIS - - perldoc -o tk Some::Modulename & - -=head1 DESCRIPTION - -This is a "plug-in" class that allows Perldoc to use -Tk::Pod as a formatter class. - -You have to have installed Tk::Pod first, or this class won't load. - -=head1 SEE ALSO - -L, L - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke C, with significant portions copied from -F in the Tk::Pod dist, by Nick Ing-Simmons, Slaven Rezic, et al. - -=cut - diff --git a/lib/Pod/Perldoc/ToXml.pm b/lib/Pod/Perldoc/ToXml.pm deleted file mode 100644 index 439e736c20..0000000000 --- a/lib/Pod/Perldoc/ToXml.pm +++ /dev/null @@ -1,66 +0,0 @@ - -require 5; -package Pod::Perldoc::ToXml; -use strict; -use warnings; -use vars qw($VERSION); - -use base qw( Pod::Simple::XMLOutStream ); - -$VERSION # so that ->VERSION is happy -# stop CPAN from seeing this - = -$Pod::Simple::XMLOutStream::VERSION; - - -sub is_pageable { 0 } -sub write_with_binmode { 0 } -sub output_extension { 'xml' } - -1; -__END__ - -=head1 NAME - -Pod::Perldoc::ToXml - let Perldoc render Pod as XML - -=head1 SYNOPSIS - - perldoc -o xml -d out.xml Some::Modulename - -=head1 DESCRIPTION - -This is a "plug-in" class that allows Perldoc to use -Pod::Simple::XMLOutStream as a formatter class. - -This is actually a Pod::Simple::XMLOutStream subclass, and inherits -all its options. - -You have to have installed Pod::Simple::XMLOutStream (from the Pod::Simple -dist), or this class won't work. - - -=head1 SEE ALSO - -L, L, L - -=head1 COPYRIGHT AND DISCLAIMERS - -Copyright (c) 2002 Sean M. Burke. All rights reserved. - -This library is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -This program is distributed in the hope that it will be useful, but -without any warranty; without even the implied warranty of -merchantability or fitness for a particular purpose. - -=head1 AUTHOR - -Current maintainer: Adriano R. Ferreira - -Past contributions from: -Sean M. Burke - -=cut - diff --git a/lib/Pod/Perldoc/t/01_about_verbose.t b/lib/Pod/Perldoc/t/01_about_verbose.t deleted file mode 100644 index eb2f411fe9..0000000000 --- a/lib/Pod/Perldoc/t/01_about_verbose.t +++ /dev/null @@ -1,87 +0,0 @@ - -require 5; -# Time-stamp: "2004-04-09 18:02:36 ADT" - -# Summary of, well, things. - -use Test; -BEGIN {plan tests => 2}; - -ok 1; - -use Pod::Perldoc; - -#chdir "t" if -e "t"; - -{ - my @out; - push @out, - "\n\nPerl v", - defined($^V) ? sprintf('%vd', $^V) : $], - " under $^O ", - (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber()) - ? ("(Win32::BuildNumber ", &Win32::BuildNumber(), ")") : (), - (defined $MacPerl::Version) - ? ("(MacPerl version $MacPerl::Version)") : (), - "\n" - ; - - # Ugly code to walk the symbol tables: - my %v; - my @stack = (''); # start out in %:: - my $this; - my $count = 0; - my $pref; - while(@stack) { - $this = shift @stack; - die "Too many packages?" if ++$count > 1000; - next if exists $v{$this}; - next if $this eq 'main'; # %main:: is %:: - - #print "Peeking at $this => ${$this . '::VERSION'}\n"; - - if(defined ${$this . '::VERSION'} ) { - $v{$this} = ${$this . '::VERSION'} - } elsif( - defined *{$this . '::ISA'} or defined &{$this . '::import'} - or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . "::"}) - # If it has an ISA, an import, or any subs... - ) { - # It's a class/module with no version. - $v{$this} = undef; - } else { - # It's probably an unpopulated package. - ## $v{$this} = '...'; - } - - $pref = length($this) ? "$this\::" : ''; - push @stack, map m/^(.+)::$/ ? "$pref$1" : (), keys %{$this . '::'}; - #print "Stack: @stack\n"; - } - push @out, " Modules in memory:\n"; - delete @v{'', '[none]'}; - foreach my $p (sort {lc($a) cmp lc($b)} keys %v) { - $indent = ' ' x (2 + ($p =~ tr/:/:/)); - push @out, ' ', $indent, $p, defined($v{$p}) ? " v$v{$p};\n" : ";\n"; - } - push @out, sprintf "[at %s (local) / %s (GMT)]\n", - scalar(gmtime), scalar(localtime); - my $x = join '', @out; - $x =~ s/^/#/mg; - print $x; -} - -print "# Running", - (chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n", - "#\n", -; - -print "# \@INC:\n", map("# [$_]\n", @INC), "#\n#\n"; - -print "# \%INC:\n"; -foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) { - print "# [$x] = [", $INC{$x} || '', "]\n"; -} - -ok 1; - diff --git a/lib/Pod/Perldoc/t/checkerbasic.t b/lib/Pod/Perldoc/t/checkerbasic.t deleted file mode 100644 index c47dcedc64..0000000000 --- a/lib/Pod/Perldoc/t/checkerbasic.t +++ /dev/null @@ -1,9 +0,0 @@ - -use Test; -BEGIN {plan tests => 2}; -ok 1; -require Pod::Perldoc::ToChecker; -$Pod::Perldoc::VERSION - and print "# Pod::Perldoc version $Pod::Perldoc::VERSION\n"; -ok 1; - diff --git a/lib/Pod/Perldoc/t/perldocbasic.t b/lib/Pod/Perldoc/t/perldocbasic.t deleted file mode 100644 index 6f6b9984d7..0000000000 --- a/lib/Pod/Perldoc/t/perldocbasic.t +++ /dev/null @@ -1,9 +0,0 @@ - -use Test; -BEGIN {plan tests => 3}; -ok 1; -require Pod::Perldoc; -ok($Pod::Perldoc::VERSION) - and print "# Pod::Perldoc version $Pod::Perldoc::VERSION\n"; -ok 1; - diff --git a/lib/Pod/Perldoc/t/textbasic.t b/lib/Pod/Perldoc/t/textbasic.t deleted file mode 100644 index 6814267ec8..0000000000 --- a/lib/Pod/Perldoc/t/textbasic.t +++ /dev/null @@ -1,9 +0,0 @@ - -use Test; -BEGIN {plan tests => 2}; -ok 1; -require Pod::Perldoc::ToText; -$Pod::Perldoc::VERSION - and print "# Pod::Perldoc version $Pod::Perldoc::VERSION\n"; -ok 1; - -- cgit v1.2.1