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

package Pod::PerldocJp;

use strict;
use warnings;
use base 'Pod::Perldoc';
use Encode;
use Encode::Guess;
use Term::Encoding;
use HTTP::Tiny;
use Path::Tiny;
use URI::Escape;
use utf8;

my $term_encoding = Term::Encoding::get_encoding() || 'utf-8';

our $VERSION = '0.19';

sub opt_J { shift->_elem('opt_J', @_) }

sub _perldocjp_dir {
  my $self = shift;

  my @subs = (
    sub {
      require File::HomeDir;
      path(File::HomeDir->my_home, '.perldocjp');
    },
    sub { path(File::Spec->tmpdir, '.perldocjp') },
    sub { path('.') },
  );

  foreach my $sub (@subs) {
    my $dir = eval { $sub->() } or next;
    $dir->mkpath;
    return $dir if -d $dir && -w $dir;
  };
}

sub grand_search_init {
  my ($self, $pages, @found) = @_;

  my $dir = $self->_perldocjp_dir()
    or return $self->SUPER::grand_search_init($pages, @found);

    my @encodings =
      split ' ', $ENV{PERLDOCJP_ENCODINGS} || 'euc-jp shiftjis utf8';

  if (not $self->opt_F and ($self->opt_J or ($pages->[0] && $pages->[0] =~ /^https?:/))) {
    my $ua  = HTTP::Tiny->new(agent => "Pod-PerldocJp/$VERSION");

    my $api_url = $ENV{PERLDOCJP_SERVER} || 'http://perldoc.charsbar.org/api/pod';
    $api_url =~ s|/+$||;

    foreach my $page (@$pages) {
      $self->aside("Searching for $page\n");
      my $url = ($page =~ /^https?:/) ? $page : "$api_url/$page";
      my $file = $dir->child(uri_escape($page, '^A-Za-z0-9_') . '.pod');
      unless ($file->exists && $file->stat->size && $file->stat->mtime > time - 60 * 60 * 24) {
        my $res = $ua->mirror($url => "$file");
        if ($res->{success} && (my $pod = $file->slurp) !~ /^=encoding\s/m) {
          # You can't trust perldoc.jp's Content-Type too much.
          # (there're several utf-8 translations, though perldoc.jp
          # is (or was) supposed to use euc-jp)
          my $encoding;
          my $enc = guess_encoding($pod, @encodings);
          if (ref $enc) {
            $encoding = $enc->name;
          }
          elsif (my $ctype = $res->{headers}{'content-type'}) {
            ($encoding) = $ctype =~ /charset\s*=\s*([\w-]+)/;
          }
          if ($encoding) {
            $pod = "=encoding $encoding\n\n$pod";
            $file->spew($pod);
          }
        }
      }
      push @found, "$file" if $file->stat->size;
    }
    return @found if @found;
  }

  @found = $self->SUPER::grand_search_init($pages, @found);

  if ($self->opt_J) {
    foreach my $path (@found) {
      my $pod = path($path)->slurp;
      unless ($pod =~ /^=encoding\s/m) {
        my $encoding;
        my $enc = guess_encoding($pod, @encodings);
        if (ref $enc) {
          $encoding = $enc->name;
          next if $encoding eq 'ascii';
          $pod = "=encoding $encoding\n\n$pod";
          my $file = $dir->child(uri_escape($path, '^A-Za-z0-9_'));
          $file->spew($pod);
          $path = "$file" if $file->stat->size;
        }
      }
    }
  }
  @found;
}

