File Coverage

blib/lib/Pod/POM/Web.pm
Criterion Covered Total %
statement 459 631 72.7
branch 121 218 55.5
condition 38 87 43.6
subroutine 71 90 78.8
pod 3 37 8.1
total 692 1063 65.1


line stmt bran cond sub pod time code
1             #======================================================================
2             package Pod::POM::Web; # see doc at end of file
3             #======================================================================
4 1     1   123580 use strict;
  1         10  
  1         31  
5 1     1   6 use warnings;
  1         2  
  1         32  
6 1     1   27 use 5.008;
  1         6  
7 1     1   6 no warnings 'uninitialized';
  1         2  
  1         57  
8              
9 1     1   695 use Pod::POM 0.25; # parsing Pod
  1         25027  
  1         74  
10 1     1   13 use List::Util qw/max/; # maximum
  1         3  
  1         211  
11 1     1   812 use List::MoreUtils qw/uniq firstval any/;
  1         14419  
  1         9  
12 1     1   4735 use Module::CoreList; # asking if a module belongs to Perl core
  1         114082  
  1         20  
13 1     1   1866 use HTTP::Daemon; # for the builtin HTTP server
  1         74462  
  1         19  
14 1     1   648 use URI; # parsing incoming requests
  1         2  
  1         31  
15 1     1   639 use URI::QueryParam; # implements URI->query_form_hash
  1         984  
  1         39  
16 1     1   578 use MIME::Types; # translate file extension into MIME type
  1         4670  
  1         76  
17 1     1   689 use Alien::GvaScript 1.021000; # javascript files
  1         3698  
  1         39  
18 1     1   10 use Config; # where are the script directories
  1         3  
  1         55  
19 1     1   921 use Getopt::Long qw/GetOptions/; # parsing options from command-line
  1         11115  
  1         7  
20 1     1   259 use Module::Metadata 1.000033; # get version number from module
  1         29  
  1         31  
21 1     1   785 use Encode qw/decode encode_utf8/;
  1         17519  
  1         121  
22 1     1   567 use Encode::Detect;
  1         3787  
  1         359  
