The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

ISHIGAKI / Pod-Perldocs-0.17 / lib / Pod / Perldocs.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
—
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138

              
package Pod::Perldocs;
use strict;
use warnings;
require Pod::Perldoc;
use LWP::UserAgent;
use base qw(Pod::Perldoc);
our ($VERSION);
$VERSION = '0.17';
################################################################
# Change the following to reflect your setup
my $soap_uri = 'http://theoryx5.uwinnipeg.ca/Apache/DocServer';
my $soap_proxy = 'http://theoryx5.uwinnipeg.ca/cgi-bin/docserver.cgi';
my $pod_server = q{http://cpan.uwinnipeg.ca/cgi-bin/podserver.cgi};
###############################################################
sub grand_search_init {
  my($self, $pages, @found) = @_;
  @found = $self->SUPER::grand_search_init($pages, @found);
  return @found if @found;
  print STDERR "Searching on remote pod server ...\n";
  my $filename;
  if ($filename = get_lwp($self, $pages->[0])) {
    push @found, $filename;
    return @found;
  }
  elsif ($filename = get_soap($self, $pages->[0])) {
    push @found, $filename;
    return @found;
  }
  else {
    return @found;
  }
}
sub get_lwp {
  my ($self, $mod) = @_;
  my $ua = LWP::UserAgent->new;
  $ua->agent("Pod/Perldocs 0.16 ");
  push @{ $ua->requests_redirectable }, 'POST';
  # Create a request
  my $req = HTTP::Request->new(POST => $pod_server);
  $req->content_type('application/x-www-form-urlencoded');
  $req->content("mod=$mod");
  # Pass request to the user agent and get a response back
  my $res = $ua->request($req);
  # Check the outcome of the response
  if ($res->is_success) {
    my ($fh, $filename) = $self->new_tempfile();
    print $fh $res->content;
    return $filename;
  }
  else {
    print STDERR "Remote server returned status code: " . $res->status_line . "\n";
    return;
  }
}
sub get_soap {
  my ($self, $mod) = @_;
  my $soap = make_soap() or return; # no SOAP::Lite available
  my $result = $soap->get_doc($mod);
  defined $result && defined $result->result or do {
    print STDERR "No matches found there either.\n";
    return;
  };
  my $lines = $result->result();
  unless ($lines and ref($lines) eq 'ARRAY') {
    print STDERR "Documentation not found there either.\n";
    return;
  }
  my ($fh, $filename) = $self->new_tempfile();
  print $fh @$lines;
  return $filename;
}
sub make_soap {
  unless (eval { require SOAP::Lite }) {
    print STDERR "SOAP::Lite is unavailable to make remote call\n";
    return undef;
  }
  return SOAP::Lite
    ->uri($soap_uri)
      ->proxy($soap_proxy,
              options => {compress_threshold => 10000})
        ->on_fault(sub { my($soap, $res) = @_; 
                         print STDERR "SOAP Fault: ", 
                           (ref $res ? $res->faultstring 
                                     : $soap->transport->status),
                           "\n";
                         return undef;
                       });
}
1;
=head1 NAME
Pod::Perldocs - view remote pod via Pod::Perldoc
=head1 DESCRIPTION
This is a drop-in replacement for C<perldoc> based on
C<Pod::Perldoc>. Usage is the same, except in the case
when documentation for a module cannot be found on the
local machine, in which case a query (via LWP or SOAP::Lite) will
be made to a remote pod repository and, if the documentation is
found there, the results will be displayed as usual.
=head1 NOTE
The values of C<$pod_server>, C<$soap_uri> and
C<$soap_proxy> at the top of this script reflect
the location of the remote pod repository.
=head1 SERVER
See the I<CPAN-Search-Lite> project on SourceForge at
L<http://sourceforge.net/projects/cpan-search/>
for the software needed to set up a remote pod
repository used by C<perldocs>.
=head1 SEE ALSO
L<Pod::Perldoc>.
=head1 COPYRIGHT
This software is copyright 2004,2009 by Randy Kobes
E<lt>r.kobes@uwinnipeg.caE<gt>. Usage and redistribution
is under the same terms as Perl itself.
=head1 CURRENT MAINTAINER
Kenichi Ishigaki E<lt>ishigaki@cpan.orgE<gt>
=cut