File Coverage

lib/Pod/PerldocJp.pm
Criterion Covered Total %
statement 30 290 10.3
branch 0 200 0.0
condition 0 99 0.0
subroutine 10 25 40.0
pod 11 11 100.0
total 51 625 8.1


line stmt bran cond sub pod time code
1             package Pod::PerldocJp;
2              
3 1     1   41601 use strict;
  1         2  
  1         40  
4 1     1   6 use warnings;
  1         3  
  1         31  
5 1     1   5 use base 'Pod::Perldoc';
  1         6  
  1         1330  
6 1     1   24596 use Encode;
  1         12381  
  1         81  
7 1     1   774 use Encode::Guess;
  1         4301  
  1         5  
8 1     1   721 use Term::Encoding;
  1         498  
  1         49  
9 1     1   698105 use HTTP::Tiny;
  1         803367  
  1         52  
10 1     1   1319 use Path::Tiny;
  1         9715  
  1         58  
11 1     1   807 use URI::Escape;
  1         1324  
  1         62  
12 1     1   917 use utf8;
  1         9  
  1         7  
13              
14             my $term_encoding = Term::Encoding::get_encoding() || 'utf-8';
15              
16             our $VERSION = '0.18';
17              
18 0     0 1   sub opt_J { shift->_elem('opt_J', @_) }
19              
20             sub _perldocjp_dir {
21 0     0     my $self = shift;
22              
23             my @subs = (
24             sub {
25 0     0     require File::HomeDir;
26 0           path(File::HomeDir->my_home, '.perldocjp');
27             },
28 0     0     sub { path(File::Spec->tmpdir, '.perldocjp') },
29 0     0     sub { path('.') },
30 0           );
31              
32 0           foreach my $sub (@subs) {
33 0 0         my $dir = eval { $sub->() } or next;
  0            
34 0           $dir->mkpath;
35 0 0 0       return $dir if -d $dir && -w $dir;
36             };
37             }
38              
39             sub grand_search_init {
40 0     0 1   my ($self, $pages, @found) = @_;
41              
42 0 0         my $dir = $self->_perldocjp_dir()
43             or return $self->SUPER::grand_search_init($pages, @found);
44              
45 0   0       my @encodings =
46             split ' ', $ENV{PERLDOCJP_ENCODINGS} || 'euc-jp shiftjis utf8';
47              
48 0 0 0       if ($self->opt_J or ($pages->[0] && $pages->[0] =~ /^https?:/)) {
      0        
49 0           my $ua = HTTP::Tiny->new(agent => "Pod-PerldocJp/$VERSION");
50              
51 0   0       my $api_url = $ENV{PERLDOCJP_SERVER} || 'http://perldoc.charsbar.org/api/pod';
52 0           $api_url =~ s|/+$||;
53              
54 0           foreach my $page (@$pages) {
55 0           $self->aside("Searching for $page\n");
56 0 0         my $url = ($page =~ /^https?:/) ? $page : "$api_url/$page";
57 0           my $file = $dir->child(uri_escape($page, '^A-Za-z0-9_') . '.pod');
58 0 0 0       unless ($file->exists && $file->stat->size && $file->stat->mtime > time - 60 * 60 * 24) {
      0        
59 0           my $res = $ua->mirror($url => "$file");
60 0 0 0       if ($res->{success} && (my $pod = $file->slurp) !~ /^=encoding\s/m) {
61             # You can't trust perldoc.jp's Content-Type too much.
62             # (there're several utf-8 translations, though perldoc.jp
63             # is (or was) supposed to use euc-jp)
64 0           my $encoding;
65 0           my $enc = guess_encoding($pod, @encodings);
66 0 0         if (ref $enc) {
    0          
67 0           $encoding = $enc->name;
68             }
69             elsif (my $ctype = $res->{headers}{'content-type'}) {
70 0           ($encoding) = $ctype =~ /charset\s*=\s*([\w-]+)/;
71             }
72 0 0         if ($encoding) {
73 0           $pod = "=encoding $encoding\n\n$pod";
74 0           $file->spew($pod);
75             }
76             }
77             }
78 0 0         push @found, "$file" if $file->stat->size;
79             }
80 0 0         return @found if @found;
81             }
82              
83 0           @found = $self->SUPER::grand_search_init($pages, @found);
84              
85 0 0         if ($self->opt_J) {
86 0           foreach my $path (@found) {
87 0           my $pod = path($path)->slurp;
88 0 0         unless ($pod =~ /^=encoding\s/m) {
89 0           my $encoding;
90 0           my $enc = guess_encoding($pod, @encodings);
91 0 0         if (ref $enc) {
92 0           $encoding = $enc->name;
93 0 0         next if $encoding eq 'ascii';
94 0           $pod = "=encoding $encoding\n\n$pod";
95 0           my $file = $dir->child(uri_escape($path, '^A-Za-z0-9_'));
96 0           $file->spew($pod);
97 0 0         $path = "$file" if $file->stat->size;
98             }
99             }
100             }
101             }
102 0           @found;
103             }
104              
105             {
106             # shamelessly ripped from Pod::Perldoc 3.23 and tweaked
107              
108             sub opt_o_with { # "o" for output format
109 0     0 1   my($self, $rest) = @_;
110 0 0 0       return unless defined $rest and length $rest;
111 0 0         if($rest =~ m/^(\w+)$/s) {
112 0           $rest = $1; #untaint
113             } else {
114 0           $self->warn( qq("$rest" isn't a valid output format. Skipping.\n") );
115 0           return;
116             }
117              
118 0           $self->aside("Noting \"$rest\" as desired output format...\n");
119              
120             # Figure out what class(es) that could actually mean...
121              
122 0           my @classes;
123             # TWEAKED: to include "Pod::PerldocJp::To"
124 0           foreach my $prefix ("Pod::PerldocJp::To", "Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
125             # Messy but smart:
126 0           foreach my $stem (
127             $rest, # Yes, try it first with the given capitalization
128             "\L$rest", "\L\u$rest", "\U$rest" # And then try variations
129              
130             ) {
131 0           $self->aside("Considering $prefix$stem\n");
132 0           push @classes, $prefix . $stem;
133             }
134              
135             # Tidier, but misses too much:
136             #push @classes, $prefix . ucfirst(lc($rest));
137             }
138 0           $self->opt_M_with( join ";", @classes );
139 0           return;
140             }
141              
142             sub init_formatter_class_list {
143 0     0 1   my $self = shift;
144 0   0       $self->{'formatter_classes'} ||= [];
145              
146             # Remember, no switches have been read yet, when
147             # we've started this routine.
148              
149 0           $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru
150 0           $self->opt_o_with('text');
151              
152             # TWEAKED: XXX: should support term later
153             # $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos
154             # || !($ENV{TERM} && (
155             # ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
156             # ));
157              
158 0           return;
159             }
160              
161             sub maybe_generate_dynamic_pod {
162 0     0 1   my ($self, $found_things) = @_;
163 0           my @dynamic_pod;
164              
165 0 0         $self->search_perlapi($found_things, \@dynamic_pod) if $self->opt_a;
166              
167 0 0         $self->search_perlfunc($found_things, \@dynamic_pod) if $self->opt_f;
168              
169 0 0         $self->search_perlvar($found_things, \@dynamic_pod) if $self->opt_v;
170              
171 0 0         $self->search_perlfaqs($found_things, \@dynamic_pod) if $self->opt_q;
172              
173 0 0 0       if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v and ! $self->opt_a) {
    0          
174 0           Pod::Perldoc::DEBUG > 4 and print "That's a non-dynamic pod search.\n";
175             } elsif ( @dynamic_pod ) {
176 0           $self->aside("Hm, I found some Pod from that search!\n");
177 0           my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
178 0 0 0       if ( $] >= 5.008 && $self->opt_L ) {
179 0           binmode($buffd, ":utf8");
180 0           print $buffd "=encoding utf8\n\n";
181             }
182              
183 0           push @{ $self->{'temp_file_list'} }, $buffer;
  0            
184             # I.e., it MIGHT be deleted at the end.
185              
186 0   0       my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v || $self->opt_a;
187             # TWEAKED: to add =encoding utf-8 and encode_utf8
188 0           print $buffd "=encoding utf-8\n\n";
189 0 0         print $buffd "=over 8\n\n" if $in_list;
190 0 0         print $buffd map {encode_utf8($_)} @dynamic_pod or die "Can't print $buffer: $!";
  0            
191 0 0         print $buffd "=back\n" if $in_list;
192              
193 0 0         close $buffd or $self->die( "Can't close $buffer: $!" );
194              
195 0           @$found_things = $buffer;
196             # Yes, so found_things never has more than one thing in
197             # it, by time we leave here
198              
199 0           $self->add_formatter_option('__filter_nroff' => 1);
200              
201             } else {
202 0           @$found_things = ();
203 0           $self->aside("I found no Pod from that search!\n");
204             }
205              
206 0           return;
207             }
208              
209             sub search_perlfunc {
210 0     0 1   my($self, $found_things, $pod) = @_;
211              
212 0           Pod::Perldoc::DEBUG > 2 and print "Search: @$found_things\n";
213              
214 0           my $perlfunc = shift @$found_things;
215 0 0         open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
216             or $self->die("Can't open $perlfunc: $!");
217              
218             # Functions like -r, -e, etc. are listed under `-X'.
219 0 0         my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
220             ? '(?:I<)?-X' : quotemeta($self->opt_f) ;
221              
222 0           Pod::Perldoc::DEBUG > 2 and
223             print "Going to perlfunc-scan for $search_re in $perlfunc\n";
224              
225 0           my $re = 'Alphabetical Listing of Perl Functions';
226              
227             # Check available translator or backup to default (english)
228 0 0 0       if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
229 0           my $tr = $self->{'translators'}->[0];
230 0 0         $re = $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
231 0 0         if ( $] < 5.008 ) {
232 0           $self->aside("Your old perl doesn't really have proper unicode support.");
233             }
234             else {
235 0           binmode(PFUNC, ":utf8");
236             }
237             }
238              
239             # Skip introduction
240 0           local $_;
241             # TWEAKED: to find encoding
242 0           my $encoding = 'utf-8';
243 0           while () {
244 0 0         if (/^=encoding\s+(\S+)/) {
245 0           $encoding = $1;
246             }
247 0 0         last if /^=head2 $re/;
248             }
249              
250             # Look for our function
251 0           my $found = 0;
252 0           my $inlist = 0;
253              
254 0           my @perlops = qw(m q qq qr qx qw s tr y);
255              
256 0           my @related;
257             my $related_re;
258 0           while () { # "The Mothership Connection is here!"
259 0 0         last if( grep{ $self->opt_f eq $_ }@perlops );
  0            
260              
261 0 0 0       if ( /^=over/ and not $found ) {
    0 0        
      0        
262 0           ++$inlist;
263             }
264             elsif ( /^=back/ and not $found and $inlist ) {
265 0           --$inlist;
266             }
267              
268              
269 0 0 0       if ( m/^=item\s+$search_re\b/ and $inlist < 2 ) {
    0 0        
    0 0        
    0          
270 0           $found = 1;
271             }
272             elsif (@related > 1 and /^=item/) {
273 0   0       $related_re ||= join "|", @related;
274 0 0         if (m/^=item\s+(?:$related_re)\b/) {
275 0           $found = 1;
276             }
277             else {
278 0 0 0       last if $found > 1 and $inlist < 2;
279             }
280             }
281             elsif (/^=item/) {
282 0 0 0       last if $found > 1 and $inlist < 2;
283             }
284             elsif ($found and /^X<[^>]+>/) {
285 0           push @related, m/X<([^>]+)>/g;
286             }
287 0 0         next unless $found;
288 0 0         if (/^=over/) {
    0          
289 0           ++$inlist;
290             }
291             elsif (/^=back/) {
292 0           --$inlist;
293             }
294             # TWEAKED: to decode
295 0           push @$pod, decode($encoding, $_);
296 0 0         ++$found if /^\w/; # found descriptive text
297             }
298              
299 0 0         if( !@$pod ){
300 0           $self->search_perlop( $found_things, $pod );
301             }
302              
303 0 0         if (!@$pod) {
304 0           CORE::die( sprintf
305             "No documentation for perl function `%s' found\n",
306             $self->opt_f )
307             ;
308             }
309 0 0         close PFUNC or $self->die( "Can't open $perlfunc: $!" );
310              
311 0           return;
312             }
313              
314             sub search_perlvar {
315 0     0 1   my ($self, $found_things, $pod) = @_;
316              
317 0           my $opt = $self->opt_v;
318              
319 0 0         if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) {
320 0           CORE::die( "'$opt' does not look like a Perl variable\n" );
321             }
322              
323 0           Pod::Perldoc::DEBUG > 2 and print "Search: @$found_things\n";
324              
325 0           my $perlvar = shift @$found_things;
326 0 0         open(PVAR, "<", $perlvar) # "Funk is its own reward"
327             or $self->die("Can't open $perlvar: $!");
328              
329 0 0 0       if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ..., $9
330 0           $opt = '$>';
331             }
332 0           my $search_re = quotemeta($opt);
333              
334 0           Pod::Perldoc::DEBUG > 2 and
335             print "Going to perlvar-scan for $search_re in $perlvar\n";
336              
337             # Skip introduction
338 0           local $_;
339             # TWEAKED: to find encoding
340 0           my $encoding = 'utf-8';
341 0           while () {
342 0 0         if (/^=encoding\s+(\S+)/) {
343 0           $encoding = $1;
344             }
345 0 0         last if /^=over 8/;
346             }
347              
348             # Look for our variable
349 0           my $found = 0;
350 0           my $inheader = 1;
351 0           my $inlist = 0;
352 0           while () { # "The Mothership Connection is here!"
353 0 0         last if /^=head2 Error Indicators/;
354             # \b at the end of $` and friends borks things!
355 0 0         if ( m/^=item\s+$search_re\s/ ) {
    0          
    0          
356 0           $found = 1;
357             }
358             elsif (/^=item/) {
359 0 0 0       last if $found && !$inheader && !$inlist;
      0        
360             }
361             elsif (!/^\s+$/) { # not a blank line
362 0 0         if ( $found ) {
363 0           $inheader = 0; # don't accept more =item (unless inlist)
364             }
365             else {
366 0           @$pod = (); # reset
367 0           $inheader = 1; # start over
368 0           next;
369             }
370             }
371              
372 0 0         if (/^=over/) {
    0          
373 0           ++$inlist;
374             }
375             elsif (/^=back/) {
376 0 0 0       last if $found && !$inheader && !$inlist;
      0        
377 0           --$inlist;
378             }
379             # TWEAKED: to decode
380 0           push @$pod, decode($encoding, $_);
381             # ++$found if /^\w/; # found descriptive text
382             }
383 0 0         @$pod = () unless $found;
384 0 0         if (!@$pod) {
385 0           CORE::die( "No documentation for perl variable '$opt' found\n" );
386             }
387 0 0         close PVAR or $self->die( "Can't open $perlvar: $!" );
388              
389 0           return;
390             }
391              
392             sub search_perlfaqs {
393 0     0 1   my ($self, $found_things, $pod) = @_;
394              
395 0           my $found = 0;
396 0           my %found_in;
397 0           my $search_key = $self->opt_q;
398              
399 0 0         my $rx = eval { qr/$search_key/ }
  0            
400             or $self->die( <
401             Invalid regular expression '$search_key' given as -q pattern:
402             $@
403             Did you mean \\Q$search_key ?
404              
405             EOD
406              
407 0           local $_;
408 0           foreach my $file (@$found_things) {
409 0 0         $self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/;
410 0 0         open(INFAQ, "<", $file) # XXX 5.6ism
411             or $self->die( "Can't read-open $file: $!\nAborting" );
412             # TWEAKED: to find encoding
413 0           my $encoding = 'utf-8';
414 0           while () {
415 0 0         if (/^=encoding\s+(\S+)/) {
416 0           $encoding = $1;
417             }
418 0 0         if ( m/^=head2\s+.*(?:$search_key)/i ) {
    0          
419 0           $found = 1;
420 0 0         push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
421             }
422             elsif (/^=head[12]/) {
423 0           $found = 0;
424             }
425 0 0         next unless $found;
426             # TWEAKED: to decode
427 0           push @$pod, decode($encoding, $_);
428             }
429 0           close(INFAQ);
430             }
431 0 0         CORE::die("No documentation for perl FAQ keyword `$search_key' found\n")
432             unless @$pod;
433              
434 0 0         if ( $self->opt_l ) {
435 0           CORE::die((join "\n", keys %found_in) . "\n");
436             }
437 0           return;
438             }
439              
440             sub search_perlapi {
441 0     0 1   my($self, $found_things, $pod) = @_;
442              
443 0           Pod::Perldoc::DEBUG > 2 and print "Search: @$found_things\n";
444              
445 0           my $perlapi = shift @$found_things;
446 0 0         open(PAPI, "<", $perlapi) # "Funk is its own reward"
447             or $self->die("Can't open $perlapi: $!");
448              
449 0           my $search_re = quotemeta($self->opt_a);
450              
451 0           Pod::Perldoc::DEBUG > 2 and
452             print "Going to perlapi-scan for $search_re in $perlapi\n";
453              
454             # Check available translator or backup to default (english)
455 0 0 0       if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
456 0           my $tr = $self->{'translators'}->[0];
457 0 0         if ( $] < 5.008 ) {
458 0           $self->aside("Your old perl doesn't really have proper unicode support.");
459             }
460             else {
461 0           binmode(PAPI, ":utf8");
462             }
463             }
464              
465 0           local $_;
466             # TWEAKED: to find encoding
467 0           my $encoding = 'utf-8';
468 0           while () {
469 0 0         if (/^=encoding\s+(\S+)/) {
470 0           $encoding = $1;
471             }
472 0 0         last if /^=over 8/;
473             }
474              
475             # Look for our function
476 0           my $found = 0;
477 0           my $inlist = 0;
478              
479 0           my @related;
480             my $related_re;
481 0           while () { # "The Mothership Connection is here!"
482 0 0 0       if ( m/^=item\s+$search_re\b/ ) {
    0 0        
    0          
    0          
483 0           $found = 1;
484             }
485             elsif (@related > 1 and /^=item/) {
486 0   0       $related_re ||= join "|", @related;
487 0 0         if (m/^=item\s+(?:$related_re)\b/) {
488 0           $found = 1;
489             }
490             else {
491 0           last;
492             }
493             }
494             elsif (/^=item/) {
495 0 0 0       last if $found > 1 and not $inlist;
496             }
497             elsif ($found and /^X<[^>]+>/) {
498 0           push @related, m/X<([^>]+)>/g;
499             }
500 0 0         next unless $found;
501 0 0         if (/^=over/) {
    0          
502 0           ++$inlist;
503             }
504             elsif (/^=back/) {
505 0 0 0       last if $found > 1 and not $inlist;
506 0           --$inlist;
507             }
508 0           push @$pod, decode($encoding, $_);
509 0 0         ++$found if /^\w/; # found descriptive text
510             }
511              
512 0 0         if (!@$pod) {
513 0           CORE::die( sprintf
514             "No documentation for perl api function '%s' found\n",
515             $self->opt_a )
516             ;
517             }
518 0 0         close PAPI or $self->die( "Can't open $perlapi: $!" );
519              
520 0           return;
521             }
522              
523             # TWEAKED: translation and encoding
524             sub usage {
525 0     0 1   my $self = shift;
526 0 0         $self->warn( "@_\n" ) if @_;
527              
528             # Erase evidence of previous errors (if any), so exit status is simple.
529 0           $! = 0;
530              
531 0           my $usage = <<"EOF";
532             perldoc [options] PageName|ModuleName|ProgramName|URL...
533             perldoc [options] -f BuiltinFunction
534             perldoc [options] -q FAQRegex
535             perldoc [options] -v PerlVariable
536              
537             オプション:
538             -h このヘルプを表示する
539             -V バージョンを表示する
540             -r 再帰検索 (時間がかかります)
541             -i 大文字小文字を無視する
542             -t pod2manとnroffではなくpod2textを使って表示(デフォルト)
543             -u 整形前のPODを表示する
544             -m 指定したモジュールのコードも含めて表示する
545             -n nroffのかわりを指定する
546             -l モジュールのファイル名を表示する
547             -F 引数はモジュール名ではなくファイル名である
548             -D デバッグメッセージを表示する
549             -T ページャを通さずに画面に出力する
550             -d 保存するファイル名
551             -o 出力フォーマット名
552             -M フォーマット用のモジュール名(FormatterModuleNameToUse)
553             -w フォーマット用のオプション:値(formatter_option:option_value)
554             -L 国別コード。(あれば)翻訳を表示します
555             -X あれば索引を利用する (pod.idxを探します)
556             -J perldoc.jpの日本語訳も検索
557             -q perlfaq[1-9]の質問を検索
558             -f Perlの組み込み関数を検索
559             -a Perl APIを検索
560             -v Perlの定義済み変数を検索
561              
562             PageName|ModuleName|ProgramName|URL...
563             表示したいドキュメント名です。「perlfunc」のようなページ名、
564             モジュール名(「Term::Info」または「Term/Info」)、「perldoc」
565             のようなプログラム名、http(s)で始まるURLを指定できます。
566              
567             BuiltinFunction
568             Perlの関数名です。「perlfunc」ないし「perlop」からドキュメント
569             を抽出します。
570              
571             FAQRegex
572             正規表現です。perlfaq[1-9]を検索してマッチした質問を抽出します。
573              
574             PERLDOC環境変数で指定したスイッチはコマンドライン引数の前に適用されます。
575             PODの索引には(あれば)ファイル名の一覧が(1行に1つ)含まれています。
576              
577             [PerldocJp v$Pod::PerldocJp::VERSION based on Perldoc v$Pod::Perldoc::VERSION]
578             EOF
579              
580 0           CORE::die encode($term_encoding => $usage);
581             }
582              
583             sub usage_brief {
584 0     0 1   my $self = shift;
585 0           my $program_name = $self->program_name;
586              
587 0           my $usage =<<"EOUSAGE";
588             使い方: $program_name [-hVriDtumFXlTJ] [-n nroffer_program]
589             [-d output_filename] [-o output_format] [-M FormatterModule]
590             [-w formatter_option:option_value] [-L translation_code]
591             PageName|ModuleName|ProgramName
592              
593             Examples:
594              
595             $program_name -f PerlFunc
596             $program_name -q FAQKeywords
597             $program_name -v PerlVar
598             $program_name -a PerlAPI
599              
600             -hオプションをつけるともう少し詳しいヘルプが表示されます。
601             詳細は"perldocjp perldocjp"をご覧ください。
602             [PerldocJp v$Pod::PerldocJp::VERSION based on Perldoc v$Pod::Perldoc::VERSION]
603             EOUSAGE
604              
605 0           CORE::die encode($term_encoding => $usage);
606             }
607             }
608              
609             1;
610              
611             __END__