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