{
  # shamelessly ripped from Pod::Perldoc 3.23 and tweaked

  sub opt_o_with { # "o" for output format
    my($self, $rest) = @_;
    return unless defined $rest and length $rest;
    if($rest =~ m/^(\w+)$/s) {
      $rest = $1; #untaint
    } else {
      $self->warn( qq("$rest" isn't a valid output format.  Skipping.\n") );
      return;
    }

    $self->aside("Noting \"$rest\" as desired output format...\n");

    # Figure out what class(es) that could actually mean...

    my @classes;
    # TWEAKED: to include "Pod::PerldocJp::To"
    foreach my $prefix ("Pod::PerldocJp::To", "Pod::Perldoc::To", "Pod::Simple::", "Pod::") {
      # Messy but smart:
      foreach my $stem (
        $rest,  # Yes, try it first with the given capitalization
        "\L$rest", "\L\u$rest", "\U$rest" # And then try variations

      ) {
        $self->aside("Considering $prefix$stem\n");
        push @classes, $prefix . $stem;
      }

      # Tidier, but misses too much:
      #push @classes, $prefix . ucfirst(lc($rest));
    }
    $self->opt_M_with( join ";", @classes );
    return;
  }

  sub init_formatter_class_list {
    my $self = shift;
    $self->{'formatter_classes'} ||= [];

    # Remember, no switches have been read yet, when
    # we've started this routine.

    $self->opt_M_with('Pod::Perldoc::ToPod');   # the always-there fallthru
    $self->opt_o_with('text');

    # TWEAKED: XXX: should support term later
    # $self->opt_o_with('term') unless $self->is_mswin32 || $self->is_dos
    #   || !($ENV{TERM} && (
    #       ($ENV{TERM} || '') !~ /dumb|emacs|none|unknown/i
    #      ));

    return;
  }

  sub maybe_generate_dynamic_pod {
    my ($self, $found_things) = @_;
    my @dynamic_pod;

    $self->search_perlapi($found_things, \@dynamic_pod)   if  $self->opt_a;

    $self->search_perlfunc($found_things, \@dynamic_pod)  if  $self->opt_f;

    $self->search_perlvar($found_things, \@dynamic_pod)   if  $self->opt_v;

    $self->search_perlfaqs($found_things, \@dynamic_pod)  if  $self->opt_q;

    if( ! $self->opt_f and ! $self->opt_q and ! $self->opt_v and ! $self->opt_a) {
      Pod::Perldoc::DEBUG > 4 and print "That's a non-dynamic pod search.\n";
    } elsif ( @dynamic_pod ) {
      $self->aside("Hm, I found some Pod from that search!\n");
      my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn');
      if ( $] >= 5.008 && $self->opt_L ) {
        binmode($buffd, ":utf8");
        print $buffd "=encoding utf8\n\n";
      }

      push @{ $self->{'temp_file_list'} }, $buffer;
      # I.e., it MIGHT be deleted at the end.

      my $in_list = !$self->not_dynamic && $self->opt_f || $self->opt_v || $self->opt_a;
      # TWEAKED: to add =encoding utf-8 and encode_utf8
      print $buffd "=encoding utf-8\n\n";
      print $buffd "=over 8\n\n" if $in_list;
      print $buffd map {encode_utf8($_)} @dynamic_pod  or die "Can't print $buffer: $!";
      print $buffd "=back\n"     if $in_list;

      close $buffd        or $self->die( "Can't close $buffer: $!" );

      @$found_things = $buffer;
        # Yes, so found_things never has more than one thing in
        #  it, by time we leave here

      $self->add_formatter_option('__filter_nroff' => 1);

    } else {
      @$found_things = ();
      $self->aside("I found no Pod from that search!\n");
    }

    return;
  }

  sub search_perlfunc {
    my($self, $found_things, $pod) = @_;

    Pod::Perldoc::DEBUG > 2 and print "Search: @$found_things\n";

    my $perlfunc = shift @$found_things;
    open(PFUNC, "<", $perlfunc) # "Funk is its own reward"
        or $self->die("Can't open $perlfunc: $!");

    # Functions like -r, -e, etc. are listed under `-X'.
    my $search_re = ($self->opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
                        ? '(?:I<)?-X' : quotemeta($self->opt_f) ;

    Pod::Perldoc::DEBUG > 2 and
     print "Going to perlfunc-scan for $search_re in $perlfunc\n";

    my $re = 'Alphabetical Listing of Perl Functions';

    # Check available translator or backup to default (english)
    if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
        my $tr = $self->{'translators'}->[0];
        $re =  $tr->search_perlfunc_re if $tr->can('search_perlfunc_re');
        if ( $] < 5.008 ) {
            $self->aside("Your old perl doesn't really have proper unicode support.");
        }
        else {
            binmode(PFUNC, ":utf8");
        }
    }

    # Skip introduction
    local $_;
    # TWEAKED: to find encoding
    my $encoding = 'utf-8';
    while () {
      if (/^=encoding\s+(\S+)/) {
        $encoding = $1;
      }
      last if /^=head2 $re/;
    }

    # Look for our function
    my $found = 0;
    my $inlist = 0;

    my @perlops = qw(m q qq qr qx qw s tr y);

    my @related;
    my $related_re;
    while () {  # "The Mothership Connection is here!"
      last if( grep{ $self->opt_f eq $_ }@perlops );

      if ( /^=over/ and not $found ) {
        ++$inlist;
      }
      elsif ( /^=back/ and not $found and $inlist ) {
        --$inlist;
      }


      if ( m/^=item\s+$search_re\b/ and $inlist < 2 )  {
        $found = 1;
      }
      elsif (@related > 1 and /^=item/) {
        $related_re ||= join "|", @related;
        if (m/^=item\s+(?:$related_re)\b/) {
          $found = 1;
        }
        else {
          last if $found > 1 and $inlist < 2;
        }
      }
      elsif (/^=item/) {
        last if $found > 1 and $inlist < 2;
      }
      elsif ($found and /^X<[^>]+>/) {
        push @related, m/X<([^>]+)>/g;
      }
      next unless $found;
      if (/^=over/) {
        ++$inlist;
      }
      elsif (/^=back/) {
        --$inlist;
      }
      # TWEAKED: to decode
      push @$pod, decode($encoding, $_);
      ++$found if /^\w/;        # found descriptive text
    }

    if( !@$pod ){
        $self->search_perlop( $found_things, $pod );
    }

    if (!@$pod) {
      CORE::die( sprintf
        "No documentation for perl function `%s' found\n",
        $self->opt_f )
        ;
    }
    close PFUNC                or $self->die( "Can't open $perlfunc: $!" );

    return;
  }

  sub search_perlvar {
    my ($self, $found_things, $pod) = @_;

    my $opt = $self->opt_v;

    if ( $opt !~ /^ (?: [\@\%\$]\S+ | [A-Z]\w* ) $/x ) {
      CORE::die( "'$opt' does not look like a Perl variable\n" );
    }

    Pod::Perldoc::DEBUG > 2 and print "Search: @$found_things\n";

    my $perlvar = shift @$found_things;
    open(PVAR, "<", $perlvar)               # "Funk is its own reward"
        or $self->die("Can't open $perlvar: $!");

    if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ..., $9
      $opt = '$>';
    }
    my $search_re = quotemeta($opt);

    Pod::Perldoc::DEBUG > 2 and
      print "Going to perlvar-scan for $search_re in $perlvar\n";

    # Skip introduction
    local $_;
    # TWEAKED: to find encoding
    my $encoding = 'utf-8';
    while () {
      if (/^=encoding\s+(\S+)/) {
        $encoding = $1;
      }
      last if /^=over 8/;
    }

    # Look for our variable
    my $found = 0;
    my $inheader = 1;
    my $inlist = 0;
    while () {  # "The Mothership Connection is here!"
      last if /^=head2 Error Indicators/;
      # \b at the end of $` and friends borks things!
      if ( m/^=item\s+$search_re\s/ )  {
        $found = 1;
      }
      elsif (/^=item/) {
        last if $found && !$inheader && !$inlist;
      }
      elsif (!/^\s+$/) { # not a blank line
        if ( $found ) {
          $inheader = 0; # don't accept more =item (unless inlist)
	    }
        else {
          @$pod = (); # reset
          $inheader = 1; # start over
          next;
        }
      }

      if (/^=over/) {
        ++$inlist;
      }
      elsif (/^=back/) {
        last if $found && !$inheader && !$inlist;
        --$inlist;
      }
      # TWEAKED: to decode
      push @$pod, decode($encoding, $_);
#     ++$found if /^\w/;        # found descriptive text
    }
    @$pod = () unless $found;
    if (!@$pod) {
      CORE::die( "No documentation for perl variable '$opt' found\n" );
    }
    close PVAR                or $self->die( "Can't open $perlvar: $!" );

    return;
  }

  sub search_perlfaqs {
    my ($self, $found_things, $pod) = @_;

    my $found = 0;
    my %found_in;
    my $search_key = $self->opt_q;

    my $rx = eval { qr/$search_key/ }
      or $self->die( <
Invalid regular expression '$search_key' given as -q pattern:
$@
Did you mean \\Q$search_key ?

EOD

    local $_;
    foreach my $file (@$found_things) {
      $self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/;
      open(INFAQ, "<", $file)  # XXX 5.6ism
        or $self->die( "Can't read-open $file: $!\nAborting" );
      # TWEAKED: to find encoding
      my $encoding = 'utf-8';
      while () {
        if (/^=encoding\s+(\S+)/) {
          $encoding = $1;
        }
        if ( m/^=head2\s+.*(?:$search_key)/i ) {
          $found = 1;
          push @$pod, "=head1 Found in $file\n\n" unless $found_in{$file}++;
        }
        elsif (/^=head[12]/) {
          $found = 0;
        }
        next unless $found;
        # TWEAKED: to decode
        push @$pod, decode($encoding, $_);
      }
      close(INFAQ);
    }
    CORE::die("No documentation for perl FAQ keyword `$search_key' found\n")
      unless @$pod;

    if ( $self->opt_l ) {
        CORE::die((join "\n", keys %found_in) . "\n");
    }
    return;
  }

  sub search_perlapi {
    my($self, $found_things, $pod) = @_;

    Pod::Perldoc::DEBUG > 2 and print "Search: @$found_things\n";

    my $perlapi = shift @$found_things;
    open(PAPI, "<", $perlapi)               # "Funk is its own reward"
      or $self->die("Can't open $perlapi: $!");

    my $search_re = quotemeta($self->opt_a);

    Pod::Perldoc::DEBUG > 2 and
     print "Going to perlapi-scan for $search_re in $perlapi\n";

    # Check available translator or backup to default (english)
    if ( $self->opt_L && defined $self->{'translators'}->[0] ) {
      my $tr = $self->{'translators'}->[0];
      if ( $] < 5.008 ) {
        $self->aside("Your old perl doesn't really have proper unicode support.");
      }
      else {
        binmode(PAPI, ":utf8");
      }
    }

    local $_;
    # TWEAKED: to find encoding
    my $encoding = 'utf-8';
    while () {
      if (/^=encoding\s+(\S+)/) {
        $encoding = $1;
      }
      last if /^=over 8/;
    }

    # Look for our function
    my $found = 0;
    my $inlist = 0;

    my @related;
    my $related_re;
    while () {  # "The Mothership Connection is here!"
      if ( m/^=item\s+$search_re\b/ )  {
        $found = 1;
      }
      elsif (@related > 1 and /^=item/) {
        $related_re ||= join "|", @related;
        if (m/^=item\s+(?:$related_re)\b/) {
          $found = 1;
        }
        else {
          last;
        }
      }
      elsif (/^=item/) {
        last if $found > 1 and not $inlist;
      }
      elsif ($found and /^X<[^>]+>/) {
        push @related, m/X<([^>]+)>/g;
      }
      next unless $found;
      if (/^=over/) {
        ++$inlist;
      }
      elsif (/^=back/) {
        last if $found > 1 and not $inlist;
        --$inlist;
      }
      push @$pod, decode($encoding, $_);
      ++$found if /^\w/;        # found descriptive text
    }

    if (!@$pod) {
      CORE::die( sprintf
        "No documentation for perl api function '%s' found\n",
        $self->opt_a )
      ;
    }
    close PAPI                or $self->die( "Can't open $perlapi: $!" );

    return;
  }

  # TWEAKED: translation and encoding
  sub usage {
    my $self = shift;
    $self->warn( "@_\n" ) if @_;

    # Erase evidence of previous errors (if any), so exit status is simple.
    $! = 0;

    my $usage = <<"EOF";
perldoc [options] PageName|ModuleName|ProgramName|URL...
perldoc [options] -f BuiltinFunction
perldoc [options] -q FAQRegex
perldoc [options] -v PerlVariable

オプション:
    -h   このヘルプを表示する
    -V   バージョンを表示する
    -r   再帰検索 (時間がかかります)
    -i   大文字小文字を無視する
    -t   pod2manとnroffではなくpod2textを使って表示(デフォルト)
    -u   整形前のPODを表示する
    -m   指定したモジュールのコードも含めて表示する
    -n   nroffのかわりを指定する
    -l   モジュールのファイル名を表示する
    -F   引数はモジュール名ではなくファイル名である
    -D   デバッグメッセージを表示する
    -T   ページャを通さずに画面に出力する
    -d   保存するファイル名
    -o   出力フォーマット名
    -M   フォーマット用のモジュール名(FormatterModuleNameToUse)
    -w   フォーマット用のオプション:値(formatter_option:option_value)
    -L   国別コード。（あれば）翻訳を表示します
    -X   あれば索引を利用する (pod.idxを探します)
    -J   perldoc.jpの日本語訳も検索
    -q   perlfaq[1-9]の質問を検索
    -f   Perlの組み込み関数を検索
    -a   Perl APIを検索
    -v   Perlの定義済み変数を検索

PageName|ModuleName|ProgramName|URL...
    表示したいドキュメント名です。「perlfunc」のようなページ名、
    モジュール名(「Term::Info」または「Term/Info」)、「perldoc」
    のようなプログラム名、http(s)で始まるURLを指定できます。

BuiltinFunction
    Perlの関数名です。「perlfunc」ないし「perlop」からドキュメント
    を抽出します。

FAQRegex
    正規表現です。perlfaq[1-9]を検索してマッチした質問を抽出します。

PERLDOC環境変数で指定したスイッチはコマンドライン引数の前に適用されます。
PODの索引には(あれば)ファイル名の一覧が(1行に1つ)含まれています。

[PerldocJp v$Pod::PerldocJp::VERSION based on Perldoc v$Pod::Perldoc::VERSION]
EOF

    CORE::die encode($term_encoding => $usage);
  }

  sub usage_brief {
    my $self = shift;
    my $program_name = $self->program_name;

    my $usage =<<"EOUSAGE";
使い方: $program_name [-hVriDtumFXlTJ] [-n nroffer_program]
     [-d output_filename] [-o output_format] [-M FormatterModule]
     [-w formatter_option:option_value] [-L translation_code]
     PageName|ModuleName|ProgramName

Examples:

       $program_name -f PerlFunc
       $program_name -q FAQKeywords
       $program_name -v PerlVar
       $program_name -a PerlAPI

-hオプションをつけるともう少し詳しいヘルプが表示されます。
詳細は"perldocjp perldocjp"をご覧ください。
[PerldocJp v$Pod::PerldocJp::VERSION based on Perldoc v$Pod::Perldoc::VERSION]
EOUSAGE

    CORE::die encode($term_encoding => $usage);
  }
}

1;

__END__