23              
24              
25             #----------------------------------------------------------------------
26             # globals
27             #---------------------------------------------------------------------
28              
29             our $VERSION = '1.24';
30              
31             # some subdirs never contain Pod documentation
32             my @ignore_toc_dirs = qw/auto unicore/;
33              
34             # directories for modules -- filter @INC (we don't want '.', nor server_root added by mod_perl)
35             my $server_root = eval {Apache2::ServerUtil::server_root()} || "";
36             our                # because accessed from Pod::POM::Web::Indexer
37               @default_module_dirs = grep {!/^\./ && $_ ne $server_root} @INC;
38              
39             # directories for executable perl scripts
40             my @config_script_dirs = qw/sitescriptexp vendorscriptexp scriptdirexp/;
41             my @default_script_dirs = grep {$_} @Config{@config_script_dirs};
42              
43             # syntax coloring (optional)
44             my $coloring_package
45               = eval {require PPI::HTML} ? "PPI"
46               : eval {require ActiveState::Scineplex} ? "SCINEPLEX"
47               : "";
48              
49             # full-text indexing (optional)
50             my $no_indexer = eval {require Pod::POM::Web::Indexer} ? 0 : $@;
51              
52             # CPAN latest version info (tentative, but disabled because CPAN is too slow)
53             my $has_cpan = 0; # eval {require CPAN};
54              
55             # A sequence of optional filters to apply to the source code before
56             # running it through Pod::POM. Source code is passed in $_[0] and
57             # should be modified in place.
58             my @podfilters = (
59              
60             # Pod::POM fails to parse correctly when there is an initial blank line
61               sub { $_[0] =~ s/\A\s*// },
62              
63             );
64              
65              
66             our # because used by Pod::POM::View::HTML::_PerlDoc
67               %escape_entity = ('&' => '&',
68                                 '<' => '&lt;',
69                                 '>' => '&gt;',
70                                 '"' => '&quot;');
71              
72              
73             #----------------------------------------------------------------------
74             # import : just export the "server" function if called from command-line
75             #----------------------------------------------------------------------
76              
77             sub import {
78 1     1   17   my $class = shift;
79 1         5   my ($package, $filename) = caller;
80              
81 1     1   15   no strict 'refs';
  1         2  
  1         8443  
82 0     0   0   *{'main::server'} = sub {$class->server(@_)}
  0         0  
83 1 50 33     26     if $package eq 'main' and $filename eq '-e';
84             }
85              
86             #----------------------------------------------------------------------
87             # CLASS METHODS -- main entry point
88             #----------------------------------------------------------------------
89              
90             sub server { # builtin HTTP server; unused if running under Apache
91 0     0 1 0   my ($class, $port, $options) = @_;
92              
93 0   0     0   $options ||= $class->_options_from_cmd_line;
94 0   0     0   $port ||= $options->{port} || 8080;
      0        
95              
96 0 0       0   my $daemon = HTTP::Daemon->new(LocalPort => $port,
97                                              ReuseAddr => 1) # patch by CDOLAN
98                 or die "could not start daemon on port $port";
99 0         0   print STDERR "$class listening for requests at URL: ", $daemon->url, "\n";
100              
101             # main server loop
102 0         0   while (my $client_connection = $daemon->accept) {
103 0         0     while (my $req = $client_connection->get_request) {
104 0         0       print STDERR "URL : " , $req->url, "\n";
105 0         0       $client_connection->force_last_request; # patch by CDOLAN
106 0         0       my $response = HTTP::Response->new;
107 0         0       $class->handler($req, $response, $options);
108 0         0       $client_connection->send_response($response);
109                 }
110 0         0     $client_connection->close;
111 0         0     undef($client_connection);
112               }
113             }
114              
115              
116             sub _options_from_cmd_line {
117 1     1   664   GetOptions \my %options,
118                 'port=i',
119                 'page_title|title=s',
120                 'module_dirs|mdirs=s@{,}',
121                 'script_dirs|sdirs=s@{,}',
122                 ;
123              
124 1         442   push @{$options{module_dirs}}, @default_module_dirs;
  1         7  
125 1         3   push @{$options{script_dirs}}, @default_script_dirs;
  1         5  
126              
127 1 50 0     5   $options{port} ||= $ARGV[0] if @ARGV; # backward support for old API
128 1         3   return \%options;
129             }
130              
131             sub handler : method {
132 10     10 1 16670   my ($class, $request, $response, $options) = @_;
133              
134 10         41   my $handler_obj = $class->new($request, $response, $options);
135              
136 10         38   eval { $handler_obj->dispatch_request(); 1}
  10         3664  
137 10 50       21     or do {
138 0         0       my $error = $@;
139 0 0       0       if ($error =~ /No file for '(.*)'/) {
140 0         0         $handler_obj->send_content({content => $handler_obj->_no_such_module($1),
141                                                 code => 403});
142                   }
143                   else {
144 0         0         $handler_obj->send_content({content => $error,
145                                                 code => 500});
146                   }
147               };
148              
149 10         103   return 0; # Apache2::Const::OK;
150             }
151              
152              
153             #----------------------------------------------------------------------
154             # CONSTRUCTOR for the "handler object" -- instantiated at each request
155             #----------------------------------------------------------------------
156              
157              
158             sub new {
159 10     10 0 32   my ($class, $request, $response, $options) = @_;
160 10   50     32   $options ||= {};
161 10         43   my $self = {%$options};
162              
163             # cheat: will create an instance of the Indexer subclass if possible
164 10 50 33     41   if (!$no_indexer && $class eq __PACKAGE__) {
165 0         0     $class = "Pod::POM::Web::Indexer";
166               }
167 10         32   for (ref $request) {
168              
169 10 50       38     /^Apache/ and do { # coming from mod_perl
170 0         0       my $path = $request->path_info;
171 0         0       my $q = URI->new;
172 0         0       $q->query($request->args);
173 0         0       my $params = $q->query_form_hash;
174 0         0       (my $uri = $request->uri) =~ s/$path$//;
175 0         0       $self->{response} = $request; # Apache API: same object for both
176 0         0       $self->{root_url} = $uri;
177 0         0       $self->{path} = $path;
178 0         0       $self->{params} = $params;
179 0         0       last;
180                 };
181              
182 10 50       56     /^HTTP/ and do { # coming from HTTP::Daemon // server() method above
183 10         26       $self->{response} = $response;
184 10         26       $self->{root_url} = "";
185 10         33       $self->{path} = $request->url->path;
186 10         267       $self->{params} = $request->url->query_form_hash;
187 10         551       last;
188                 };
189              
190             #otherwise (coming from cgi-bin or mod_perl Registry)
191 0         0     my $q = URI->new;
192 0         0     $q->query($ENV{QUERY_STRING});
193 0         0     my $params = $q->query_form_hash;
194 0         0     $self->{response} = undef;
195 0         0     $self->{root_url} = $ENV{SCRIPT_NAME};
196 0         0     $self->{path} = $ENV{PATH_INFO};
197 0         0     $self->{params} = $params;
198               }
199              
200 10         29   bless $self, $class;
201             }
202              
203             #----------------------------------------------------------------------
204             # INSTANCE METHODS for the "handler object"
205             #----------------------------------------------------------------------
206              
207              
208 20     20 1 37 sub module_dirs {@{shift->{module_dirs}}}
  20         149  
209 0     0 0 0 sub script_dirs {@{shift->{script_dirs}}}
  0         0  
210              
211             sub dispatch_request {
212 10     10 0 24   my ($self) = @_;
213 10         31   my $path_info = $self->{path};
214              
215             # security check : no outside directories
216 10 50       58   $path_info =~ m[(\.\.|//|\\|:)] and die "illegal path: $path_info";
217              
218 10 100       59   $path_info =~ s[^/][] or return $self->index_frameset;
219 9         27   for ($path_info) {
220 9 100       39     /^$/ and return $self->index_frameset;
221 8 100       37     /^index$/ and return $self->index_frameset;
222 7 100       30     /^toc$/ and return $self->main_toc;
223 6 100       33     /^toc\/(.*)$/ and return $self->toc_for($1); # Ajax calls
224 5 50       17     /^script\/(.*)$/ and return $self->serve_script($1);
225 5 100       25     /^search$/ and return $self->dispatch_search;
226 3 100       19     /^source\/(.*)$/ and return $self->serve_source($1);
227              
228             # for debugging
229 2 50       8     /^_dirs$/ and return $self->send_html(
230                   join "<br>", "<b>Modules</b>" => $self->module_dirs,
231                                "<b>Scripts</b>" => $self->script_dirs,
232                   );
233              
234             # file extension : passthrough
235 2 100       15     /\.(\w+)$/ and return $self->serve_file($path_info, $1);
236              
237             #otherwise
238 1         6     return $self->serve_pod($path_info);
239               }
240             }
241              
242              
243             sub index_frameset{
244 3     3 0 6   my ($self) = @_;
245              
246             # initial page to open
247 3         6   my $ini = $self->{params}{open};
248 3   50     13   my $ini_content = $ini || "perl";
249 3 50       8   my $ini_toc = $ini ? "toc?open=$ini" : "toc";
250              
251             # HTML title
252 3   50     11   my $title = $self->{page_title} || 'Perl documentation';
253 3         28   $title =~ s/([&<>"])/$escape_entity{$1}/g;
254              
255 3         21   return $self->send_html(<<__EOHTML__);
256             <html>
257             <head><title>$title</title></head>
258             <frameset cols="25%, 75%">
259             <frame name="tocFrame" src="$self->{root_url}/$ini_toc">
260             <frame name="contentFrame" src="$self->{root_url}/$ini_content">
261             </frameset>
262             </html>
263             __EOHTML__
264             }
265              
266              
267              
268              
269             #----------------------------------------------------------------------
270             # serving a single file
271             #----------------------------------------------------------------------
272              
273             sub serve_source {
274 1     1 0 4   my ($self, $path) = @_;
275              
276 1         51   my $params = $self->{params};
277              
278             # default (if not printing): line numbers and syntax coloring are on
279 1 50       9   $params->{print} or $params->{lines} = $params->{coloring} = 1;
280              
281 1 50       5   my @files = $self->find_source($path) or die "No file for '$path'";
282 1         3   my $mtime = max map {(stat $_)[9]} @files;
  1         22  
283              
284 1         4   my $display_text;
285              
286 1         3   foreach my $file (@files) {
287 1         6     my $text = decode("Detect", $self->slurp_file($file, ":raw"));
288 1         693     $text =~ s/\r\n/\n/g;
289              
290                 my $view = $self->mk_view(
291                   line_numbering => $params->{lines},
292 1 50       10       syntax_coloring => ($params->{coloring} ? $coloring_package : "")
293                  );
294 1         7     $text = $view->view_verbatim($text);
295 1         119     $display_text .= "<p/><h2>$file</h2><p/><pre>$text</pre>";
296               }
297              
298              
299 1 50       9   my $offer_print = $params->{print} ? "" : <<__EOHTML__;
300             <form method="get" target="_blank">
301             <input type="submit" name="print" value="Print"> with<br>
302             <input type="checkbox" name="lines" checked>line numbers<br>
303             <input type="checkbox" name="coloring" checked>syntax coloring
304             </form>
305             __EOHTML__
306              
307 1 50       9   my $script = $params->{print} ? <<__EOHTML__ : "";
308             <script>
309             window.onload = function () {window.print()};
310             </script>
311             __EOHTML__
312              
313 1 50       8   my $doc_link = $params->{print} ? "" : <<__EOHTML__;
314             <a href="$self->{root_url}/$path" style="float:right">Doc</a>
315             __EOHTML__
316              
317 1         110   my $html = <<__EOHTML__;
318             <html>
319             <head>
320             <title>Source of $path</title>
321             <link href="$self->{root_url}/Alien/GvaScript/lib/GvaScript.css" rel="stylesheet" type="text/css">
322             <link href="$self->{root_url}/Pod/POM/Web/lib/PodPomWeb.css" rel="stylesheet" type="text/css">
323             <style>
324             PRE {border: none; background: none}
325             FORM {float: right; font-size: 70%; border: 1px solid}
326             </style>
327             </head>
328             <body>
329             $doc_link
330             <h1>Source of $path</h1>
331            
332             $offer_print
333            
334             $display_text
335             </body>
336             </html>
337             __EOHTML__
338              
339 1         12   $self->send_html($html, $mtime);
340              
341             }
342              
343              
344             sub serve_file {
345 1     1 0 5   my ($self, $path, $extension) = @_;
346              
347 1 50   6   9   my $fullpath = firstval {-f $_} map {"$_/$path"} $self->module_dirs
  6         97  
  8         28  
348                 or die "could not find $path";
349              
350 1         17   my $mime_type = MIME::Types->new->mimeTypeOf($extension);
351 1         55181   my $content = $self->slurp_file($fullpath, ":raw");
352 1         22   my $mtime = (stat $fullpath)[9];
353 1         11   $self->send_content({
354                 content => $content,
355                 mtime => $mtime,
356                 mime_type => $mime_type,
357               });
358             }
359              
360              
361              
362             sub serve_pod {
363 1     1 0 4   my ($self, $path) = @_;
364 1         4   $path =~ s[::][/]g; # just in case, if called as /perldoc/Foo::Bar
365              
366             # if several sources, will be first *.pod, then *.pm
367 1 50       7   my @sources = $self->find_source($path) or die "No file for '$path'";
368 1         6   my $mtime = max map {(stat $_)[9]} @sources;
  1         23  
369 1 50       10   my $content = $path =~ /\bperltoc\b/
370                                ? $self->fake_perltoc
371                                : $self->slurp_file($sources[0], ":crlf");
372              
373 1         9   (my $mod_name = $path) =~ s[/][::]g;
374 1 50       11   my $version = @sources > 1
375                 ? $self->parse_version($self->slurp_file($sources[-1], ":crlf"), $mod_name)
376                 : $self->parse_version($content, $mod_name);
377              
378 1         29   for my $filter (@podfilters) {
379 1         5     $filter->($content);
380               }
381              
382             # special handling for perlfunc: change initial C<..> to hyperlinks
383 1 50       6   if ($path =~ /\bperlfunc$/) {
384 0     0   0     my $sub = sub {my $txt = shift; $txt =~ s[C<(.*?)>][C<L</$1>>]g; $txt};
  0         0  
  0         0  
  0         0  
385 0         0     $content =~ s[(Perl Functions by Category)(.*?)(Alphabetical Listing)]
  0         0  
386             [$1 . $sub->($2) . $3]es;
387               }
388 1         12  
389 1 50       24   my $parser = Pod::POM->new;
390 1         13380   my $pom = $parser->parse_text($content) or die $parser->error;
391               my $view = $self->mk_view(version => $version,
392                                         mtime => $mtime,
393                                         path => $path,
394                                         mod_name => $mod_name,
395                                         syntax_coloring => $coloring_package);
396 1         6  
397               my $html = $view->print($pom);
398              
399 1 50       193 # again special handling for perlfunc : ids should be just function names
400 0         0   if ($path =~ /\bperlfunc$/) {
401                 $html =~ s/li id="(.*?)_.*?"/li id="$1"/g;
402               }
403              
404 1 50       5 # special handling for 'perl' : hyperlinks to man pages
405 0     0   0   if ($path =~ /\bperl$/) {
406 0         0     my $sub = sub {my $txt = shift;
407 0         0                    $txt =~ s[(perl\w+)]
  0         0  
408 0         0 [<a href="$self->{root_url}/$1">$1</a>]g;
  0         0  
409                                return $txt};
410                 $html =~ s[(<pre.*?</pre>)][$sub->($1)]egs;
411 1         6   }
412              
413               return $self->send_html($html, $mtime);
414             }
415 0     0 0 0  
416             sub fake_perltoc {
417 0         0   my ($self) = @_;
418              
419               return "=head1 NAME\n\nperltoc\n\n=head1 DESCRIPTION\n\n"
420                    . "I<Sorry, this page cannot be displayed in HTML by Pod:POM::Web "
421                    . "(too CPU-intensive). "
422                    . "If you really need it, please consult the source, using the link "
423                    . "in the top-right corner.>";
424             }
425              
426 0     0 0 0  
427             sub serve_script {
428 0         0   my ($self, $path) = @_;
429              
430               my $fullpath;
431 0         0  
432 0         0  DIR:
433 0         0   foreach my $dir ($self->script_dirs) {
434 0 0       0     foreach my $ext ("", ".pl", ".bat") {
435                   $fullpath = "$dir/$path$ext";
436                   last DIR if -f $fullpath;
437                 }
438 0 0       0   }
439              
440 0         0   $fullpath or die "no such script : $path";
441 0         0  
442               my $content = $self->slurp_file($fullpath, ":crlf");
443 0         0   my $mtime = (stat $fullpath)[9];
444 0         0  
445               for my $filter (@podfilters) {
446                 $filter->($content);
447 0         0   }
448 0 0       0  
449 0         0   my $parser = Pod::POM->new;
450               my $pom = $parser->parse_text($content) or die $parser->error;
451               my $view = $self->mk_view(path => "scripts/$path",
452 0         0                               mtime => $mtime,
453                                           syntax_coloring => $coloring_package);
454 0         0   my $html = $view->print($pom);
455              
456               return $self->send_html($html, $mtime);
457             }
458              
459 16     16 0 2600  
460             sub find_source {
461               my ($self, $path) = @_;
462 16 50       80  
463             # serving a script ? # TODO : factorize common code with serve_script
464 0         0   if ($path =~ s[^scripts/][]) {
465 0         0   DIR:
466 0 0       0     foreach my $dir ($self->script_dirs) {
467 0         0       foreach my $ext ("", ".pl", ".bat") {
468                     -f "$dir/$path$ext" or next;
469                     return ("$dir/$path$ext");
470 0         0       }
471                 }
472                 return;
473               }
474 16         66  
475 124         487 # otherwise, serving a module
  496         7905  
476               foreach my $prefix ($self->module_dirs) {
477                 my @found = grep {-f} ("$prefix/$path.pod",
478                                         "$prefix/$path.pm",
479 124 100       535                             "$prefix/pod/$path.pod",
480                                         "$prefix/pods/$path.pod");
481 0         0     return @found if @found;
482               }
483               return;
484             }
485              
486 11     11 0 31  
487 11         49 sub pod2pom {
488               my ($self, $sourcefile) = @_;
489 11         88   my $content = $self->slurp_file($sourcefile, ":crlf");
490 11         123  
491               for my $filter (@podfilters) {
492                 $filter->($content);
493 11         145   }
494 11 50       293  
495 11         1435546   my $parser = Pod::POM->new;
496               my $pom = $parser->parse_text($content) or die $parser->error;
497               return $pom;
498             }
499 0     0   0  
500             sub _no_such_module {
501 0         0   my ($self, $module) = @_;
502 0         0  
503 0         0   $module =~ s!/!::!g;
504               $module =~ s/([&<>"])/$escape_entity{$1}/g;
505               return <<__EOHTML__;
506             <html>
507             <head>
508             <title>$module not found</title>
509             </head>
510             <body>
511             <h1>$module not found</h1>
512             <p>
513             The module <code>$module</code> could not be found on this server.
514             It may not be installed locally. Please try
515             <a href='https://metacpan.org/pod/$module'>$module on Metacpan</a>.
516             </p>
517             </body>
518             </html>
519             __EOHTML__
520             }
521              
522              
523             #----------------------------------------------------------------------
524             # tables of contents
525             #----------------------------------------------------------------------
526              
527 1     1 0 5  
528             sub toc_for { # partial toc (called through Ajax)
529               my ($self, $prefix) = @_;
530 1         3  
531 1 50       5 # special handling for builtin paths
532 1 50       4   for ($prefix) {
533 1 50       6     /^perldocs$/ and return $self->toc_perldocs;
534                 /^pragmas$/ and return $self->toc_pragmas;
535                 /^scripts$/ and return $self->toc_scripts;
536               }
537 1         5  
538 1 50       7 # otherwise, find and htmlize entries under a given prefix
539 0         0   my $entries = $self->find_entries_for($prefix);
540               if ($prefix eq 'Pod') { # Pod/perl* should not appear under Pod
541 1         7     delete $entries->{$_} for grep /^perl/, keys %$entries;
542               }
543               return $self->send_html($self->htmlize_entries($entries));
544             }
545              
546 0     0 0 0  
547             sub toc_perldocs {
548 0         0   my ($self) = @_;
549              
550               my %perldocs;
551 0         0  
552 0         0 # perl basic docs may be found under "pod", "pods", or the root dir
553               for my $subdir (qw/pod pods/, "") {
554                 my $entries = $self->find_entries_for($subdir);
555 0         0  
556 0         0 # just keep the perl* entries, without subdir prefix
557 0         0     foreach my $key (grep /^perl/, keys %$entries) {
558                   $perldocs{$key} = $entries->{$key};
559                   $perldocs{$key}{node} =~ s[^subdir/][]i;
560                 }
561 0         0   }
562              
563               return $self->send_html($self->htmlize_perldocs(\%perldocs));
564             }
565              
566              
567 0     0 0 0  
568             sub toc_pragmas {
569 0         0   my ($self) = @_;
570 0         0  
571 0 0       0   my $entries = $self->find_entries_for(""); # files found at root level
  0         0  
572               delete $entries->{$_} for @ignore_toc_dirs, qw/pod pods inc/;
573 0         0   delete $entries->{$_} for grep {/^perl/ or !/^[[:lower:]]/} keys %$entries;
574              
575               return $self->send_html($self->htmlize_entries($entries));
576             }
577              
578 0     0 0 0  
579             sub toc_scripts {
580 0         0   my ($self) = @_;
581              
582               my %scripts;
583 0         0  
584 0 0       0 # gather all scripts and group them by initial letter
585               foreach my $dir ($self->script_dirs) {
586 0         0     opendir my $dh, $dir or next;
587 0         0   NAME:
588 0 0 0     0     foreach my $name (readdir $dh) {
      0        
589                   for ("$dir/$name") {
590 0         0         -x && !-d && -T or next NAME ; # try to just keep Perl executables
591 0         0       }
592 0         0       $name =~ s/\.(pl|bat)$//i;
593                   my $letter = uc substr $name, 0, 1;
594                   $scripts{$letter}{$name} = {node => "script/$name", pod => 1};
595                 }
596               }
597 0         0  
598 0         0 # htmlize the structure
599 0         0   my $html = "";
600 0         0   foreach my $letter (sort keys %scripts) {
601                 my $content = $self->htmlize_entries($scripts{$letter});
602                 $html .= closed_node(label => $letter,
603                                      content => $content);
604 0         0   }
605              
606               return $self->send_html($html);
607             }
608              
609 1     1 0 3  
610             sub find_entries_for {
611               my ($self, $prefix) = @_;
612              
613 1         3 # if $prefix is of shape A*, we want top-level modules starting
614 1 50       4 # with that letter
615 0         0   my $filter;
616 0         0   if ($prefix =~ /^([A-Z])\*/) {
617                 $filter = qr/^$1/;
618                 $prefix = "";
619 1         2   }
620              
621 1         4   my %entries;
622 8 50       31  
623 8 100       300   foreach my $root_dir ($self->module_dirs) {
624 2         74     my $dirname = $prefix ? "$root_dir/$prefix" : $root_dir;
625 15 100       65     opendir my $dh, $dirname or next;
626 11 50 33     25     foreach my $name (readdir $dh) {
627 11         185       next if $name =~ /^\./;
628 11         76       next if $filter and $name !~ $filter;
629                   my $is_dir = -d "$dirname/$name";
630                   my $has_pod = $name =~ s/\.(pm|pod)$//;
631 11 50 66     39  
  16         86  
632             # skip if this subdir is a member of @INC (not a real module namespace)
633 11 50 66     41       next if $is_dir and grep {m[^\Q$dirname/$name\E]} $self->module_dirs;
634 11 50       57  
635 11 100       28       if ($is_dir || $has_pod) { # found a TOC entry
636 11 100       76         $entries{$name}{node} = $prefix ? "$prefix/$name" : $name;
637                     $entries{$name}{dir} = 1 if $is_dir;
638                     $entries{$name}{pod} = 1 if $has_pod;
639                   }
640 1         7     }
641               }
642               return \%entries;
643             }
644              
645 0     0 0 0  
646 0         0 sub htmlize_perldocs {
647               my ($self, $perldocs) = @_;
648               my $parser = Pod::POM->new;
649 0 0       0  
650             # Pod/perl.pom Synopsis contains a classification of perl*.pod documents
651 0         0   my ($perlpod) = $self->find_source("perl", ":crlf")
652 0 0       0       or die "'perl.pod' does not seem to be installed on this system";
653               my $source = $self->slurp_file($perlpod);
654 0     0   0   my $perlpom = $parser->parse_text($source) or die $parser->error;
655 0   0 0   0  
  0         0  
656 0         0   my $h1 = (firstval {$_->title eq 'GETTING HELP'} $perlpom->head1)
657                      || (firstval {$_->title eq 'SYNOPSIS'} $perlpom->head1);
658               my $html = "";
659 0         0  
660 0         0 # classified pages mentioned in the synopsis
661 0         0   foreach my $h2 ($h1->head2) {
662                 my $title = $h2->title;
663                 my $content = $h2->verbatim;
664 0         0  
665             # "Internals and C-Language Interface" is too long
666                 $title =~ s/^Internals.*/Internals/;
667 0         0  
668 0         0 # gather leaf entries
669 0         0     my @leaves;
670 0 0       0     while ($content =~ /^\s*(perl\S*?)\s*\t(.+)/gm) {
671                   my ($ref, $descr) = ($1, $2);
672                   my $entry = delete $perldocs->{$ref} or next;
673 0         0       push @leaves, {label => $ref,
674                                  href => $entry->{node},
675                                  attrs => qq{id='$ref' title='$descr'}};
676 0         0     }
677 0         0 # sort and transform into HTML
  0         0  
678 0         0     @leaves = map {leaf(%$_)}
679                           sort {$a->{label} cmp $b->{label}} @leaves;
680                 $html .= closed_node(label => $title,
681                                      content => join("\n", @leaves));
682               }
683 0 0       0  
684 0         0 # maybe some remaining pages
685               if (keys %$perldocs) {
686                 $html .= closed_node(label => 'Unclassified',
687                                      content => $self->htmlize_entries($perldocs));
688 0         0   }
689              
690               return $html;
691             }
692              
693              
694              
695 1     1 0 5  
696 1         4 sub htmlize_entries {
697 1         13   my ($self, $entries) = @_;
  21         37  
698 9         20   my $html = "";
699 9         28   foreach my $name (sort {uc($a) cmp uc($b)} keys %$entries) {
700 9         30     my $entry = $entries->{$name};
701                 (my $id = $entry->{node}) =~ s[/][::]g;
702                 my %args = (class => 'TN_leaf',
703 9 100       21                 label => $name,
704 2         7                 attrs => qq{id='$id'});
705 2         6     if ($entry->{dir}) {
706                   $args{class} = 'TN_node TN_closed';
707 9 50       20       $args{attrs} .= qq{ TN:contentURL='toc/$entry->{node}'};
708 9         19     }
709 9         19     if ($entry->{pod}) {
710                   $args{href} = $entry->{node};
711 9         23       $args{abstract} = $self->get_abstract($entry->{node});
712                 }
713 1         5     $html .= generic_node(%args);
714               }
715               return $html;
716       9 0   }
717              
718             sub get_abstract {
719             # override in indexer
720             }
721              
722              
723              
724 1     1 0 3  
725             sub main_toc {
726               my ($self) = @_;
727 1         5  
728 1 50       5 # initial page to open
729               my $ini = $self->{params}{open};
730               my $select_ini = $ini ? "selectToc('$ini');" : "";
731 1         6  
  226         4405  
  378         407976  
732 1         63 # perlfunc entries in JSON format for the DHTML autocompleter
733 1         42027   my @funcs = map {$_->title} grep {$_->content =~ /\S/} $self->perlfunc_items;
  224         9608  
734               s|[/\s(].*||s foreach @funcs;
735               my $json_funcs = "[" . join(",", map {qq{"$_"}} uniq @funcs) . "]";
736 1         56  
  140         3469  
  161         104175  
  85         137  
737 1         43 # perlVAR entries in JSON format for the DHTML autocompleter
738 1         28946   my @vars = map {$_->title} grep {!/->/} map {@$_} $self->perlvar_items;
739 1         2442   s|\s*X<.*||s foreach @vars;
740 1         2212   s|\\|\\\\|g foreach @vars;
  140         6974  
741               s|"|\\"|g foreach @vars;
742 1 50       39   my $json_vars = "[" . join(",", map {qq{"$_"}} uniq @vars) . "]";
743              
744 1         4   my $js_no_indexer = $no_indexer ? 'true' : 'false';
  3         17  
745              
746               my @perl_sections = map {closed_node(
747                   label => ucfirst($_),
748                   label_class => "TN_label small_title",
749                   attrs => qq{TN:contentURL='toc/$_' id='$_'},
750 1         4      )} qw/perldocs pragmas scripts/;
751 1         9  
752 26         56   my $alpha_list = "";
753               for my $letter ('A' .. 'Z') {
754                 $alpha_list .= closed_node (
755                   label => $letter,
756                   label_class => "TN_label",
757                   attrs => qq{TN:contentURL='toc/$letter*' id='${letter}:'},
758 1         3      );
759               }
760               my $modules = generic_node (label => "Modules",
761                                           label_class => "TN_label small_title",
762                                           content => $alpha_list);
763 1         91  
764              
765               return $self->send_html(<<__EOHTML__);
766             <html>
767             <head>
768             <base target="contentFrame">
769             <link href="$self->{root_url}/Alien/GvaScript/lib/GvaScript.css"
770             rel="stylesheet" type="text/css">
771             <link href="$self->{root_url}/Pod/POM/Web/lib/PodPomWeb.css"
772             rel="stylesheet" type="text/css">
773             <script src="$self->{root_url}/Alien/GvaScript/lib/prototype.js"></script>
774             <script src="$self->{root_url}/Alien/GvaScript/lib/GvaScript.js"></script>
775             <script>
776             var treeNavigator;
777             var perlfuncs = $json_funcs;
778             var perlvars = $json_vars;
779             var completers = {};
780             var no_indexer = $js_no_indexer;
781            
782             function submit_on_event(event) {
783             \$('search_form').submit();
784             }
785            
786             function resize_tree_navigator() {
787             // compute available height -- comes either from body or documentElement,
788             // depending on browser and on compatibility mode !!
789             var doc_el_height = document.documentElement.clientHeight;
790             var avail_height
791             = (Prototype.Browser.IE && doc_el_height) ? doc_el_height
792             : document.body.clientHeight;
793            
794             var tree_height = avail_height - \$('toc_frame_top').scrollHeight - 5;
795             if (tree_height > 100)
796             \$('TN_tree').style.height = tree_height + "px";
797             }
798            
799             function open_nodes(first_node, rest) {
800            
801             var node = \$(first_node);
802             if (!node || !treeNavigator) return;
803            
804             // shift to next node in sequence
805             first_node = rest.shift();
806            
807             // build a handler for "onAfterLoadContent" (closure on first_node/rest)
808             var open_or_select_next = function() {
809            
810             // delete handler that might have been placed by previous call
811             delete treeNavigator.onAfterLoadContent;
812            
813             //
814             if (rest.length > 0) {
815             open_nodes(first_node, rest)
816             }
817             else {
818             treeNavigator.openEnclosingNodes(\$(first_node));
819             treeNavigator.select(\$(first_node));
820             }
821             };
822            
823            
824             // if node is closed and currently has no content, we need to register
825             // a handler, open the node so that it gets its content by Ajax,
826             // and then execute the handler to open the rest after Ajax returns
827             if (treeNavigator.isClosed(node)
828             && !treeNavigator.content(node)) {
829             treeNavigator.onAfterLoadContent = open_or_select_next;
830             treeNavigator.open(node);
831             }
832             // otherwise just a direct call
833             else {
834             open_or_select_next();
835             }
836            
837             }
838            
839            
840             function selectToc(entry) {
841            
842             // build array of intermediate nodes (i.e "Foo", "Foo::Bar", etc.)
843             var parts = entry.split(new RegExp("/|::"));
844             var accu = '';
845             var sequence = parts.map(function(e) {
846             accu = accu ? (accu + "::" + e) : e;
847             return accu;
848             });
849            
850             // choose id of first_node by analysis of entry
851             var initial = entry.substr(0, 1);
852             var first_node
853            
854             // CASE module (starting with uppercase)
855             = (initial <= 'Z') ? (initial + ":")
856            
857             // CASE perl* documentation page
858             : entry.search(/^perl/) > -1 ? "perldocs"
859            
860             // CASE other lowercase entries
861             : "pragmas"
862             ;
863            
864             // open each node in sequence
865             open_nodes(first_node, sequence);
866             }
867            
868             function setup() {
869            
870             treeNavigator
871             = new GvaScript.TreeNavigator('TN_tree', {tabIndex:-1});
872            
873             completers.perlfunc = new GvaScript.AutoCompleter(
874             perlfuncs,
875             {minimumChars: 1,
876             minWidth: 100,
877             offsetX: -20,
878             autoSuggestDelay: 400});
879             completers.perlfunc.onComplete = submit_on_event;
880            
881             completers.perlvar = new GvaScript.AutoCompleter(
882             perlvars,
883             {minimumChars: 1,
884             minWidth: 100,
885             offsetX: -20,
886             autoSuggestDelay: 400});
887             completers.perlvar.onComplete = submit_on_event;
888            
889             if (!no_indexer) {
890             completers.modlist = new GvaScript.AutoCompleter(
891             "search?source=modlist&search=",
892             {minimumChars: 2, minWidth: 100, offsetX: -20, typeAhead: false});
893             completers.modlist.onComplete = submit_on_event;
894             }
895            
896             resize_tree_navigator();
897             $select_ini
898             }
899            
900             document.observe('dom:loaded', setup);
901             window.onresize = resize_tree_navigator;
902             // Note: observe('resize') doesn't work. Why ?
903            
904             function displayContent(event) {
905             var label = event.controller.label(event.target);
906             if (label && label.tagName == "A") {
907             label.focus();
908             return Event. stopNone;
909             }
910             }
911            
912             function maybe_complete(input) {
913             if (input._autocompleter)
914             input._autocompleter.detach(input);
915            
916             switch (input.form.source.selectedIndex) {
917             case 0: completers.perlfunc.autocomplete(input); break;
918             case 1: completers.perlvar.autocomplete(input); break;
919             case 3: if (!no_indexer)
920             completers.modlist.autocomplete(input);
921             break;
922             }
923             }
924            
925            
926             </script>
927             <style>
928             .small_title {color: midnightblue; font-weight: bold; padding: 0 3 0 3}
929             FORM {margin:0px}
930             BODY {margin:0px; font-size: 70%; overflow-x: hidden}
931             DIV {margin:0px; width: 100%}
932             #TN_tree {overflow-y:scroll; overflow-x: hidden}
933             </style>
934             </head>
935             <body>
936            
937             <div id='toc_frame_top'>
938             <div class="small_title"
939             style="text-align:center;border-bottom: 1px solid">
940             Perl Documentation
941             </div>
942             <div style="text-align:right">
943             <a href="Pod/POM/Web/Help" class="small_title">Help</a>
944             </div>
945            
946             <form action="search" id="search_form" method="get">
947             <span class="small_title">Search in</span>
948             <select name="source">
949             <option>perlfunc</option>
950             <option>perlvar</option>
951             <option>perlfaq</option>
952             <option>modules</option>
953             <option>full-text</option>
954             </select><br>
955             <span class="small_title">&nbsp;for&nbsp;</span><input
956             name="search" size="15"
957             autocomplete="off"
958             onfocus="maybe_complete(this)">
959             </form>
960             <br>
961             <div class="small_title"
962             style="border-bottom: 1px solid">Browse</div>
963             </div>
964            
965             <!-- In principle the tree navigator below would best belong in a
966             different frame, but instead it's in a div because the autocompleter
967             from the form above sometimes needs to overlap the tree nav. -->
968             <div id='TN_tree' onPing='displayContent'>
969             @perl_sections
970             $modules
971             </div>
972            
973             </body>
974             </html>
975             __EOHTML__
976             }
977              
978             #----------------------------------------------------------------------
979             # searching
980             #----------------------------------------------------------------------
981 2     2 0 6  
982             sub dispatch_search {
983 2         6   my ($self) = @_;
984 2         5  
985               my $params = $self->{params};
986               my $source = $params->{source};
987               my $method = {perlfunc => 'perlfunc',
988                             perlvar => 'perlvar',
989                             perlfaq => 'perlfaq',
990                             modules => 'serve_pod',
991 2 50       21                 full_text => 'full_text',
992                             modlist => 'modlist',
993 2 50 33     13                 }->{$source} or die "cannot search in '$source'";
994 0         0  
995               if ($method =~ /full_text|modlist/ and $no_indexer) {
996                 die "<p>this method requires <b>Search::Indexer</b></p>"
997                   . "<p>please ask your system administrator to install it</p>"
998                   . "(<small>error message : $no_indexer</small>)";
999 2         11   }
1000              
1001               return $self->$method($params->{search});
1002             }
1003              
1004              
1005              
1006             my @_perlfunc_items; # simple-minded cache
1007 2     2 0 5  
1008             sub perlfunc_items {
1009 2 100       6   my ($self) = @_;
1010 1 50       3  
1011               unless (@_perlfunc_items) {
1012 1         5     my ($funcpod) = $self->find_source("perlfunc")
1013 1         13       or die "'perlfunc.pod' does not seem to be installed on this system";
  2         207  
1014                 my $funcpom = $self->pod2pom($funcpod);
1015 1         62     my ($description) = grep {$_->title eq 'DESCRIPTION'} $funcpom->head1;
  4         506  
1016 1         56     my ($alphalist)
1017                   = grep {$_->title =~ /^Alphabetical Listing/i} $description->head2;
1018 2         17491     @_perlfunc_items = $alphalist->over->[0]->item;
1019               };
1020               return @_perlfunc_items;
1021             }
1022              
1023 1     1 0 4  
1024 1 50       4 sub perlfunc {
  378         53507  
1025               my ($self, $func) = @_;
1026               my @items = grep {$_->title =~ /^$func\b/} $self->perlfunc_items
1027                  or return $self->send_html("No documentation found for perl "
1028 1         91                                ."function '<tt>$func</tt>'");
1029              
1030 1         5   my $view = $self->mk_view(path => "perlfunc/$func");
  2         79  
1031 1         60  
1032               my @li_items = map {$_->present($view)} @items;
1033               return $self->send_html(<<__EOHTML__);
1034             <html>
1035             <head>
1036             <link href="$self->{root_url}/Pod/POM/Web/lib/PodPomWeb.css" rel="stylesheet" type="text/css">
1037             </head>
1038             <body>
1039             <h2>Extract from <a href="$self->{root_url}/perlfunc">perlfunc</a></h2>
1040            
1041             <ul>@li_items</ul>
1042             </body>
1043             __EOHTML__
1044             }
1045              
1046              
1047              
1048              
1049              
1050             my @_perlvar_items; # simple-minded cache
1051 1     1 0 3  
1052             sub perlvar_items {
1053 1 50       7   my ($self) = @_;
1054              
1055               unless (@_perlvar_items) {
1056 1 50       7  
1057             # get items defining variables
1058 1         5     my ($varpod) = $self->find_source("perlvar")
1059 1         8       or die "'perlvar.pod' does not seem to be installed on this system";
1060                 my $varpom = $self->pod2pom($varpod);
1061                 my @items = _extract_items($varpom);
1062 1         5  
1063 1         4 # group items having common content
1064 161         1972     my $tmp = [];
1065 161 100       658     foreach my $item (@items) {
1066 85         78224       push @$tmp, $item;
1067 85         266       if ($item->content . "") { # force stringification
1068                     push @_perlvar_items, $tmp;
1069                     $tmp = [];
1070                   }
1071 1         5260     }
1072               };
1073               return @_perlvar_items;
1074             }
1075              
1076 0     0 0 0  
1077             sub perlvar {
1078 0 0   0   0   my ($self, $var) = @_;
  0         0  
  0         0  
1079              
1080               my @items = grep {any {$_->title =~ /^\Q$var\E(\s|$)/} @$_}
1081                                $self->perlvar_items
1082 0         0      or return $self->send_html("No documentation found for perl "
1083                                            ."variable '<tt>$var</tt>'");
1084 0         0   my $view = $self->mk_view(path => "perlvar/$var");
  0         0  
  0         0  
1085 0         0  
1086               my @li_items = map {$_->present($view)} map {@$_} @items;
1087               return $self->send_html(<<__EOHTML__);
1088             <html>
1089             <head>
1090             <link href="$self->{root_url}/Pod/POM/Web/lib/PodPomWeb.css" rel="stylesheet" type="text/css">
1091             </head>
1092             <body>
1093             <h2>Extract from <a href="$self->{root_url}/perlvar">perlvar</a></h2>
1094            
1095             <ul>@li_items</ul>
1096             </body>
1097             __EOHTML__
1098             }
1099              
1100              
1101 1     1 0 4  
1102 1         28 sub perlfaq {
1103 1         3   my ($self, $faq_entry) = @_;
1104 1         2   my $regex = qr/\b\Q$faq_entry\E\b/i;
1105               my $answers = "";
1106 1         7   my $n_answers = 0;
1107              
1108               my $view = $self->mk_view(path => "perlfaq/$faq_entry");
1109 1         5  
1110 9         123536  FAQ:
1111 9 50       63   for my $num (1..9) {
1112                 my $faq = "perlfaq$num";
1113 9         40     my ($faqpod) = $self->find_source($faq)
1114 9 100       87       or die "'$faq.pod' does not seem to be installed on this system";
  42         2122  
  305         33905  
1115                 my $faqpom = $self->pod2pom($faqpod);
1116 4         82     my @questions = map {grep {$_->title =~ $regex} $_->head2} $faqpom->head1
  16         812  
1117 4         355       or next FAQ;
1118                 my @nodes = map {$view->print($_)} @questions;
1119                 $answers .= generic_node(label => "Found in perlfaq$num",
1120 4         49                              label_tag => "h2",
1121                                          content => join("", @nodes));
1122                 $n_answers += @nodes;
1123 1         6815   }
1124              
1125               return $self->send_html(<<__EOHTML__);
1126             <html>
1127             <head>
1128             <link href="$self->{root_url}/Alien/GvaScript/lib/GvaScript.css" rel="stylesheet" type="text/css">
1129             <link href="$self->{root_url}/Pod/POM/Web/lib/PodPomWeb.css" rel="stylesheet" type="text/css">
1130             <script src="$self->{root_url}/Alien/GvaScript/lib/prototype.js"></script>
1131             <script src="$self->{root_url}/Alien/GvaScript/lib/GvaScript.js"></script>
1132             <script>
1133             var treeNavigator;
1134             function setup() {
1135             treeNavigator = new GvaScript.TreeNavigator('TN_tree');
1136             }
1137             window.onload = setup;
1138             </script>
1139             </head>
1140             <body>
1141             <h1>Extracts from <a href="$self->{root_url}/perlfaq">perlfaq</a></h1><br>
1142             <em>searching for '$faq_entry' : $n_answers answers</em><br><br>
1143             <div id='TN_tree'>
1144             $answers
1145             </div>
1146             </body>
1147             __EOHTML__
1148              
1149             }
1150              
1151              
1152             #----------------------------------------------------------------------
1153             # miscellaneous
1154             #----------------------------------------------------------------------
1155              
1156 4     4 0 32  
1157             sub mk_view {
1158               my ($self, %args) = @_;
1159              
1160 4         76   my $view = Pod::POM::View::HTML::_PerlDoc->new(
1161                 root_url => $self->{root_url},
1162                 %args
1163 4         339    );
1164              
1165               return $view;
1166             }
1167              
1168              
1169 9     9 0 40  
1170             sub send_html {
1171               my ($self, $html, $mtime) = @_;
1172 9         252  
1173             # dirty hack for MSIE8 (TODO: send proper HTTP header instead)
1174 9         263   $html =~ s[<head>]
1175             [<head>\n<meta http-equiv="X-UA-Compatible" content="IE=edge">];
1176              
1177               $self->send_content({content => encode_utf8($html), code => 200, mtime => $mtime, charset => 'UTF-8'});
1178             }
1179              
1180 10     10 0 35  
1181              
1182 10         33 sub send_content {
1183 10         27   my ($self, $args) = @_;
1184 10   100     58  
1185 10 100 66     81   my $charset = $args->{charset};
1186 10         137   my $length = length $args->{content};
1187 10   100     42   my $mime_type = $args->{mime_type} || "text/html";
1188                  $mime_type .= "; charset=$charset" if $charset and $mime_type =~ /html/;
1189 10         29   my $modified = gmtime $args->{mtime};
1190 10         44   my $code = $args->{code} || 200;
1191              
1192 10 50       67   my $r = $self->{response};
1193 0         0   for (ref $r) {
1194 0         0  
1195 0         0     /^Apache/ and do {
1196 0 0       0       require Apache2::Response;
1197 0         0       $r->content_type($mime_type);
1198 0         0       $r->set_content_length($length);
1199                   $r->set_last_modified($args->{mtime}) if $args->{mtime};
1200                   $r->print($args->{content});
1201 10 50       52       return;
1202 10         71     };
1203 10         206  
1204                 /^HTTP::Response/ and do {
1205 10 100       1190       $r->code($code);
1206 10         189       $r->header(Content_type => $mime_type,
1207 10         443                  Content_length => $length);
1208                   $r->header(Last_modified => $modified) if $args->{mtime};
1209                   $r->add_content($args->{content});
1210                   return;
1211 0         0     };
1212 0 0       0  
1213 0         0 # otherwise (cgi-bin)
1214 0         0     my $headers = "Content-type: $mime_type\nContent-length: $length\n";
1215 0         0     $headers .= "Last-modified: $modified\n" if $args->{mtime};
1216                 binmode(STDOUT);
1217                 print "$headers\n$args->{content}";
1218                 return;
1219               }
1220             }
1221              
1222              
1223              
1224              
1225             #----------------------------------------------------------------------
1226             # generating GvaScript treeNavigator structure
1227 43     43 0 132 #----------------------------------------------------------------------
1228 43   100     129  
1229 43   66     172 sub generic_node {
1230 43   100     150   my %args = @_;
1231 43   66     181   $args{class} ||= "TN_node";
1232               $args{attrs} &&= " $args{attrs}";
1233 43 100       115   $args{content} ||= "";
1234               $args{content} &&= qq{<div class="TN_content">$args{content}</div>};
1235 43   66     153   my ($default_label_tag, $label_attrs)
1236 43   100     118     = $args{href} ? ("a", qq{ href='$args{href}'})
1237 43 50       84                   : ("span", "" );
1238 0         0   $args{label_tag} ||= $default_label_tag;
1239 0         0   $args{label_class} ||= "TN_label";
1240               if ($args{abstract}) {
1241                 $args{abstract} =~ s/([&<>"])/$escape_entity{$1}/g;
1242                 $label_attrs .= qq{ title="$args{abstract}"};
1243               }
1244               return qq{<div class="$args{class}"$args{attrs}>}
1245                    . qq{<$args{label_tag} class="$args{label_class}"$label_attrs>}
1246 43         365        . $args{label}
1247                    . qq{</$args{label_tag}>}
1248                    . $args{content}
1249                    . qq{</div>};
1250             }
1251 29     29 0 54  
1252              
1253             sub closed_node {
1254               return generic_node(@_, class => "TN_node TN_closed");
1255 0     0 0 0 }
1256              
1257             sub leaf {
1258               return generic_node(@_, class => "TN_leaf");
1259             }
1260              
1261              
1262             #----------------------------------------------------------------------
1263             # utilities
1264             #----------------------------------------------------------------------
1265 14     14 0 50  
1266 14 50       871  
1267 14 50       239 sub slurp_file {
1268 14         109   my ($self, $file, $io_layer) = @_;
1269 14         18731   open my $fh, "<", $file or die "open $file: $!";
1270               binmode($fh, $io_layer) if $io_layer;
1271               local $/ = undef;
1272               return <$fh>;
1273             }
1274 1     1 0 4  
1275              
1276             sub parse_version {
1277 1     1   9   my ($self, $content, $mod_name) = @_;
  1         2  
  1         10  
  1         36  
1278 1 50       927  
1279             # filehandle on string content
1280               open my $fh, "<", \$content;
1281 1         4249   my $mm = Module::Metadata->new_from_handle($fh, $mod_name)
1282                 or die "couldn't create Module::Metadata";
1283              
1284               return $mm->version;
1285             }
1286              
1287 247     247   324  
1288              
1289 247         815 sub _extract_items { # recursively grab all nodes of type 'item'
1290 247 100       3954   my $node = shift;
1291 86 100       315  
  246         689  
1292               for ($node->type) {
1293 66         122     /^item/ and return ($node);
1294                 /^(pod|head|over)/ and return map {_extract_items($_)} $node->content;
1295               }
1296               return ();
1297             }
1298              
1299              
1300             1;
1301             #======================================================================
1302             # END OF package Pod::POM::Web
1303             #======================================================================
1304              
1305              
1306 1     1   23 #======================================================================
  1         3  
  1         56  
1307 1     1   8 package Pod::POM::View::HTML::_PerlDoc; # View package
  1         2  
  1         61  
1308 1     1   6 #======================================================================
  1         2  
  1         70  
1309 1     1   8 use strict;
  1         2  
  1         845  
1310 1     1   6700 use warnings;
  1         2  
  1         13  
1311 1     1   111 no warnings qw/uninitialized/;
  1         2  
  1         22  
1312             use base qw/Pod::POM::View::HTML/;
1313             use POSIX qw/strftime/; # date formatting
1314             use List::MoreUtils qw/firstval/;
1315              
1316             # SUPER::view_seq_text tries to find links automatically ... but is buggy
1317 451     451   8682 # for URLs that contain '$' or ' '. So we disable it, and only consider
1318             # links explicitly marked with L<..>, handled in view_seq_link() below.
1319 451         692 sub view_seq_text {
1320 451         740   my ($self, $text) = @_;
1321 451         591  
1322 451         768   for ($text) {
1323                 s/&/&amp;/g;
1324                 s/</&lt;/g;
1325 451         1226     s/>/&gt;/g;
1326               }
1327              
1328               return $text;
1329             }
1330              
1331              
1332 38     38   368  
1333             # SUPER::view_seq_link needs some adaptations
1334             sub view_seq_link {
1335                 my ($self, $link) = @_;
1336 38         48  
1337 38 100       153 # we handle the L<link_text|...> syntax here, because we also want
1338             # link_text for http URLS (not supported by SUPER::view_seq_link)
1339                 my $link_text;
1340 38         102     $link =~ s/^([^|]+)\|// and $link_text = $1;
1341              
1342             # links to external resources will open in a blank page
1343 38         117     my $is_external_resource = ($link =~ m[^\w+://]);
1344 38         908  
1345             # call parent and reparse the result
1346                 my $linked = $self->SUPER::view_seq_link($link);
1347 38 100       167     my ($url, $label) = ($linked =~ m[^<a href="(.*?)">(.*)</a>]);
  15         41  
1348              
1349             # fix link for 'hash' part of the url
1350 38 100       133     $url =~ s[#(.*)]['#' . _title_to_id($1)]e unless $is_external_resource;
    100          
1351 10         19  
1352             # if explicit link_text given by client, take that as label, unchanged
1353                 if ($link_text) {
1354                   $label = $link_text;
1355 26 50       57     }
  5         28  
1356             # if "$page/$section", replace by "$section in $page"
1357                 elsif ($label !~ m{^\w+://}s) { # but only if not a full-blown URL
1358                   $label =~ s[^(.*?)/(.*)$][$1 ? "$2 in $1" : $2]e ;
1359 38 100       99     }
1360 38         233  
1361             # return link (if external resource, opens in a new browser window)
1362                 my $target = $is_external_resource ? " target='_blank'" : "";
1363                 return qq{<a href="$url"$target>$label</a>};
1364             }
1365              
1366 57     57   986  
1367 57         168  
1368 57         196 sub view_seq_link_transform_path {
1369                 my($self, $page) = @_;
1370                 $page =~ s[::][/]g;
1371                 return "$self->{root_url}/$page";
1372             }
1373 21     21   1433  
1374              
1375 21   50     38 sub view_item {
1376 21 50       188   my ($self, $item) = @_;
1377              
1378 21         42   my $title = eval {$item->title->present($self)} || "";
1379 21         47      $title = "" if $title =~ /^\s*\*\s*$/;
1380 21   33     119  
1381               my $class = "";
1382 21         103   my $id = _title_to_id($title);
1383 21 50       380   $id &&= qq{ id="$id"};
1384 21         105  
1385               my $content = $item->content->present($self);
1386               $title = qq{<b>$title</b>} if $title;
1387               return qq{<li$id$class>$title\n$content</li>\n};
1388             }
1389              
1390 72     72   124  
1391 72         141  
1392 72         196 sub _title_to_id {
1393 72         430   my $title = shift;
1394 72         351   $title =~ s/<.*?>//g; # no tags
1395 72         170   $title =~ s/[,(].*//; # drop argument lists or text lists
1396               $title =~ s/\s*$//; # drop final spaces
1397               $title =~ s/[^A-Za-z0-9_]/_/g; # replace chars unsuitable for an id
1398               return $title;
1399             }
1400 1     1   34  
1401              
1402             sub view_pod {
1403 1 50       7   my ($self, $pom) = @_;
1404              
1405             # compute view
1406               my $content = $pom->content->present($self)
1407                 or return "no documentation found in <tt>$self->{path}</tt><br>\n"
1408 1     1   69             . "<a href='$self->{root_url}/source/$self->{path}'>Source</a>";
  1         29  
1409 1 50       95  
1410             # parse name and description
1411               my $name_h1 = firstval {$_->title =~ /^(NAME|TITLE)\b/} $pom->head1();
1412 1         122   my $doc_title = $name_h1 ? $name_h1->content->present('Pod::POM::View')
1413 1   33     6 # retrieve content as plain text
1414 1         4                            : 'Untitled';
1415               my ($name, $description) = ($doc_title =~ /^\s*(.*?)\s+-+\s+(.*)/);
1416               $name ||= $doc_title;
1417 1         119   $name =~ s/\n.*//s;
1418              
1419             # installation date
1420 1         11   my $installed = strftime("%x", localtime($self->{mtime}));
1421              
1422 1 50       6 # if this is a module (and not a script), get additional info
1423               my ($version, $core_release, $orig_version, $cpan_info, $module_refs)
1424                 = ("") x 6;
1425 1 50       28   if (my $mod_name = $self->{mod_name}) {
1426              
1427             # version
1428 1   50     18     $version = $self->{version} ? "v. $self->{version}, " : "";
1429              
1430 1   50     472 # is this module in Perl core ?
1431 1   33     4     $core_release = Module::CoreList->first_release($mod_name) || "";
1432 1   33     5     $orig_version
1433                   = $Module::CoreList::version{$core_release}{$mod_name} || "";
1434                 $orig_version &&= "v. $orig_version ";
1435 1         5     $core_release &&= "; ${orig_version}entered Perl core in $core_release";
1436              
1437             # hyperlinks to various internet resources
1438                 $module_refs = qq{<br>
1439             <a href="https://metacpan.org/pod/$mod_name"
1440 1 50       5 target="_blank">meta::cpan</a>
1441 0         0 };
1442 0 0       0  
1443 0         0     if ($has_cpan) {
1444                   my $mod = CPAN::Shell->expand("Module", $mod_name);
1445 0 0       0       if ($mod) {
1446                     my $cpan_version = $mod->cpan_version;
1447                     $cpan_info = "; CPAN has v. $cpan_version"
1448                       if $cpan_version ne $self->{version};
1449                   }
1450 1         7     }
1451               }
1452              
1453               my $toc = $self->make_toc($pom, 0);
1454              
1455               return <<__EOHTML__
1456             <html>
1457             <head>
1458             <title>$name</title>
1459             <link href="$self->{root_url}/Alien/GvaScript/lib/GvaScript.css" rel="stylesheet" type="text/css">
1460             <link href="$self->{root_url}/Pod/POM/Web/lib/PodPomWeb.css" rel="stylesheet" type="text/css">
1461             <script src="$self->{root_url}/Alien/GvaScript/lib/prototype.js"></script>
1462             <script src="$self->{root_url}/Alien/GvaScript/lib/GvaScript.js"></script>
1463             <script>
1464             var treeNavigator;
1465             function setup() {
1466             new GvaScript.TreeNavigator(
1467             'TN_tree',
1468             {selectFirstNode: (location.hash ? false : true),
1469             tabIndex: 0}
1470             );
1471            
1472             var tocFrame = window.parent.frames.tocFrame;
1473             if (tocFrame) {
1474             try {tocFrame.eval("selectToc('$name')")}
1475             catch(e) {};
1476             }
1477             }
1478             window.onload = setup;
1479             function jumpto_href(event) {
1480             var label = event.controller.label(event.target);
1481             if (label && label.tagName == "A") {
1482             /* label.focus(); */
1483             return Event.stopNone;
1484             }
1485             }
1486             </script>
1487             <style>
1488             #TOC .TN_content .TN_label {font-size: 80%; font-weight: bold}
1489             #TOC .TN_leaf .TN_label {font-weight: normal}
1490            
1491             #ref_box {
1492             clear: right;
1493             float: right;
1494             text-align: right;
1495             font-size: 80%;
1496             }
1497             #title_descr {
1498             clear: right;
1499             float: right;
1500             font-style: italic;
1501             margin-top: 8px;
1502             margin-bottom: 8px;
1503             padding: 5px;
1504             text-align: center;
1505             border: 3px double #888;
1506             }
1507             </style>
1508             </head>
1509             <body>
1510             <div id='TN_tree'>
1511             <div class="TN_node">
1512             <h1 class="TN_label">$name</h1>
1513             <small>(${version}installed $installed$core_release$cpan_info)</small>
1514            
1515            
1516             <span id="title_descr">$description</span>
1517            
1518             <span id="ref_box">
1519             <a href="$self->{root_url}/source/$self->{path}">Source</a>
1520             $module_refs
1521             </span>
1522            
1523             <div class="TN_content">
1524             <div class="TN_node" onPing="jumpto_href" id="TOC">
1525             <h3 class="TN_label">Table of contents</h3>
1526             <div class="TN_content">
1527             $toc
1528             </div>
1529             </div>
1530             <hr/>
1531             </div>
1532             </div>
1533             $content
1534             </div>
1535             </body>
1536 1         59 </html>
1537             __EOHTML__
1538              
1539             }
1540 1     1   8  
1541 1     1   2260 # generating family of methods for view_head1, view_head2, etc.
  1         3  
  1         158  
1542 6         838 BEGIN {
1543 26     26   1049   for my $num (1..6) {
1544 26         135     no strict 'refs';
1545 26         203     *{"view_head$num"} = sub {
1546 26         129       my ($self, $item) = @_;
1547 26         612       my $title = $item->title->present($self);
1548                   my $id = _title_to_id($title);
1549                   my $content = $item->content->present($self);
1550                   my $h_num = $num + 1;
1551                   return <<EOHTML
1552             <div class="TN_node" id="$id">
1553             <h$h_num class="TN_label">$title</h$h_num>
1554             <div class="TN_content">
1555             $content
1556 26         236 </div>
1557 6         23 </div>
1558             EOHTML
1559                 }
1560               }
1561             }
1562 10     10   97  
1563 10         30  
1564             sub view_seq_index {
1565               my ($self, $item) = @_;
1566               return ""; # Pod index tags have no interest for HTML
1567             }
1568 59     59   1182  
1569              
1570 59         106 sub view_verbatim {
1571 59 100       117   my ($self, $text) = @_;
1572 5         15  
1573 5         22   my $coloring = $self->{syntax_coloring};
1574               if ($coloring) {
1575                 my $method = "${coloring}_coloring";
1576 54         308     $text = $self->$method($text);
1577               }
1578               else {
1579                 $text =~ s/([&<>"])/$Pod::POM::Web::escape_entity{$1}/g;
1580 59         428   }
  29         95  
1581 29         382  
1582             # hyperlinks to other modules
1583 59 100       218   $text =~ s{(\buse\b(?:</span>)?\ +(?:<span.*?>)?)([\w:]+)}
1584 1         3 {my $url = $self->view_seq_link_transform_path($2);
1585 1         146 qq{$1<a href="$url">$2</a>} }eg;
  353         904  
1586              
1587 59         422   if ($self->{line_numbering}) {
1588                 my $line = 1;
1589                 $text =~ s/^/sprintf "%6d\t", $line++/egm;
1590               }
1591               return qq{<pre class="$coloring">$text</pre>};
1592             }
1593 5     5   16  
1594 5         35  
1595 5         156  
1596             sub PPI_coloring {
1597 5 50       431717   my ($self, $text) = @_;
1598 5         710   my $ppi = PPI::HTML->new();
1599 5         90   my $html = $ppi->html(\$text);
1600              
1601               if ($html) {
1602 0         0     $html =~ s/<br>//g;
1603 0         0     return $html;
1604               }
1605               else { # PPI failed to parse that text
1606                 $text =~ s/([&<>"])/$Pod::POM::Web::escape_entity{$1}/g;
1607                 return $text;
1608               }
1609 0     0   0 }
1610 0         0  
1611 0         0  
1612             sub SCINEPLEX_coloring {
1613               my ($self, $text) = @_;
1614               eval {
1615 0         0     $text = ActiveState::Scineplex::Annotate($text,
1616                                                          'perl',
1617                                                          outputFormat => 'html');
1618               };
1619               return $text;
1620             }
1621              
1622              
1623 11     11   22  
1624              
1625 11         17  
1626 11         23 sub make_toc {
1627 11         51   my ($self, $item, $level) = @_;
1628              
1629 11         163   my $html = "";
1630 10         37   my $method = "head" . ($level + 1);
1631 10         64   my $sub_items = $item->$method;
1632              
1633 10         33   foreach my $sub_item (@$sub_items) {
1634 10 100       22     my $title = $sub_item->title->present($self);
1635 10   66     24     my $id = _title_to_id($title);
1636              
1637 10         51     my $node_content = $self->make_toc($sub_item, $level + 1);
1638                 my $class = $node_content ? "TN_node" : "TN_leaf";
1639                 $node_content &&= qq{<div class="TN_content">$node_content</div>};
1640              
1641                 $html .= qq{<div class="$class">}
1642                        . qq{<a class="TN_label" href="#$id">$title</a>}
1643 11         24            . $node_content
1644                        . qq{</div>};
1645               }
1646              
1647       0       return $html;
1648             }
1649              
1650              
1651             sub DESTROY {} # avoid AUTOLOAD
1652              
1653              
1654             1;
1655              
1656              
1657              
1658             __END__
1659            
1660             =encoding ISO8859-1
1661            
1662             =head1 NAME
1663            
1664             Pod::POM::Web - HTML Perldoc server
1665            
1666             =head1 DESCRIPTION
1667            
1668             L<Pod::POM::Web> is a Web application for browsing
1669             the documentation of Perl components installed
1670             on your local machine. Since pages are dynamically
1671             generated, they are always in sync with code actually
1672             installed.
1673            
1674             The application offers
1675            
1676             =over
1677            
1678             =item *
1679            
1680             a tree view for browsing through installed modules
1681             (with dynamic expansion of branches as they are visited)
1682            
1683             =item *
1684            
1685             a tree view for navigating and opening / closing sections while
1686             visiting a documentation page
1687            
1688             =item *
1689            
1690             a source code view with hyperlinks between used modules
1691             and optionally with syntax coloring
1692             (see section L</"Optional features">)
1693            
1694            
1695             =item *
1696            
1697             direct access to L<perlfunc> entries (builtin Perl functions)
1698            
1699             =item *
1700            
1701             search through L<perlfaq> headers
1702            
1703             =item *
1704            
1705             full-text search, including names of Perl variables
1706             (this is an optional feature -- see section L</"Optional features">).
1707            
1708             =item *
1709            
1710             parsing and display of version number
1711            
1712             =item *
1713            
1714             display if and when the displayed module entered Perl core.
1715            
1716             =item *
1717            
1718             parsing pod links and translating them into hypertext links
1719            
1720             =item *
1721            
1722             links to CPAN sites
1723            
1724             =back
1725            
1726             The application may be hosted by an existing Web server, or otherwise
1727             may run its own builtin Web server.
1728            
1729             The DHTML code for navigating through documentation trees requires a
1730             modern browser. So far it has been tested on Microsoft Internet
1731             Explorer 8.0, Firefox 3.5, Google Chrome 3.0 and Safari 4.0.4.
1732            
1733             =head1 USAGE
1734            
1735             Usage is described in a separate document
1736             L<Pod::POM::Web::Help>.
1737            
1738             =head1 INSTALLATION
1739            
1740             =head2 Starting the Web application
1741            
1742             Once the code is installed (most probably through
1743             L<CPAN> or L<CPANPLUS>), you have to configure
1744             the web server :
1745            
1746             =head3 As a mod_perl service
1747            
1748             If you have Apache2 with mod_perl 2.0, then edit your
1749             F<perl.conf> as follows :
1750            
1751             PerlModule Apache2::RequestRec
1752             PerlModule Apache2::RequestIO
1753             <Location /perldoc>
1754             SetHandler modperl
1755             PerlResponseHandler Pod::POM::Web->handler
1756             </Location>
1757            
1758             Then navigate to URL L<http://localhost/perldoc>.
1759            
1760             =head3 As a cgi-bin script
1761            
1762             Alternatively, you can run this application as a cgi-script
1763             by writing a simple file F<perldoc> in your C<cgi-bin> directory,
1764             containing :
1765            
1766             #!/path/to/perl
1767             use Pod::POM::Web;
1768             Pod::POM::Web->handler;
1769            
1770             Make this script executable,
1771             then navigate to URL L<http://localhost/cgi-bin/perldoc>.
1772            
1773             The same can be done for running under mod_perl Registry
1774             (write the same script as above and put it in your
1775             Apache/perl directory). However, this does not make much sense,
1776             because if you have mod_perl Registry then you could as well
1777             run it as a basic mod_perl handler.
1778            
1779             =head3 As a standalone server
1780            
1781             A third way to use this application is to start a process invoking
1782             the builtin HTTP server :
1783            
1784             perl -MPod::POM::Web -e server
1785            
1786             This is useful if you have no other HTTP server, or if
1787             you want to run this module under the perl debugger.
1788             The server will listen at L<http://localhost:8080>.
1789             A different port may be specified, in several ways :
1790            
1791             perl -MPod::POM::Web -e server 8888
1792             perl -MPod::POM::Web -e server(8888)
1793             perl -MPod::POM::Web -e server -- --port 8888
1794            
1795             =head2 Opening a specific initial page
1796            
1797             By default, the initial page displayed by the application
1798             is F<perl>. This can be changed by supplying an C<open> argument
1799             with the name of any documentation page: for example
1800            
1801             http://localhost:8080?open=Pod/POM/Web
1802             http://localhost:8080?open=perlfaq
1803            
1804             =head2 Setting a specific title
1805            
1806             If you run several instances of C<Pod::POM::Web> simultaneously, you may
1807             want them to have distinct titles. This can be done like this:
1808            
1809             perl -MPod::POM::Web -e server -- --title "My Own Perl Doc"
1810            
1811            
1812             =head1 MISCELLANEOUS
1813            
1814             =head2 Note about security
1815            
1816             This application is intended as a power tool for Perl developers,
1817             not as an Internet application. It will give access to any file
1818             installed under your C<@INC> path or Apache C<lib/perl> directory
1819             (but not outside of those directories);
1820             so it is probably a B<bad idea>
1821             to put it on a public Internet server.
1822            
1823            
1824             =head2 Optional features
1825            
1826             =head3 Syntax coloring
1827            
1828             Syntax coloring improves readability of code excerpts.
1829             If your Perl distribution is from ActiveState, then
1830             C<Pod::POM::Web> will take advantage
1831             of the L<ActiveState::Scineplex> module
1832             which is already installed on your system. Otherwise,
1833             you need to install L<PPI::HTML>, available from CPAN.
1834            
1835             =head3 Full-text indexing
1836            
1837             C<Pod::POM::Web> can index the documentation and source code
1838             of all your installed modules, including Perl variable names,
1839             C<Names:::Of::Modules>, etc. To use this feature you need to
1840            
1841             =over
1842            
1843             =item *
1844            
1845             install L<Search::Indexer> from CPAN
1846            
1847             =item *
1848            
1849             build the index as described in L<Pod::POM::Web::Indexer> documentation.
1850            
1851             =back
1852            
1853            
1854             =head1 HINTS TO POD AUTHORING
1855            
1856             =head2 Images
1857            
1858             The Pod::Pom::Web server also serves non-pod files within the C<@INC>
1859             hierarchy. This is useful for example to include images in your
1860             documentation, by inserting chunks of HTML as follows :
1861            
1862             =for html
1863             <img src="pretty_diagram.jpg">
1864            
1865             or
1866            
1867             =for html
1868             <object type="image/svg+xml" data="try.svg" width="640" height="480">
1869             </object>
1870            
1871             Here it is assumed that auxiliary files C<pretty_diagram.jpg> or
1872             C<try.svg> are in the same directory than the POD source; but
1873             of course relative or absolute links can be used.
1874            
1875            
1876            
1877             =head1 METHODS
1878            
1879             =head2 handler
1880            
1881             Pod::POM::Web->handler($request, $response, $options);
1882            
1883             Public entry point for serving a request. Objects C<$request> and
1884             C<$response> are specific to the hosting HTTP server (modperl, HTTP::Daemon
1885             or cgi-bin); C<$options> is a hashref that can contain
1886            
1887             =over
1888            
1889             =item C<page_title>
1890            
1891             for specifying the HTML title
1892             of the application (useful if you run several concurrent instances
1893             of Pod::POM::Web).
1894            
1895             =item C<port>
1896            
1897             the HTTP port listening for requests
1898            
1899             =item C<module_dirs>
1900            
1901             directories for searching for modules,
1902             in addition to the standard ones installed with your perl executable.
1903            
1904            
1905             =item <script_dirs>
1906            
1907             additional directories for searching for scripts
1908            
1909             =back
1910            
1911            
1912            
1913            
1914             =head2 server
1915            
1916             Pod::POM::Web->server($port, $options);
1917            
1918             Starts the event loop for the builtin HTTP server.
1919             The C<$port> number can be given as optional first argument
1920             (default is 8080). The second argument C<$options> may be
1921             used to specify a page title (see L</"handler"> method above).
1922            
1923             This function is exported into the C<main::> namespace if perl
1924             is called with the C<-e> flag, so that you can write
1925            
1926             perl -MPod::POM::Web -e server
1927            
1928             Options and port may be specified on the command line :
1929            
1930             perl -MPod::POM::Web -e server -- --port 8888 --title FooBar
1931            
1932             =head1 ACKNOWLEDGEMENTS
1933            
1934             This web application was deeply inspired by :
1935            
1936             =over
1937            
1938             =item *
1939            
1940             the structure of HTML Perl documentation released with
1941             ActivePerl (L<http://www.activeperl.com/ASPN/Perl>).
1942            
1943            
1944             =item *
1945            
1946             the excellent tree navigation in Microsoft's former MSDN Library Web site
1947             -- since they rebuilt the site, keyboard navigation has gone !
1948            
1949             =item *
1950            
1951             the standalone HTTP server implemented in L<Pod::WebServer>.
1952            
1953             =item *
1954            
1955             the wide possibilities of Andy Wardley's L<Pod::POM> parser.
1956            
1957             =back
1958            
1959             Thanks
1960             to Philippe Bruhat who mentioned a weakness in the API,
1961             to Chris Dolan who supplied many useful suggestions and patches
1962             (esp. integration with AnnoCPAN),
1963             to Rémi Pauchet who pointed out a regression bug with Firefox CSS,
1964             to Alexandre Jousset who fixed a bug in the TOC display,
1965             to Cédric Bouvier who pointed out a IO bug in serving binary files,
1966             to Elliot Shank who contributed the "page_title" option,
1967             to Olivier 'dolmen' Mengué who suggested to export "server" into C<main::>,
1968             to Ben Bullock who added the 403 message for absent modules,
1969             and to Paul Cochrane for several improvements in the doc and in the
1970             repository structure.
1971            
1972            
1973             =head1 RELEASE NOTES
1974            
1975             Indexed information since version 1.04 is not compatible
1976             with previous versions.
1977            
1978             So if you upgraded from a previous version and want to use
1979             the index, you need to rebuild it entirely, by running the
1980             command :
1981            
1982             perl -MPod::POM::Web::Indexer -e "index(-from_scratch => 1)"
1983            
1984            
1985            
1986             =head1 AUTHOR
1987            
1988             Laurent Dami, C<< <dami AT cpan DOT org> >>
1989            
1990            
1991             =head1 COPYRIGHT & LICENSE
1992            
1993             Copyright 2007-2021 Laurent Dami, all rights reserved.
1994            
1995             This program is free software; you can redistribute it and/or modify it
1996             under the same terms as Perl itself.
1997            
1998             =head1 TODO
1999            
2000             - real tests !
2001             - factorization (esp. initial <head> in html pages)
2002             - use Getopts to choose colouring package, toggle CPAN, etc.
2003             - declare Pod::POM bugs
2004             - perlre : line 1693 improper parsing of L<C<< (?>pattern) >>>
2005             - bug: doc files taken as pragmas (lwptut, lwpcook, pip, pler)
2006             - exploit doc index X<...>
2007             - do something with perllocal (installation history)
2008             - restrict to given set of paths/ modules
2009             - need to change toc (no perlfunc, no scripts/pragmas, etc)
2010             - treenav with letter entries or not ?
2011             - port to Plack
2012