Pod-POM-Web/lib/Pod/POM/Web.pm
#======================================================================
package Pod::POM::Web; # see doc at end of file
#======================================================================
use strict;
use warnings;
use 5.010;
use parent 'Plack::Component'; # web app based on Plack architecture
use Plack::Request; # Plack API for an HTTP request
use Plack::Response; # Plack API for an HTTP response
use Plack::Util; # encode_html()
use Pod::POM 0.25; # parsing Pod
use List::Util qw/min max/; # numeric minimum & maximum
use List::MoreUtils qw/uniq firstval any/; # list utilities
use Module::CoreList; # asking if a module belongs to Perl core
use MIME::Types; # translate file extension into MIME type
use Alien::GvaScript 1.021000; # javascript files
use Config; # to find where are the perl script directories
use Encode qw/encode_utf8 decode_utf8/; # utf8 encoding
use Params::Validate qw/validate_with SCALAR ARRAYREF/; # check validity of parameters
use Path::Tiny qw/path/; # easy access to file contents
use CPAN::Common::Index::Mux::Ordered; # current CPAN version of a module
use Pod::POM::Web::Util qw/slurp_native_or_utf8 parse_version extract_POM_items/;
# other modules that may be required dynamically :
# Getopt::Long, PPI::HTML, ActiveState::Scineplex, Plack::Runner
#----------------------------------------------------------------------
# GLOBAL VARIABLES
#---------------------------------------------------------------------
our $VERSION = '1.27';
# directories for modules -- filter @INC (we don't want '.', nor server_root added by mod_perl)
my $server_root = eval {Apache2::ServerUtil::server_root()} || "";
my @default_module_dirs = grep {!/^\./ && $_ ne $server_root} @INC;
# directories for executable perl scripts
my @default_script_dirs = grep {$_}
@Config{qw/sitescriptexp vendorscriptexp scriptdirexp/};
(my $default_index_dir = __FILE__) =~ s[Web\.pm$][Web/index];
# parameters for instantiating the module. They could also come from cmd-line options
my %params_for_new = (
page_title => {type => SCALAR , default => 'Perl documentation'},
module_dirs => {type => ARRAYREF, default => \@default_module_dirs},
script_dirs => {type => ARRAYREF, default => \@default_script_dirs},
index_dir => {type => SCALAR , default => $default_index_dir},
script_name => {type => SCALAR , optional => 1}, # will be filled at first web request
);
my @params_for_getopt = (
'page_title|title=s',
'module_dirs|mdirs=s@{,}',
'script_dirs|sdirs=s@{,}',
'index_dir|idir=s',
);
# some subdirs never contain Pod documentation
my @ignore_toc_dirs = qw/auto unicore/;
# syntax coloring (optional)
my $coloring_package
= eval {require PPI::HTML} ? "PPI"
: eval {require ActiveState::Scineplex} ? "SCINEPLEX"
: "";
# A sequence of optional filters to apply to the source code before
# running it through Pod::POM. Source code is passed in $_[0] and
# should be modified in place.
my @podfilters = (
# Pod::POM fails to parse correctly when there is an initial blank line
sub { $_[0] =~ s/\A\s*// },
# Pod::POM only understands =encoding utf8, not utf-8
sub { $_[0] =~ s/=encoding utf-8/=encoding utf8/i; },
);
my %special_podfilters = (
perlfunc => # remove args in links to function names
# (for ex. L<C<open>|/open FILEHANDLE,MODE,EXPR> becomes L<C<open>|/open>
sub {$_[0] =~ s[(L<.*?\|/\w+)\s.*?>][$1>]g},
# perlre: the POM parser is not smart enough to parse
# L</C<< (?>pattern) >>>, so we translate them into L<C<< (?E<gt>pattern) >>|/(?E<gt>pattern)>
perlre => sub {$_[0] =~ s[\(\?>][(?E<gt>]g;
$_[0] =~ s[L</C<< (.*?) >>>][L<C<< $1 >>|/$1>]g},
# POSIX: the POM parser is not smart enough to parse
# L<C<function>(3)>, so we translate them into C<L<function(3)>>
POSIX => sub {$_[0] =~ s[L<C<(\w+)>\((\d)\)>][C<L<$1($2)>>]g},
);
#----------------------------------------------------------------------
# CLASS METHODS
#----------------------------------------------------------------------
# functions exported so that they can be called from command-line
sub import {
my $class = shift;
my ($package, $filename) = caller;
no strict 'refs';
# export "server" and "index" -- for "perl -MPod::POM::Web -e ..."
if ($package eq 'main' and $filename eq '-e') {
*{'main::server'} = sub { $class->server };
*{'main::index'} = sub { $class->index(@_) };
}
# export "app" --- for "plackup -MPod::POM::Web -e app"
elsif($package eq 'Plack::Runner') {
*{'Plack::Runner::app'} = sub {$class->app};
}
}
# launch the app via Plack::Runner when called from perl cmd-line
sub server {
my $class = shift;
require Plack::Runner;
my $runner = Plack::Runner->new;
$runner->parse_options(@ARGV);
$runner->run($class->app);
}
# return an app suitable to run under Plack::Runner
sub app {
my $class = shift;
# get options from command-line
require Getopt::Long;
my $parser = Getopt::Long::Parser->new(config => [qw/pass_through/]);
$parser->getoptions(\my %options, @params_for_getopt);
# create a Pod::POM::Web instance and make it into a Plack app
my $obj = $class->new(%options);
return $obj->to_app;
}
# backcompat : a class method to be used as a CGI script or as a modperl handler
sub handler : method {
my ($class, $r) = @_;
if ($r && ref $r =~ /^Apache/) {
require Plack::Handler::Apache2;
Plack::Handler::Apache2->call_app($r, $class->app);
}
else {
require Plack::Handler::CGI;
Plack::Handler::CGI->new->run($class->app);
}
}
# façade to the Indexer class -- for facilitating command-line invocation
sub index {
my ($class, %options) = @_;
my $self = $class->new();
$self->indexer(%options)->start_indexing_session;
}
# constructor
sub new {
my $class = shift;
# validate input parameters
my $self = validate_with(
params => \@_,
spec => \%params_for_new,
allow_extra => 0,
);
# sources for CPAN index. The default requires an internet connexion. If there is a
# local MiniCPAN mirror, it will be detected and used as an alternate source.
my @cpan_indices = (MetaDB => {});
if (my $local_minicpan = eval {require CPAN::Mini;
my %conf = CPAN::Mini->read_config;
$conf{local}}) {
unshift @cpan_indices,
LocalPackage => { source => "$local_minicpan/modules/02packages.details.txt.gz" };
}
$self->{cpan_index} = CPAN::Common::Index::Mux::Ordered->assemble(@cpan_indices);
# create instance
bless $self, $class;
}
#----------------------------------------------------------------------
# INSTANCE METHODS
#----------------------------------------------------------------------
# simple-minded accessors
sub module_dirs {@{shift->{module_dirs}}}
sub script_dirs {@{shift->{script_dirs}}}
# lazy instantiation of the indexer class
sub indexer {
my ($self, %options) = @_;
# NOTE : the indexer cannot be cached, because this would lock the .BDB files, preventing updates
require Pod::POM::Web::Indexer;
my $indexer = Pod::POM::Web::Indexer->new(index_dir => $self->{index_dir},
module_dirs => $self->{module_dirs},
%options);
return $indexer;
}
# main request dispatcher (see L<Plack::Component>)
sub call {
my ($self, $env) = @_;
# plack request object
my $req = Plack::Request->new($env);
# at first request, register the script name
$self->{script_name} = $req->script_name if not exists $self->{script_name};
# dispatching will be based on path_info
my $path_info = $req->path_info;
# security check : no outside directories
$path_info =~ m[(\.\.|//|\\|:)] and die "illegal path: $path_info";
# dispatch
$path_info =~ s[^/][] or return $self->index_frameset($req);
for ($path_info) {
/^$/ and return $self->index_frameset($req);
/^index$/ and return $self->index_frameset($req);
/^toc$/ and return $self->main_toc($req);
/^toc\/(.*)$/ and return $self->toc_for($1); # Ajax calls
/^script\/(.*)$/ and return $self->serve_script($1);
/^search$/ and return $self->dispatch_search($req);
/^source\/(.*)$/ and return $self->serve_source($1, $req);
/^ft_index$/ and return $self->ft_index($req);
# files with extensions (.css, .js, images)
/\.(\w+)$/ and return $self->serve_file($path_info, $1);
# otherwise, it must be a module
return $self->serve_module($path_info);
}
}
#----------------------------------------------------------------------
# main frameset
#----------------------------------------------------------------------
sub index_frameset{
my ($self, $req) = @_;
# initial page to open
my $ini = $req->parameters->{open};
my $ini_content = $ini || "perl";
my $ini_toc = $ini ? "toc?open=$ini" : "toc";
# HTML title
my $title = Plack::Util::encode_html($self->{page_title});
return $self->respond_html(<<__EOHTML__);
<html>
<head><title>$title</title></head>
<frameset cols="25%, 75%">
<frame name="tocFrame" src="$self->{script_name}/$ini_toc">
<frame name="contentFrame" src="$self->{script_name}/$ini_content">
</frameset>
</html>
__EOHTML__
}
#----------------------------------------------------------------------
# serving a single file (source code, raw content or POD documentation)
#----------------------------------------------------------------------
sub serve_source {
my ($self, $path, $req) = @_;
my $params = $req->parameters;
# default (if not printing): line numbers and syntax coloring are on
$params->{lines} = $params->{coloring} = 1 unless $params->{print};
# find the source file(s)
my @files = $path =~ s[^script/][] ? $self->find_script($path)
: $self->find_module($path)
or die "did not find source for '$path'";
# last modification
my $mtime = max map{(stat $_)[9]} @files;
# build formatted source
my $view = $self->mk_view(
line_numbering => $params->{lines},
syntax_coloring => ($params->{coloring} ? $coloring_package : "")
);
my $formatted_sources = "";
foreach my $file (@files) {
my $source = slurp_native_or_utf8($file);
$source =~ s/\r\n/\n/g;
my $formatted_source = $view->view_verbatim($source);
$formatted_sources .= "<p/><h2>$file</h2><p/><pre>$formatted_source</pre>";
}
my $offer_print = $params->{print} ? "" : <<__EOHTML__;
<form method="get" target="_blank">
<input type="submit" name="print" value="Print"> with<br>
<input type="checkbox" name="lines" checked>line numbers<br>
<input type="checkbox" name="coloring" checked>syntax coloring
</form>
__EOHTML__
my $script = $params->{print} ? <<__EOHTML__ : "";
<script>
window.onload = function () {window.print()};
</script>
__EOHTML__
my $doc_link = $params->{print} ? "" : <<__EOHTML__;
<a href="$self->{script_name}/$path" style="float:right">Doc</a>
__EOHTML__
my $css_links = $self->css_links;
(my $module = $path) =~ s[/][::]g;
my $html = <<__EOHTML__;
<html>
<head>
<title>Source of $module</title>
$css_links
<style>
PRE {border: none; background: none}
FORM {float: right; font-size: 70%; border: 1px solid}
</style>
</head>
<body>
$doc_link
<h1>Source of $module</h1>
$offer_print
$formatted_sources
</body>
</html>
__EOHTML__
$self->respond_html($html, $mtime);
}
sub serve_file {
my ($self, $path, $extension) = @_;
my ($fullpath) = $self->find_files(module_dirs => $path)
or return $self->respond(code => 404,
content => "$path: no such file");
my $mime_type = MIME::Types->new->mimeTypeOf($extension);
my $content = path($fullpath)->slurp_raw;
my $mtime = (stat $fullpath)[9];
$self->respond(content => $content,
mtime => $mtime,
mime_type => $mime_type);
}
sub serve_module {
my ($self, $path) = @_;
$path =~ s[::][/]g; # just in case, if called as /perldoc/Foo::Bar
# find file(s) corresponding to $path
my @sources = $self->find_module($path)
or return $self->_no_such_module($path);
my $mtime = max map {(stat $_)[9]} @sources;
# module version
my $version = firstval {$_} map {parse_version($_)} grep {/\.pm$/} @sources;
# latest CPAN version -- needs hack because CPAN::Common::Index reports 'undef' instead of undef
(my $mod_name = $path) =~ s[/][::]g;
my $cpan_package = $self->{cpan_index}->search_packages( { package => $mod_name } );
my $cpan_version = $cpan_package ? $cpan_package->{version} : undef;
undef $cpan_version if $cpan_version && $cpan_version eq 'undef';
# special pre-processing for some specific paths
my @special_podfilters = ($special_podfilters{$path} // ());
# POD content, preferably from the 1st file in list, otherwise from the 2nd
my $pom = $self->extract_POM($sources[0], @special_podfilters);
my @content = $pom->content;
$pom = $self->extract_POM($sources[1], @special_podfilters)
if @sources > 1 and !@content;
# generate HTML through the view class
my $view = $self->mk_view(version => $version,
mtime => $mtime,
path => $path,
mod_name => $mod_name,
cpan_version => $cpan_version,
syntax_coloring => $coloring_package);
my $html = $view->print($pom);
# special handling for perlfunc : ids should be just function names
$html =~ s/li id="(.*?)_.*?"/li id="$1"/g
if $path =~ /\bperlfunc$/;
# special handling for 'perl' : hyperlinks to man pages
if ($path =~ /\bperl$/) {
my $sub = sub {my $txt = shift;
$txt =~ s[(perl\w+)]
[<a href="$self->{script_name}/$1">$1</a>]g;
return $txt};
$html =~ s[(<pre.*?</pre>)][$sub->($1)]egs;
}
return $self->respond_html($html, $mtime);
}
sub serve_script {
my ($self, $path) = @_;
# find file(s) corresponding to $path
my ($fullpath) = $self->find_script($path)
or die "no such script : $path";
# last modification time
my $mtime = (stat $fullpath)[9];
# call view to generate HTML
my $pom = $self->extract_POM($fullpath);
my $view = $self->mk_view(path => "script/$path",
mtime => $mtime,
syntax_coloring => $coloring_package);
my $html = $view->print($pom);
# return HTML
return $self->respond_html($html, $mtime);
}
sub extract_POM {
my ($self, $sourcefile, @more_podfilters) = @_;
my $pod = slurp_native_or_utf8($sourcefile);
$_->($pod) foreach @podfilters, @more_podfilters;
my $parser = Pod::POM->new;
my $pom = $parser->parse_text($pod) or die $parser->error;
return $pom;
}
sub _no_such_module {
my ($self, $module) = @_;
$module =~ s!/!::!g;
$module = Plack::Util::encode_html($module);
my $html = <<__EOHTML__;
<html>
<head>
<title>$module not found</title>
</head>
<body>
<h1>$module not found</h1>
<p>
The module <code>$module</code> could not be found on this server.
It may not be installed locally. Please try
<a href='https://metacpan.org/pod/$module' target='_blank'>$module on Metacpan</a>.
</p>
</body>
</html>
__EOHTML__
$self->respond_html($html);
}
#----------------------------------------------------------------------
# tables of contents
#----------------------------------------------------------------------
sub toc_for { # partial toc (called through Ajax)
my ($self, $prefix) = @_;
# special handling for builtin paths
for ($prefix) {
/^perldocs$/ and return $self->toc_perldocs;
/^pragmas$/ and return $self->toc_pragmas;
/^scripts$/ and return $self->toc_scripts;
}
# otherwise, find and htmlize entries under a given prefix
my $entries = $self->find_entries_for($prefix);
if ($prefix eq 'Pod') {
# in old versions of perl, basic docs are under Pod/perl*.pod. They should not be listed in the toc.
delete $entries->{$_} for grep /^perl/, keys %$entries;
}
return $self->respond_html($self->htmlize_entries($entries));
}
sub toc_perldocs {
my ($self) = @_;
my %perldocs;
# Perl basic docs are found under "pod" or "pods", depending on the installations.
# "perllocal.pod" is in the root dir.
for my $subdir (qw/pod pods/, "") {
my $entries = $self->find_entries_for($subdir);
# just keep the perl* entries, without subdir prefix
foreach my $key (grep /^perl/, keys %$entries) {
$perldocs{$key} = $entries->{$key};
$perldocs{$key}{node} =~ s[^$subdir/][]i;
}
}
return $self->respond_html($self->htmlize_perldocs(\%perldocs));
}
sub toc_pragmas {
my ($self) = @_;
my $entries = $self->find_entries_for(""); # files found at root level
delete $entries->{$_} for @ignore_toc_dirs, qw/pod pods inc/;
delete $entries->{$_} for grep {/^perl/ or !/^[[:lower:]]/} keys %$entries;
return $self->respond_html($self->htmlize_entries($entries));
}
sub toc_scripts {
my ($self) = @_;
my %scripts;
# gather all scripts and group them by initial letter
foreach my $dir ($self->script_dirs) {
opendir my $dh, $dir or next;
NAME:
foreach my $name (readdir $dh) {
for ("$dir/$name") {
-x && !-d && -T or next NAME ; # try to just keep Perl executables
}
$name =~ s/\.(pl|bat)$//i;
my $letter = uc substr $name, 0, 1;
$scripts{$letter}{$name} = {node => "script/$name", pod => 1};
}
}
# htmlize the structure
my $html = "";
foreach my $letter (sort keys %scripts) {
my $content = $self->htmlize_entries($scripts{$letter});
$html .= closed_node(label => $letter,
content => $content);
}
return $self->respond_html($html);
}
sub find_entries_for {
my ($self, $prefix) = @_;
# if $prefix is of shape A*, we want top-level modules starting
# with that letter
my $filter;
if ($prefix =~ /^([A-Z])\*/) {
$filter = qr/^$1/;
$prefix = "";
}
my %entries;
foreach my $root_dir ($self->module_dirs) {
my $dirname = $prefix ? "$root_dir/$prefix" : $root_dir;
opendir my $dh, $dirname or next;
foreach my $name (readdir $dh) {
next if $name =~ /^\./;
next if $filter and $name !~ $filter;
my $is_dir = -d "$dirname/$name";
my $has_pod = $name =~ s/\.(pm|pod)$//;
# skip if this subdir is a member of @INC (not a real module namespace)
next if $is_dir and grep {m[^\Q$dirname/$name\E]} $self->module_dirs;
if ($is_dir || $has_pod) { # found a TOC entry
$entries{$name}{node} = $prefix ? "$prefix/$name" : $name;
$entries{$name}{dir} = 1 if $is_dir;
$entries{$name}{pod} = 1 if $has_pod;
}
}
}
return \%entries;
}
sub htmlize_perldocs {
my ($self, $perldocs) = @_;
my $parser = Pod::POM->new;
# Pod/perl.pom Synopsis contains a classification of perl*.pod documents
my ($perl_path) = $self->find_module("perl")
or die "'perl.pod' does not seem to be installed on this system";
my $perlpom = $self->extract_POM($perl_path);
my $h1 = (firstval {$_->title eq 'GETTING HELP'} $perlpom->head1)
|| (firstval {$_->title eq 'SYNOPSIS'} $perlpom->head1);
my $html = "";
# classified pages mentioned in the synopsis
foreach my $h2 ($h1->head2) {
my $title = $h2->title;
my $content = $h2->verbatim;
# "Internals and C-Language Interface" is too long
$title =~ s/^Internals.*/Internals/;
# gather leaf entries
my @leaves;
while ($content =~ /^\s*(perl\S*)(?:\h+(\w.+))?/gm) {
my ($ref, $descr) = ($1, $2);
my $attrs = qq{id='$ref'};
$attrs .= qq{ title='$descr'} if $descr;
my $entry = delete $perldocs->{$ref} or next;
push @leaves, {label => $ref,
href => $entry->{node},
attrs => $attrs};
}
# sort and transform into HTML
@leaves = map {leaf(%$_)}
sort {$a->{label} cmp $b->{label}} @leaves;
$html .= closed_node(label => $title,
content => join("\n", @leaves));
}
# maybe some remaining pages
if (keys %$perldocs) {
$html .= closed_node(label => 'Unclassified',
content => $self->htmlize_entries($perldocs));
}
return $html;
}
sub htmlize_entries {
my ($self, $entries) = @_;
my $html = "";
my $has_index = $self->indexer->has_index;
foreach my $name (sort {uc($a) cmp uc($b)} keys %$entries) {
my $entry = $entries->{$name};
(my $id = $entry->{node}) =~ s[/][::]g;
my %args = (class => 'TN_leaf',
label => $name,
attrs => qq{id='$id'});
if ($entry->{dir}) {
$args{class} = 'TN_node TN_closed';
$args{attrs} .= qq{ TN:contentURL='toc/$entry->{node}'};
}
if ($entry->{pod}) {
$args{href} = $entry->{node};
$args{module_descr} = $self->indexer->get_module_description($entry->{node})
if $has_index;
}
$html .= generic_node(%args);
}
return $html;
}
sub main_toc {
my ($self, $req) = @_;
# initial page to open
my $ini = $req->parameters->{open};
my $select_ini = $ini ? "selectToc('$ini');" : "";
# perlfunc entries in JSON format for the DHTML autocompleter
my @funcs = map {$_->title} grep {$_->content =~ /\S/} $self->perlfunc_items;
s|[/\s(].*||s foreach @funcs;
my $json_funcs = "[" . join(",", map {qq{"$_"}} uniq @funcs) . "]";
# perlvar entries in JSON format for the DHTML autocompleter
my @vars = map {$_->title} grep {!/->/} map {@$_} $self->perlvar_items;
s|\s*X<.*||s foreach @vars;
s|\\|\\\\|g foreach @vars;
s|"|\\"|g foreach @vars;
my $json_vars = "[" . join(",", map {qq{"$_"}} uniq @vars) . "]";
# initial sections : perldocs, pragmas and scripts
my @perl_sections = map {closed_node(
label => ucfirst($_),
label_class => "TN_label small_title",
attrs => qq{TN:contentURL='toc/$_' id='$_'},
)} qw/perldocs pragmas scripts/;
# following sections : alphabetical list of modules (details will be loaded dynamically)
my $alpha_list = "";
for my $letter ('A' .. 'Z') {
$alpha_list .= closed_node (
label => $letter,
label_class => "TN_label",
attrs => qq{TN:contentURL='toc/$letter*' id='${letter}:'},
);
}
my $modules = generic_node (label => "Modules",
label_class => "TN_label small_title",
content => $alpha_list);
# build the HTML response
my $css_links = $self->css_links;
my $js_scripts = $self->js_scripts;
return $self->respond_html(<<__EOHTML__);
<html>
<head>
<base target="contentFrame">
$css_links
$js_scripts
<script>
var treeNavigator;
var perlfuncs = $json_funcs;
var perlvars = $json_vars;
var completers = {};
function submit_on_event(event) {
\$('search_form').submit();
}
function resize_tree_navigator() {
// compute available height -- comes either from body or documentElement,
// depending on browser and on compatibility mode !!
var doc_el_height = document.documentElement.clientHeight;
var avail_height
= (Prototype.Browser.IE && doc_el_height) ? doc_el_height
: document.body.clientHeight;
var tree_height = avail_height - \$('toc_frame_top').scrollHeight - 5;
if (tree_height > 100)
\$('TN_tree').style.height = tree_height + "px";
}
function open_nodes(first_node, rest) {
var node = \$(first_node);
if (!node || !treeNavigator) return;
// shift to next node in sequence
first_node = rest.shift();
// build a handler for "onAfterLoadContent" (closure on first_node/rest)
var open_or_select_next = function() {
// delete handler that might have been placed by previous call
delete treeNavigator.onAfterLoadContent;
//
if (rest.length > 0) {
open_nodes(first_node, rest)
}
else {
treeNavigator.openEnclosingNodes(\$(first_node));
treeNavigator.select(\$(first_node));
}
};
// if node is closed and currently has no content, we need to register
// a handler, open the node so that it gets its content by Ajax,
// and then execute the handler to open the rest after Ajax returns
if (treeNavigator.isClosed(node)
&& !treeNavigator.content(node)) {
treeNavigator.onAfterLoadContent = open_or_select_next;
treeNavigator.open(node);
}
// otherwise just a direct call
else {
open_or_select_next();
}
}
function selectToc(entry) {
// build array of intermediate nodes (i.e "Foo", "Foo::Bar", etc.)
var parts = entry.split(new RegExp("/|::"));
var accu = '';
var sequence = parts.map(function(e) {
accu = accu ? (accu + "::" + e) : e;
return accu;
});
// choose id of first_node by analysis of entry
var initial = entry.substr(0, 1);
var first_node
// CASE module (starting with uppercase)
= (initial <= 'Z') ? (initial + ":")
// CASE perl* documentation page
: entry.search(/^perl/) > -1 ? "perldocs"
// CASE other lowercase entries
: "pragmas"
;
// open each node in sequence
open_nodes(first_node, sequence);
}
function setup() {
treeNavigator
= new GvaScript.TreeNavigator('TN_tree', {tabIndex:-1});
completers.perlfunc = new GvaScript.AutoCompleter(
perlfuncs,
{minimumChars: 1,
minWidth: 100,
offsetX: -20,
autoSuggestDelay: 400});
completers.perlfunc.onComplete = submit_on_event;
completers.perlvar = new GvaScript.AutoCompleter(
perlvars,
{minimumChars: 1,
minWidth: 100,
offsetX: -20,
autoSuggestDelay: 400});
completers.perlvar.onComplete = submit_on_event;
completers.modlist = new GvaScript.AutoCompleter(
"search?source=modlist&search=",
{minimumChars: 2, minWidth: 100, offsetX: -20, typeAhead: false});
completers.modlist.onComplete = submit_on_event;
resize_tree_navigator();
$select_ini
}
document.observe('dom:loaded', setup);
window.onresize = resize_tree_navigator;
// Note: observe('resize') doesn't work. Why ?
function displayContent(event) {
var label = event.controller.label(event.target);
if (label && label.tagName == "A") {
label.focus();
return Event. stopNone;
}
}
function maybe_complete(input) {
if (input._autocompleter)
input._autocompleter.detach(input);
switch (input.form.source.selectedIndex) {
case 0: completers.perlfunc.autocomplete(input); break;
case 1: completers.perlvar.autocomplete(input); break;
case 3: if (!no_indexer)
completers.modlist.autocomplete(input);
break;
}
}
</script>
<style>
.small_title {color: midnightblue; font-weight: bold; padding: 0 3 0 3}
FORM {margin:0px}
BODY {margin:0px; font-size: 70%; overflow-x: hidden}
DIV {margin:0px; width: 100%}
#TN_tree {overflow-y:scroll; overflow-x: hidden}
</style>
</head>
<body>
<div id='toc_frame_top'>
<div class="small_title"
style="text-align:center;border-bottom: 1px solid">
$self->{page_title}
</div>
<div style="text-align:right">
<a href="$self->{script_name}/Pod/POM/Web/Help" class="small_title">Help</a>
</div>
<form action="search" id="search_form" method="get" accept-charset="UTF-8">
<span class="small_title">Search in</span>
<select name="source">
<option>perlfunc</option>
<option>perlvar</option>
<option>perlfaq</option>
<option>modules</option>
<option>full-text</option>
</select><br>
<span class="small_title"> for </span><input
name="search" size="15"
autocomplete="off"
onfocus="maybe_complete(this)">
</form>
<br>
<div class="small_title"
style="border-bottom: 1px solid">Browse</div>
</div>
<!-- In principle the tree navigator below would best belong in a
different frame, but instead it's in a div because the autocompleter
from the form above sometimes needs to overlap the tree nav. -->
<div id='TN_tree' onPing='displayContent'>
@perl_sections
$modules
</div>
</body>
</html>
__EOHTML__
}
#----------------------------------------------------------------------
# searching
#----------------------------------------------------------------------
sub dispatch_search {
my ($self, $req) = @_;
my $params = $req->parameters;
my $search_string = decode_utf8($params->{search});
for ($params->{source}) {
/^perlfunc$/ and return $self->search_perlfunc($search_string);
/^perlvar$/ and return $self->search_perlvar($search_string);
/^perlfaq$/ and return $self->search_perlfaq($search_string);
/^modules$/ and return $self->serve_module($search_string);
/^full-text$/ and return $self->search_fulltext($search_string, $params);
/^modlist$/ and return $self->modules_matching_prefix($search_string);
# otherwise
die "cannot search in '$_'";
}
}
sub perlfunc_items {
my ($self) = @_;
# gather POM description of all functions in perlfunc -- lazy loading at first call
if (!$self->{perlfunc_items}) {
my ($func_path) = $self->find_module("perlfunc")
or die "'perlfunc.pod' does not seem to be installed on this system";
my $funcpom = $self->extract_POM($func_path, $special_podfilters{perlfunc});
my ($description) = grep {$_->title eq 'DESCRIPTION'} $funcpom->head1;
my ($alphalist)
= grep {$_->title =~ /^Alphabetical Listing/i} $description->head2;
my @items = $alphalist->over->[0]->item;
$self->{perlfunc_items} = \@items;
}
return @{$self->{perlfunc_items}};
}
sub search_perlfunc {
my ($self, $func) = @_;
# find items matching the $func request
my @matching_items = grep {$_->title =~ /^$func\b/} $self->perlfunc_items
or return $self->respond_html("No documentation found for perl "
."function '<tt>$func</tt>'");
# htmlize
my $view = $self->mk_view(path => "perlfunc/$func");
my @li_items = map {$_->present($view)} @matching_items;
# hack the perlfunc internal links so that they call again search?source=perlfunc
s[href="#(\w+)"][href="$self->{script_name}/search?source=perlfunc&search=$1"]g
foreach @li_items;
# HTML response
my $css_links = $self->css_links;
return $self->respond_html(<<__EOHTML__);
<html>
<head>
$css_links
</head>
<body>
<h2>Extract from <a href="$self->{script_name}/perlfunc">perlfunc</a></h2>
<ul>@li_items</ul>
</body>
__EOHTML__
}
sub perlvar_items {
my ($self) = @_;
# lazily compute at first request; then store in $self
unless ($self->{perlvar_items}) {
# gather POM items defining variables
my ($var_path) = $self->find_module("perlvar")
or die "'perlvar.pod' does not seem to be installed on this system";
my $varpom = $self->extract_POM($var_path);
my @items = extract_POM_items($varpom);
# group items having common content
my $tmp = [];
foreach my $item (@items) {
push @$tmp, $item;
if ($item->content . "") { # force stringification
push @{$self->{perlvar_items}}, $tmp;
$tmp = [];
}
}
};
return @{$self->{perlvar_items}};
}
sub search_perlvar {
my ($self, $var) = @_;
# HTML list of items matching the $func request
my @items = grep {any { $_->title =~ /^\Q$var\E(\s|$)/ } @$_}
$self->perlvar_items
or return $self->respond_html("No documentation found for perl "
."variable '<tt>$var</tt>'");
my $view = $self->mk_view(path => "perlvar/$var");
my @li_items = map {$_->present($view)} map {@$_} @items;
# HTML response
my $css_links = $self->css_links;
return $self->respond_html(<<__EOHTML__);
<html>
<head>
$css_links
</head>
<body>
<h2>Extract from <a href="$self->{script_name}/perlvar">perlvar</a></h2>
<ul>@li_items</ul>
</body>
__EOHTML__
}
sub search_perlfaq {
my ($self, $faq_entry) = @_;
my $regex = qr/\b\Q$faq_entry\E\b/i;
my $answers = "";
my $n_answers = 0;
my $view = $self->mk_view(path => "perlfaq/$faq_entry");
# gather headings that match the regex in any of the perlfaq* pages
FAQ:
foreach my $faq (map {"perlfaq$_"} 1..9) {
my ($faq_path) = $self->find_module($faq)
or die "'$faq.pod' does not seem to be installed on this system";
my $faqpom = $self->extract_POM($faq_path);
my @questions = map {grep {$_->title =~ $regex} $_->head2} $faqpom->head1
or next FAQ;
my @nodes = map {$view->print($_)} @questions;
my $html = join "", @nodes;
my @split_on_tags = split /(<.*?>)/, $html;
for (my $i = 0; $i < @split_on_tags; $i += 2) {
$split_on_tags[$i] =~ s[($regex)][<span class="hl">$1</span>]g;
}
$html = join "", @split_on_tags;
$answers .= generic_node(label => "Found in $faq",
label_tag => "h2",
content => $html);
$n_answers += @nodes;
}
# HTML response
my $css_links = $self->css_links;
my $js_scripts = $self->js_scripts;
return $self->respond_html(<<__EOHTML__);
<html>
<head>
$css_links
$js_scripts
<style>
.hl {background-color: lightpink}
</style>
<script>
var treeNavigator;
function setup() {
treeNavigator = new GvaScript.TreeNavigator('TN_tree');
}
window.onload = setup;
</script>
</head>
<body>
<h1>Extracts from <a href="$self->{script_name}/perlfaq">perlfaq</a></h1><br>
<em>searched for regex '$faq_entry' in titles of faq documents: $n_answers answers</em><br><br>
<div id='TN_tree'>
$answers
</div>
</body>
__EOHTML__
}
sub search_fulltext {
my ($self, $search_string, $params) = @_;
# start of HTML page
my $css_links = $self->css_links;
my $html = <<__EOHTML__;
<html>
<head>
$css_links
<style>
.src {font-size:70%; float: right}
.sep {font-size:110%; font-weight: bolder; color: magenta;
padding-left: 8px; padding-right: 8px}
.hl {background-color: lightpink}
.reindex_form {float: right; border: 3px double #888;}
</style>
<script>
function confirm_reindex() {
var want_reindex = confirm("This action may take a few minutes. The index will use " +
"about 20MB on your hard disk. Proceed ?");
if (want_reindex)
document.getElementById('ft_results').innerHTML
= "Reindex in progress, please wait...";
return want_reindex;
}
</script>
</head>
<body>
<form class="reindex_form" action="$self->{script_name}/ft_index"
onsubmit="return confirm_reindex()">
(Re)generate index
<label><input type=radio name=from_scratch value=0 checked>incrementally</label>
<label><input type=radio name=from_scratch value=1>from scratch</label>
<input type=submit value=Go>
</form>
<div id="ft_results">
__EOHTML__
# main content
if (!$self->indexer->has_index) {
$html .= "No full-text index found in $self->{index_dir}."
. "Please use the form above to generate the index";
}
else {
my $count = $params->{count} || 50;
my $start_record = $params->{start} || 0;
my $end_record = $start_record + $count - 1;
# callback function used by the indexer to access the content of documents
my $get_doc_content = sub {
my $path = shift;
my @filenames = $self->find_module($path);
return join "\n", map {slurp_native_or_utf8($_)} @filenames;
};
# results from the indexer
my $results = $self->indexer->search($search_string, $start_record, $end_record,
$get_doc_content);
my $killedWords = join ", ", @{$results->{killedWords}};
$killedWords &&= " (ignoring words : $killedWords)";
# adjust numbers
my $n_in_slice = @{$results->{modules}};
$end_record = $start_record + $n_in_slice -1;
my $n_total = $results->{n_total};
# build navigation links
my $base_url = encode_utf8("?source=full-text&search=$search_string");
my $nav_links = $self->nav_links($base_url, $start_record, $end_record, $count, $n_total);
# more HTML content
$html .= "<b>Full-text search</b> for '$search_string'$killedWords<br>"
. "$nav_links<hr>\n";
# generate HTML for each result
foreach my $module (@{$results->{modules}}) {
my ($path, $description, $excerpts) = @$module;
foreach (@$excerpts) {
s/&/&/g, s/</</g, s/>/>/g; # replace entities
s/\[\[/<span class='hl'>/g, s/\]\]/<\/span>/g; # highlight
}
my $lst_excerpts = join "<span class='sep'>/</span>", @$excerpts;
$html .= "<p>"
. "<a href='$self->{script_name}/source/$path' class='src'>source</a>"
. "<a href='$self->{script_name}/$path'>$path</a>"
. ($description ? " <em>$description</em>" : "")
. "<br>"
. "<small>$lst_excerpts</small>"
. "</p>";
}
$html .= "<hr>$nav_links\n";
}
# finish the page
$html .= "</div></body></html>";
# respond
return $self->respond_html($html);
}
sub nav_links {
my ($self, $base_url, $start_record, $end_record, $n_slice, $n_total) = @_;
my $prev_idx = max($start_record - $n_slice, 0);
my $next_idx = $start_record + $n_slice;
my $prev_link = $start_record > 0 ? "$base_url&start=$prev_idx" : "";
my $next_link = $next_idx < $n_total ? "$base_url&start=$next_idx" : "";
# URI escape
s{([^;\/?:@&=\$,A-Za-z0-9\-_.!~*'()])}
{sprintf("%%%02X", ord($1)) }ge for $prev_link, $next_link;
$_ += 1 for $start_record, $end_record;
my $nav_links = "";
$nav_links .= "<a href='$prev_link'>[Previous <<]</a> " if $prev_link;
$nav_links .= "Results <b>$start_record</b> to <b>$end_record</b> "
. "from <b>$n_total</b>";
$nav_links .= " <a href='$next_link'>[>> Next]</a> " if $next_link;
return $nav_links;
}
sub modules_matching_prefix { # called by Ajax
my ($self, $search_string) = @_;
$self->indexer->has_index
or die "module list : no index";
my @matching_modules = $self->indexer->modules_matching_prefix($search_string);
my $json = "[" . join(",", map {qq{"$_"}} sort @matching_modules) . "]";
return $self->respond(content => $json,
mime_type => 'application/x-json');
}
#----------------------------------------------------------------------
# updating the fulltext index
#----------------------------------------------------------------------
sub ft_index {
my ($self, $req) = @_;
# free the indexer
delete $self->{indexer};
# start another process for updating or building the fulltext index
my $command = "index";
$command .= "(from_scratch=>1)" if $req->parameters->get('from_scratch');
warn "STARTING COMMAND $command\n";
open my $pipe, '-|', qq{perl -Ilib -MPod::POM::Web -e "$command"};
# pipe progress reports from the subprocess into the HTTP response,
# using Plack's streaming API
my $res = Plack::Response->new(200);
$res->content_type('text/plain');
$res->body($pipe);
return $res->finalize;
}
#----------------------------------------------------------------------
# encapsulation of Plack response
#----------------------------------------------------------------------
sub respond_html {
my ($self, $html, $mtime) = @_;
$self->respond(content => encode_utf8($html),
code => 200,
mtime => $mtime,
charset => 'UTF-8');
}
sub respond {
my ($self, %args) = @_;
my $charset = $args{charset};
my $length = length $args{content};
my $mime_type = $args{mime_type} || "text/html";
$mime_type .= "; charset=$charset" if $charset and $mime_type =~ /html/;
my $code = $args{code} || 200;
my $headers = {Content_type => $mime_type,
Content_length => $length};
$headers->{Last_modified} = gmtime($args{mtime}) if $args{mtime};
my $r = Plack::Response->new($code, $headers, $args{content});
$r->finalize;
}
#----------------------------------------------------------------------
# miscellaneous
#----------------------------------------------------------------------
sub mk_view {
my ($self, %args) = @_;
my $view = Pod::POM::View::HTML::_PerlDoc->new(
script_name => $self->{script_name},
css_links => $self->css_links,
js_scripts => $self->js_scripts,
%args
);
return $view;
}
sub find_module {
my ($self, $path) = @_;
return $self->find_files(module_dirs => "$path.pod", "$path.pm",
"pod/$path.pod", "pods/$path.pod");
}
sub find_script {
my ($self, $path) = @_;
return $self->find_files(script_dirs => $path, "$path.pl", "$path.bat");
}
sub find_files {
my ($self, $dirs_method, @file_candidates) = @_;
# try each dir in turn. The first successful search wins.
foreach my $dir ($self->$dirs_method) {
my @found = grep {-f} map {"$dir/$_"} @file_candidates;
return @found if @found; # returns a list because there could be both a *.pm and *.pod
}
# empty list if nothing is found
return;
}
sub css_links {
my ($self) = @_;
my @css = qw(Alien/GvaScript/lib/GvaScript.css Pod/POM/Web/lib/PodPomWeb.css);
my @links = map {"<link href='$self->{script_name}/$_' rel='stylesheet' type='text/css'>\n"}
@css;
return join "", @links;
}
sub js_scripts {
my ($self) = @_;
my @src = qw(Alien/GvaScript/lib/prototype.js Alien/GvaScript/lib/GvaScript.js);
my @scripts = map {"<script src='$self->{script_name}/$_'></script>\n"} @src;
return join "", @scripts;
}
#----------------------------------------------------------------------
# generating GvaScript treeNavigator structure
#----------------------------------------------------------------------
sub generic_node {
my %args = @_;
$args{class} ||= "TN_node";
my $attrs = $args{attrs} ? " $args{attrs}" : "";
$args{content} ||= "";
$args{content} &&= qq{<div class="TN_content">$args{content}</div>};
my ($default_label_tag, $label_attrs)
= $args{href} ? ("a", qq{ href='$args{href}'})
: ("span", "" );
$args{label_tag} ||= $default_label_tag;
$args{label_class} ||= "TN_label";
if ($args{module_descr}) {
my $module_descr = Plack::Util::encode_html($args{module_descr});
$label_attrs .= qq{ title="$module_descr"};
}
return qq{<div class="$args{class}"$attrs>}
. qq{<$args{label_tag} class="$args{label_class}"$label_attrs>}
. $args{label}
. qq{</$args{label_tag}>}
. $args{content}
. qq{</div>};
}
sub closed_node {
return generic_node(@_, class => "TN_node TN_closed");
}
sub leaf {
return generic_node(@_, class => "TN_leaf");
}
1;
#======================================================================
# END OF package Pod::POM::Web
#======================================================================
#======================================================================
package Pod::POM::View::HTML::_PerlDoc; # View package
#======================================================================
use strict;
use warnings;
no warnings qw/uninitialized/;
use base qw/Pod::POM::View::HTML/;
use POSIX qw/strftime/; # date formatting
use List::MoreUtils qw/firstval/;
use Plack::Util;
# SUPER::view_seq_text tries to find links automatically ... but is buggy
# for URLs that contain '$' or ' '. So we disable it, and only consider
# links explicitly marked with L<..>, handled in view_seq_link() below.
sub view_seq_text {
my ($self, $text) = @_;
for ($text) {
s/&/&/g;
s/</</g;
s/>/>/g;
}
return $text;
}
# some adaptations to SUPER::view_seq_link
sub view_seq_link {
my ($self, $link) = @_;
# we handle the L<link_text|...> syntax here, because we also want
# link_text for http URLS (not supported by SUPER::view_seq_link)
my $link_text;
$link =~ s/^([^|]+)\|// and $link_text = $1;
# links to external resources will open in a blank page
my $is_external_resource = ($link =~ m[^\w+://]);
# call parent and reparse the result
my $linked = $self->SUPER::view_seq_link($link);
my ($url, $label) = ($linked =~ m[^<a href="(.*?)">(.*)</a>]);
# fix link for 'hash' part of the url
$url =~ s[#(.*)]['#' . _title_to_id($1)]e unless $is_external_resource;
# if explicit link_text given by client, take that as label, unchanged
if ($link_text) {
$label = $link_text;
}
# if "$page/$section", replace by "$section in $page"
elsif ($label !~ m{^\w+://}s) { # but only if not a full-blown URL
$label =~ s[^(.*?)/(.*)$][$1 ? "$2 in $1" : $2]e ;
}
# return link (if external resource, opens in a new browser window)
my $target = $is_external_resource ? " target='_blank'" : "";
return qq{<a href="$url"$target>$label</a>};
}
sub view_seq_link_transform_path {
my($self, $page) = @_;
$page =~ s[::][/]g;
return "$self->{script_name}/$page";
}
sub view_item {
my ($self, $item) = @_;
my $title = eval {$item->title->present($self)} || "";
$title = "" if $title =~ /^\s*\*\s*$/;
my $class = "";
my $id = _title_to_id($title);
$id &&= qq{ id="$id"};
my $content = $item->content->present($self);
$title = qq{<b>$title</b>} if $title;
return qq{<li$id$class>$title\n$content</li>\n};
}
sub _title_to_id {
my $title = shift;
$title =~ s/<.*?>//g; # no tags
$title =~ s/[,(].*//; # drop argument lists or text lists
$title =~ s/\s*$//; # drop final spaces
$title =~ s/[^A-Za-z0-9_]/_/g; # replace chars unsuitable for an id
return $title;
}
sub view_pod {
my ($self, $pom) = @_;
# compute view
my $content = $pom->content->present($self)
or return "no documentation found in <tt>$self->{path}</tt><br>\n"
. "<a href='$self->{script_name}/source/$self->{path}'>Source</a>";
# parse name and description
my $name_h1 = firstval {$_->title =~ /^(NAME|TITLE)\b/} $pom->head1();
my $doc_title = $name_h1 ? $name_h1->content->present('Pod::POM::View')
# retrieve content as plain text
: 'Untitled';
my ($name, $description) = ($doc_title =~ /^\s*(.*?)\s+-+\s+(.*)/);
$name ||= $doc_title;
$name =~ s/\n.*//s;
# installation date
my $installed = strftime("%x", localtime($self->{mtime}));
# if this is a module (and not a script), get additional info
my ($version, $core_release, $orig_version, $module_refs) = ("") x 5;
if (my $mod_name = $self->{mod_name}) {
# version
$version = $self->{version} ? "v. $self->{version}, " : "";
# is this module in Perl core ?
$core_release = Module::CoreList->first_release($mod_name) || "";
$orig_version
= $Module::CoreList::version{$core_release}{$mod_name} || "";
$orig_version &&= "v. $orig_version ";
$core_release &&= "; ${orig_version}entered Perl core in $core_release";
# latest CPAN version
my $latest_version = $self->{cpan_version} ? " (v. $self->{cpan_version})" : "";
# hyperlinks to various internet resources
$module_refs = qq{<br>
<a href="https://metacpan.org/pod/$mod_name"
target="_blank">meta::cpan$latest_version</a>
};
}
my $toc = $self->make_toc($pom, 0);
my $css_links = $self->{css_links};
my $js_scripts = $self->{js_scripts};
return <<__EOHTML__
<html>
<head>
<title>$name</title>
$css_links
$js_scripts
<script>
var treeNavigator;
function setup() {
new GvaScript.TreeNavigator(
'TN_tree',
{selectFirstNode: (location.hash ? false : true),
tabIndex: 0}
);
var tocFrame = window.parent.frames.tocFrame;
if (tocFrame) {
try {tocFrame.eval("selectToc('$name')")}
catch(e) {};
}
}
window.onload = setup;
function jumpto_href(event) {
var label = event.controller.label(event.target);
if (label && label.tagName == "A") {
/* label.focus(); */
return Event.stopNone;
}
}
</script>
<style>
#TOC .TN_content .TN_label {font-size: 80%; font-weight: bold}
#TOC .TN_leaf .TN_label {font-weight: normal}
#ref_box {
clear: right;
float: right;
text-align: right;
font-size: 80%;
}
#title_descr {
clear: right;
float: right;
font-style: italic;
margin-top: 8px;
margin-bottom: 8px;
padding: 5px;
text-align: center;
border: 3px double #888;
}
</style>
</head>
<body>
<div id='TN_tree'>
<div class="TN_node">
<h1 class="TN_label">$name</h1>
<small>(${version}installed $installed$core_release)</small>
<span id="title_descr">$description</span>
<span id="ref_box">
<a href="$self->{script_name}/source/$self->{path}">Source</a>
$module_refs
</span>
<div class="TN_content">
<div class="TN_node" onPing="jumpto_href" id="TOC">
<h3 class="TN_label">Table of contents</h3>
<div class="TN_content">
$toc
</div>
</div>
<hr/>
</div>
</div>
$content
</div>
</body>
</html>
__EOHTML__
}
# generating family of methods for view_head1, view_head2, etc.
BEGIN {
for my $num (1..6) {
no strict 'refs';
*{"view_head$num"} = sub {
my ($self, $item) = @_;
my $title = $item->title->present($self);
my $id = _title_to_id($title);
my $content = $item->content->present($self);
my $h_num = $num + 1;
return <<EOHTML
<div class="TN_node" id="$id">
<h$h_num class="TN_label">$title</h$h_num>
<div class="TN_content">
$content
</div>
</div>
EOHTML
}
}
}
sub view_seq_index {
my ($self, $item) = @_;
return ""; # Pod index tags have no interest for HTML
}
sub view_verbatim {
my ($self, $text) = @_;
my $coloring = $self->{syntax_coloring};
if ($coloring) {
my $method = "${coloring}_coloring";
$text = $self->$method($text);
}
else {
$text = Plack::Util::encode_html($text);
}
# hyperlinks to other modules
$text =~ s{(\buse\b(?:</span>)?\ +(?:<span.*?>)?)([\w:]+)}
{my $url = $self->view_seq_link_transform_path($2);
qq{$1<a href="$url">$2</a>} }eg;
if ($self->{line_numbering}) {
my $line = 1;
$text =~ s/^/sprintf "%6d\t", $line++/egm;
}
return qq{<pre class="$coloring">$text</pre>};
}
sub PPI_coloring {
my ($self, $text) = @_;
my $ppi = PPI::HTML->new();
my $html = $ppi->html(\$text);
if ($html) {
$html =~ s/<br>//g;
return $html;
}
else { # PPI failed to parse that text
return Plack::Util::encode_html($text);
}
}
sub SCINEPLEX_coloring {
my ($self, $text) = @_;
eval {
$text = ActiveState::Scineplex::Annotate($text,
'perl',
outputFormat => 'html');
};
return $text;
}
sub make_toc {
my ($self, $item, $level) = @_;
my $html = "";
my $method = "head" . ($level + 1);
my $sub_items = $item->$method;
foreach my $sub_item (@$sub_items) {
my $title = $sub_item->title->present($self);
my $id = _title_to_id($title);
my $node_content = $self->make_toc($sub_item, $level + 1);
my $class = $node_content ? "TN_node" : "TN_leaf";
$node_content &&= qq{<div class="TN_content">$node_content</div>};
$html .= qq{<div class="$class">}
. qq{<a class="TN_label" href="#$id">$title</a>}
. $node_content
. qq{</div>};
}
return $html;
}
sub DESTROY {} # avoid AUTOLOAD
1;
__END__
=encoding ISO8859-1
=head1 NAME
Pod::POM::Web - HTML Perldoc server
=head1 DESCRIPTION
L<Pod::POM::Web> is a Web application for browsing
the documentation of Perl components installed
on your local machine. Since pages are dynamically
generated, they are always in sync with code actually
installed.
The application offers
=over
=item *
a tree view for browsing through installed modules
(with dynamic expansion of branches as they are visited)
=item *
a tree view for navigating and opening / closing sections while
visiting a documentation page
=item *
a source code view with hyperlinks between used modules
and optionally with syntax coloring
(see section L</"Optional features">)
=item *
direct access to L<perlfunc> entries (builtin Perl functions)
=item *
search through L<perlfaq> headers
=item *
full-text search, including names of Perl variables
(this is an optional feature -- see section L</"Optional features">).
=item *
parsing and display of version number
=item *
display if and when the displayed module entered Perl core.
=item *
parsing pod links and translating them into hypertext links
=item *
links to MetaCPAN
=back
The application may be hosted by an existing Web server, or otherwise
may run its own builtin Web server. Instructions for launching the application
are given in the next section.
Usage of the application is described in a separate document
L<Pod::POM::Web::Help>.
=head1 STARTING THE WEB APPLICATION
=head2 Starting from the command-line
The simplest way to use this application is to start a process invoking
the builtin HTTP server :
perl -MPod::POM::Web -e server
This is useful if you have no other HTTP server, or if
you want to run this module under the perl debugger.
The server will listen at L<http://localhost:5000>.
A different port may be specified :
perl -MPod::POM::Web -e server -- -p 8888
Notice the double dash C<--> : this is used to separate options to the
C<perl> command itself from options to C<Pod::POM::Web>.
The internal implementation of C<server> is based on L<Plack::Runner>, the same
module that also supports the L<plackup> utility. All plackup options
can also be used here -- see plackup's documentation.
Another way to start the server is to call C<plackup> directly :
plackup -MPod::POM::Web -e app -p 8888
In this case no double dash is required.
=head3 As a cgi-bin script
Alternatively, you can run this application as a cgi-script
by writing a simple file F<perldoc> in your C<cgi-bin> directory,
containing :
#!/path/to/perl
use Pod::POM::Web;
use Plack::Handler::CGI;
my $app = Pod::POM::Web->new->to_app;
Plack::Handler::CGI->new->run($app);
For historical reasons, the module also supports a simpler invocation,
written as follows :
#!/path/to/perl
use Pod::POM::Web;
Pod::POM::Web->handler;
Make this script executable,
then navigate to URL L<http://localhost/cgi-bin/perldoc>.
=head3 Other Web architectures -- PSGI
The application is built on top of the well-known L<Plack> middleware for
web applications, using the L<PSGI> protocol. Therefore it can be integrated
easily in various Web architectures. Write a F<.psgi> file as follows :
use Pod::POM::Web;
Pod::POM::Web->new->to_app;
and invoke one of the Web server adapters under L<Plack::Handler>.
=head2 Opening a specific initial page
By default, the initial page displayed by the application
is F<perl>. This can be changed by supplying an C<open> argument
with the path to any documentation page: for example
http://localhost:8080?open=Pod/POM/Web
http://localhost:8080?open=perlfaq
=head2 Setting a specific title
If you run several instances of C<Pod::POM::Web> simultaneously, you may
want them to have distinct titles. This can be done like this:
perl -MPod::POM::Web -e server -- --title "My Own Perl Doc"
=head1 MISCELLANEOUS
=head2 Note about security
This application is intended as a power tool for Perl developers,
not as an Internet application. It will give read access to any file
installed under your C<@INC> path or Apache C<lib/perl> directory;
so it is probably a B<bad idea>
to put it on a public Internet server.
=head2 Optional features
=head3 Syntax coloring
Syntax coloring improves readability of code excerpts.
If your Perl distribution is from ActiveState, then
C<Pod::POM::Web> will take advantage
of the L<ActiveState::Scineplex> module
which is already installed on your system. Otherwise,
you need to install L<PPI::HTML>, available from CPAN.
=head3 Full-text indexing
C<Pod::POM::Web> can index the documentation and source code
of all your installed modules, including Perl variable names,
C<Names:::Of::Modules>, etc. To use this feature you need to
=over
=item *
install L<Search::Indexer> from CPAN
=item *
build the index as described in L<Pod::POM::Web::Indexer> documentation.
=back
=head3 Indication of the latest CPAN version
When displaying a module, L<CPAN::Common::Index> is used to try to identify the
latest CPAN version of that module. By default the information comes from
C<http://cpanmetadb.plackperl.org/v1.0/>, but it requires an internet connection.
If a local installation of L<CPAN::Mini> is available, this will be used as
a primary source of information.
=head1 HINTS TO POD AUTHORING
=head2 Images
The Pod::Pom::Web server also serves non-pod files within the C<@INC>
hierarchy. This is useful for example to include images in your
documentation, by inserting chunks of HTML as follows :
=for html
<img src="pretty_diagram.jpg">
or
=for html
<object type="image/svg+xml" data="try.svg" width="640" height="480">
</object>
Here it is assumed that auxiliary files C<pretty_diagram.jpg> or
C<try.svg> are in the same directory than the POD source; but
of course relative or absolute links can be used.
=head1 CLASS METHODS
=head2 import
When the module is C<use>d from the command-line, the C<import> method
automatically exports a C<server> function and an C<app> function to
facilitate server startup.
=head2 server
Invokes L<Plack::Runner> to launch the server.
=head2 app
Creates an instance of the module and returns a L<PSGI> app.
Options from the command-line that are not consumed by L<plackup>
are read and passed to to the L<new> method. Available options are :
=over
=item C<page_title> or C<title>
Title for this instance of the application.
=item C<module_dirs> or C<mdirs>
Additional directories to search for modules.
=item C<script_dirs> or C<sdirs>
Additional directories to search for scripts.
=back
=head2 handler
Legacy class method, used by CGI scripts or mod_perl handlers.
=head2 new
Constructor. May take the following arguments :
=over
=item C<page_title>
for specifying the HTML title
of the application (useful if you run several concurrent instances
of Pod::POM::Web).
=item C<module_dirs>
directories for searching for modules,
in addition to the standard ones installed with your perl executable.
=item C<script_dirs>
additional directories for searching for scripts
=item C<script_name>
URL fragment to be prepended before each internal hyperlink.
=back
=head1 INSTANCE METHODS
Instance methods are not meant to be called by external clients.
Some documentation can be found in the source code.
=head1 ACKNOWLEDGEMENTS
This web application was deeply inspired by :
=over
=item *
the structure of HTML Perl documentation released with
ActivePerl (L<http://www.activeperl.com/ASPN/Perl>).
=item *
the excellent tree navigation in Microsoft's former MSDN Library Web site
-- since they rebuilt the site, keyboard navigation has gone !
=item *
the standalone HTTP server implemented in L<Pod::WebServer>.
=item *
the wide possibilities of Andy Wardley's L<Pod::POM> parser.
=back
Thanks
to Philippe Bruhat who mentioned a weakness in the API,
to Chris Dolan who supplied many useful suggestions and patches,
to Rémi Pauchet who pointed out a regression bug with Firefox CSS,
to Alexandre Jousset who fixed a bug in the TOC display,
to Cédric Bouvier who pointed out a IO bug in serving binary files,
to Elliot Shank who contributed the "page_title" option,
to Olivier 'dolmen' Mengué who suggested to export "server" into C<main::>,
to Ben Bullock who added the 403 message for absent modules,
and to Paul Cochrane for several improvements in the doc and in the
repository structure.
=head1 AUTHOR
Laurent Dami, C<< <dami AT cpan DOT org> >>
=head1 COPYRIGHT & LICENSE
Copyright 2007-2021 Laurent Dami, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.