#====================================================================== package Pod::POM::Web; # see doc at end of file #====================================================================== use strict; use warnings; no warnings 'uninitialized'; use Pod::POM 0.25; # parsing Pod use List::Util qw/max/; # maximum use List::MoreUtils qw/uniq firstval any/; use Module::CoreList; # asking if a module belongs to Perl core use HTTP::Daemon; # for the builtin HTTP server use URI; # parsing incoming requests use URI::QueryParam; # implements URI->query_form_hash use MIME::Types; # translate file extension into MIME type use Alien::GvaScript 1.021000; # javascript files use Encode::Guess; # guessing if pod source is utf8 or latin1 use Config; # where are the script directories use Getopt::Long qw/GetOptions/; # parsing options from command-line #---------------------------------------------------------------------- # globals #---------------------------------------------------------------------- our $VERSION = '1.20'; # some subdirs never contain Pod documentation my @ignore_toc_dirs = qw/auto unicore/; # filter @INC (don't want '.', nor server_root added by mod_perl) my $server_root = eval {Apache2::ServerUtil::server_root()} || ""; our # because accessed from Pod::POM::Web::Indexer @search_dirs = grep {!/^\./ && $_ ne $server_root} @INC; # directories for executable perl scripts my @config_script_dirs = qw/sitescriptexp vendorscriptexp scriptdirexp/; my @script_dirs = grep {$_} @Config{@config_script_dirs}; # syntax coloring (optional) my $coloring_package = eval {require PPI::HTML} ? "PPI" : eval {require ActiveState::Scineplex} ? "SCINEPLEX" : ""; # fulltext indexing (optional) my $no_indexer = eval {require Pod::POM::Web::Indexer} ? 0 : $@; # CPAN latest version info (tentative, but disabled because CPAN is too slow) my $has_cpan = 0; # eval {require CPAN}; # 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 = ( # AnnoCPAN must be first in the filter list because # it uses the MD5 of the original source eval {require AnnoCPAN::Perldoc::Filter} ? sub {$_[0] = AnnoCPAN::Perldoc::Filter->new->filter($_[0])} : (), # Pod::POM fails to parse correctly when there is an initial blank line sub { $_[0] =~ s/\A\s*// }, ); our # because used by Pod::POM::View::HTML::_PerlDoc %escape_entity = ('&' => '&', '<' => '<', '>' => '>', '"' => '"'); #---------------------------------------------------------------------- # import : just export the "server" function if called from command-line #---------------------------------------------------------------------- sub import { my $class = shift; my ($package, $filename) = caller; no strict 'refs'; *{'main::server'} = sub {$class->server(@_)} if $package eq 'main' and $filename eq '-e'; } #---------------------------------------------------------------------- # main entry point #---------------------------------------------------------------------- sub server { # builtin HTTP server; unused if running under Apache my ($class, $port, $options) = @_; $options ||= $class->_options_from_cmd_line; $port ||= $options->{port} || 8080; my $daemon = HTTP::Daemon->new(LocalPort => $port, ReuseAddr => 1) # patch by CDOLAN or die "could not start daemon on port $port"; print STDERR "Please contact me at: url, ">\n"; # main server loop while (my $client_connection = $daemon->accept) { while (my $req = $client_connection->get_request) { print STDERR "URL : " , $req->url, "\n"; $client_connection->force_last_request; # patch by CDOLAN my $response = HTTP::Response->new; $class->handler($req, $response, $options); $client_connection->send_response($response); } $client_connection->close; undef($client_connection); } } sub _options_from_cmd_line { GetOptions(\my %options, qw/port=i page_title|title=s/); $options{port} ||= $ARGV[0] if @ARGV; # backward support for old API return \%options; } sub handler : method { my ($class, $request, $response, $options) = @_; my $self = $class->new($request, $response, $options); eval { $self->dispatch_request(); 1} or $self->send_content({content => $@, code => 500}); return 0; # Apache2::Const::OK; } sub new { my ($class, $request, $response, $options) = @_; $options ||= {}; my $self = {%$options}; # cheat: will create an instance of the Indexer subclass if possible if (!$no_indexer && $class eq __PACKAGE__) { $class = "Pod::POM::Web::Indexer"; } for (ref $request) { /^Apache/ and do { # coming from mod_perl my $path = $request->path_info; my $q = URI->new; $q->query($request->args); my $params = $q->query_form_hash; (my $uri = $request->uri) =~ s/$path$//; $self->{response} = $request; # Apache API: same object for both $self->{root_url} = $uri; $self->{path} = $path; $self->{params} = $params; last; }; /^HTTP/ and do { # coming from HTTP::Daemon // server() method above $self->{response} = $response; $self->{root_url} = ""; $self->{path} = $request->url->path; $self->{params} = $request->url->query_form_hash; last; }; #otherwise (coming from cgi-bin or mod_perl Registry) my $q = URI->new; $q->query($ENV{QUERY_STRING}); my $params = $q->query_form_hash; $self->{response} = undef; $self->{root_url} = $ENV{SCRIPT_NAME}; $self->{path} = $ENV{PATH_INFO}; $self->{params} = $params; } bless $self, $class; } sub dispatch_request { my ($self) = @_; my $path_info = $self->{path}; # security check : no outside directories $path_info =~ m[(\.\.|//|\\|:)] and die "illegal path: $path_info"; $path_info =~ s[^/][] or return $self->index_frameset; for ($path_info) { /^$/ and return $self->index_frameset; /^index$/ and return $self->index_frameset; /^toc$/ and return $self->main_toc; /^toc\/(.*)$/ and return $self->toc_for($1); # Ajax calls /^script\/(.*)$/ and return $self->serve_script($1); /^search$/ and return $self->dispatch_search; /^source\/(.*)$/ and return $self->serve_source($1); # for debugging /^_dirs$/ and return $self->send_html(join "
", @search_dirs); # file extension : passthrough /\.(\w+)$/ and return $self->serve_file($path_info, $1); #otherwise return $self->serve_pod($path_info); } } sub index_frameset{ my ($self) = @_; # initial page to open my $ini = $self->{params}{open}; my $ini_content = $ini || "perl"; my $ini_toc = $ini ? "toc?open=$ini" : "toc"; # HTML title my $title = $self->{page_title} || 'Perl documentation'; $title =~ s/([&<>"])/$escape_entity{$1}/g; return $self->send_html(<<__EOHTML__); $title __EOHTML__ } #---------------------------------------------------------------------- # serving a single file #---------------------------------------------------------------------- sub serve_source { my ($self, $path) = @_; my $params = $self->{params}; # default (if not printing): line numbers and syntax coloring are on $params->{print} or $params->{lines} = $params->{coloring} = 1; my @files = $self->find_source($path) or die "No file for '$path'"; my $mtime = max map {(stat $_)[9]} @files; my $display_text; foreach my $file (@files) { my $text = $self->slurp_file($file, ":crlf"); my $view = $self->mk_view( line_numbering => $params->{lines}, syntax_coloring => ($params->{coloring} ? $coloring_package : "") ); $text = $view->view_verbatim($text); $display_text .= "

$file

$text
"; } my $offer_print = $params->{print} ? "" : <<__EOHTML__;
with
line numbers
syntax coloring
__EOHTML__ my $script = $params->{print} ? <<__EOHTML__ : ""; __EOHTML__ my $doc_link = $params->{print} ? "" : <<__EOHTML__; Doc __EOHTML__ return $self->send_html(<<__EOHTML__, $mtime); Source of $path $doc_link

Source of $path

$offer_print $display_text __EOHTML__ } sub serve_file { my ($self, $path, $extension) = @_; my $fullpath = firstval {-f $_} map {"$_/$path"} @search_dirs or die "could not find $path"; my $mime_type = MIME::Types->new->mimeTypeOf($extension); my $content = $self->slurp_file($fullpath, ":raw"); my $mtime = (stat $fullpath)[9]; $self->send_content({ content => $content, mtime => $mtime, mime_type => $mime_type, }); } sub serve_pod { my ($self, $path) = @_; $path =~ s[::][/]g; # just in case, if called as /perldoc/Foo::Bar # if several sources, will be first *.pod, then *.pm my @sources = $self->find_source($path) or die "No file for '$path'"; my $mtime = max map {(stat $_)[9]} @sources; my $content = $path =~ /\bperltoc\b/ ? $self->fake_perltoc : $self->slurp_file($sources[0], ":crlf"); my $version = @sources > 1 ? $self->parse_version($self->slurp_file($sources[-1], ":crlf")) : $self->parse_version($content); for my $filter (@podfilters) { $filter->($content); } # special handling for perlfunc: change initial C<..> to hyperlinks if ($path =~ /\bperlfunc$/) { my $sub = sub {my $txt = shift; $txt =~ s[C<(.*?)>][C>]g; $txt}; $content =~ s[(Perl Functions by Category)(.*?)(Alphabetical Listing)] [$1 . $sub->($2) . $3]es; } my $parser = Pod::POM->new; my $pom = $parser->parse_text($content) or die $parser->error; (my $mod_name = $path) =~ s[/][::]g; my $view = $self->mk_view(version => $version, mtime => $mtime, path => $path, mod_name => $mod_name, syntax_coloring => $coloring_package); my $html = $view->print($pom); # again special handling for perlfunc : ids should be just function names if ($path =~ /\bperlfunc$/) { $html =~ s/li id="(.*?)_.*?"/li id="$1"/g; } # special handling for 'perl' : hyperlinks to man pages if ($path =~ /\bperl$/) { my $sub = sub {my $txt = shift; $txt =~ s[(perl\w+)] [$1]g; return $txt}; $html =~ s[()][$sub->($1)]egs; } return $self->send_html($html, $mtime); } sub fake_perltoc { my ($self) = @_; return "=head1 NAME\n\nperltoc\n\n=head1 DESCRIPTION\n\n" . "I"; } sub serve_script { my ($self, $path) = @_; my $fullpath; DIR: foreach my $dir (@script_dirs) { foreach my $ext ("", ".pl", ".bat") { $fullpath = "$dir/$path$ext"; last DIR if -f $fullpath; } } $fullpath or die "no such script : $path"; my $content = $self->slurp_file($fullpath, ":crlf"); my $mtime = (stat $fullpath)[9]; for my $filter (@podfilters) { $filter->($content); } my $parser = Pod::POM->new; my $pom = $parser->parse_text($content) or die $parser->error; my $view = $self->mk_view(path => "scripts/$path", mtime => $mtime, syntax_coloring => $coloring_package); my $html = $view->print($pom); return $self->send_html($html, $mtime); } sub find_source { my ($self, $path) = @_; # serving a script ? # TODO : factorize common code with serve_script if ($path =~ s[^scripts/][]) { DIR: foreach my $dir (@script_dirs) { foreach my $ext ("", ".pl", ".bat") { -f "$dir/$path$ext" or next; return ("$dir/$path$ext"); } } return; } # otherwise, serving a module foreach my $prefix (@search_dirs) { my @found = grep {-f} ("$prefix/$path.pod", "$prefix/$path.pm", "$prefix/pod/$path.pod", "$prefix/pods/$path.pod"); return @found if @found; } return; } sub pod2pom { my ($self, $sourcefile) = @_; my $content = $self->slurp_file($sourcefile, ":crlf"); for my $filter (@podfilters) { $filter->($content); } my $parser = Pod::POM->new; my $pom = $parser->parse_text($content) or die $parser->error; return $pom; } #---------------------------------------------------------------------- # 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') { # Pod/perl* should not appear under Pod delete $entries->{$_} for grep /^perl/, keys %$entries; } return $self->send_html($self->htmlize_entries($entries)); } sub toc_perldocs { my ($self) = @_; my %perldocs; # perl basic docs may be found under "pod", "pods", or 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->send_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->send_html($self->htmlize_entries($entries)); } sub toc_scripts { my ($self) = @_; my %scripts; # gather all scripts and group them by initial letter foreach my $dir (@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->send_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 (@search_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]} @search_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 ($perlpod) = $self->find_source("perl", ":crlf") or die "'perl.pod' does not seem to be installed on this system"; my $source = $self->slurp_file($perlpod); my $perlpom = $parser->parse_text($source) or die $parser->error; 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*?)\s*\t(.+)/gm) { my ($ref, $descr) = ($1, $2); my $entry = delete $perldocs->{$ref} or next; push @leaves, {label => $ref, href => $entry->{node}, attrs => qq{id='$ref' title='$descr'}}; } # 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 = ""; 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{abstract} = $self->get_abstract($entry->{node}); } $html .= generic_node(%args); } return $html; } sub get_abstract { # override in indexer } sub main_toc { my ($self) = @_; # initial page to open my $ini = $self->{params}{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) . "]"; my $js_no_indexer = $no_indexer ? 'true' : 'false'; my @perl_sections = map {closed_node( label => ucfirst($_), label_class => "TN_label small_title", attrs => qq{TN:contentURL='toc/$_' id='$_'}, )} qw/perldocs pragmas scripts/; 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); return $self->send_html(<<__EOHTML__);
Perl Documentation
Search in
 for 

Browse
@perl_sections $modules
__EOHTML__ } #---------------------------------------------------------------------- # searching #---------------------------------------------------------------------- sub dispatch_search { my ($self) = @_; my $params = $self->{params}; my $source = $params->{source}; my $method = {perlfunc => 'perlfunc', perlvar => 'perlvar', perlfaq => 'perlfaq', modules => 'serve_pod', fulltext => 'fulltext', modlist => 'modlist', }->{$source} or die "cannot search in '$source'"; if ($method =~ /fulltext|modlist/ and $no_indexer) { die "

this method requires Search::Indexer

" . "

please ask your system administrator to install it

" . "(error message : $no_indexer)"; } return $self->$method($params->{search}); } my @_perlfunc_items; # simple-minded cache sub perlfunc_items { my ($self) = @_; unless (@_perlfunc_items) { my ($funcpod) = $self->find_source("perlfunc") or die "'perlfunc.pod' does not seem to be installed on this system"; my $funcpom = $self->pod2pom($funcpod); my ($description) = grep {$_->title eq 'DESCRIPTION'} $funcpom->head1; my ($alphalist) = grep {$_->title =~ /^Alphabetical Listing/i} $description->head2; @_perlfunc_items = $alphalist->over->[0]->item; }; return @_perlfunc_items; } sub perlfunc { my ($self, $func) = @_; my @items = grep {$_->title =~ /^$func\b/} $self->perlfunc_items or return $self->send_html("No documentation found for perl " ."function '$func'"); my $view = $self->mk_view(path => "perlfunc/$func"); my @li_items = map {$_->present($view)} @items; return $self->send_html(<<__EOHTML__);

Extract from perlfunc

    @li_items
__EOHTML__ } my @_perlvar_items; # simple-minded cache sub perlvar_items { my ($self) = @_; unless (@_perlvar_items) { # get items defining variables my ($varpod) = $self->find_source("perlvar") or die "'perlvar.pod' does not seem to be installed on this system"; my $varpom = $self->pod2pom($varpod); my @items = _extract_items($varpom); # group items having common content my $tmp = []; foreach my $item (@items) { push @$tmp, $item; if ($item->content . "") { # force stringification push @_perlvar_items, $tmp; $tmp = []; } } }; return @_perlvar_items; } sub perlvar { my ($self, $var) = @_; my @items = grep {any {$_->title =~ /^\Q$var\E(\s|$)/} @$_} $self->perlvar_items or return $self->send_html("No documentation found for perl " ."variable '$var'"); my $view = $self->mk_view(path => "perlvar/$var"); my @li_items = map {$_->present($view)} map {@$_} @items; return $self->send_html(<<__EOHTML__);

Extract from perlvar

    @li_items
__EOHTML__ } sub 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"); FAQ: for my $num (1..9) { my $faq = "perlfaq$num"; my ($faqpod) = $self->find_source($faq) or die "'$faq.pod' does not seem to be installed on this system"; my $faqpom = $self->pod2pom($faqpod); my @questions = map {grep {$_->title =~ $regex} $_->head2} $faqpom->head1 or next FAQ; my @nodes = map {$view->print($_)} @questions; $answers .= generic_node(label => "Found in perlfaq$num", label_tag => "h2", content => join("", @nodes)); $n_answers += @nodes; } return $self->send_html(<<__EOHTML__);

Extracts from perlfaq


searching for '$faq_entry' : $n_answers answers

$answers
__EOHTML__ } #---------------------------------------------------------------------- # miscellaneous #---------------------------------------------------------------------- sub mk_view { my ($self, %args) = @_; my $view = Pod::POM::View::HTML::_PerlDoc->new( root_url => $self->{root_url}, %args ); return $view; } sub send_html { my ($self, $html, $mtime) = @_; # dirty hack for MSIE8 (TODO: send proper HTTP header instead) $html =~ s[] [\n]; $self->send_content({content => $html, code => 200, mtime => $mtime}); } sub send_content { my ($self, $args) = @_; my $encoding = guess_encoding($args->{content}, qw/ascii utf8 latin1/); my $charset = ref $encoding ? $encoding->name : ""; $charset =~ s/^ascii/US-ascii/; # Firefox insists on that imperialist name my $length = length $args->{content}; my $mime_type = $args->{mime_type} || "text/html"; $mime_type .= "; charset=$charset" if $charset and $mime_type =~ /html/; my $modified = gmtime $args->{mtime}; my $code = $args->{code} || 200; my $r = $self->{response}; for (ref $r) { /^Apache/ and do { require Apache2::Response; $r->content_type($mime_type); $r->set_content_length($length); $r->set_last_modified($args->{mtime}) if $args->{mtime}; $r->print($args->{content}); return; }; /^HTTP::Response/ and do { $r->code($code); $r->header(Content_type => $mime_type, Content_length => $length); $r->header(Last_modified => $modified) if $args->{mtime}; $r->add_content($args->{content}); return; }; # otherwise (cgi-bin) my $headers = "Content-type: $mime_type\nContent-length: $length\n"; $headers .= "Last-modified: $modified\n" if $args->{mtime}; binmode(STDOUT); print "$headers\n$args->{content}"; return; } } #---------------------------------------------------------------------- # generating GvaScript treeNavigator structure #---------------------------------------------------------------------- sub generic_node { my %args = @_; $args{class} ||= "TN_node"; $args{attrs} &&= " $args{attrs}"; $args{content} ||= ""; $args{content} &&= qq{
$args{content}
}; 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{abstract}) { $args{abstract} =~ s/([&<>"])/$escape_entity{$1}/g; $label_attrs .= qq{ title="$args{abstract}"}; } return qq{
} . qq{<$args{label_tag} class="$args{label_class}"$label_attrs>} . $args{label} . qq{} . $args{content} . qq{
}; } sub closed_node { return generic_node(@_, class => "TN_node TN_closed"); } sub leaf { return generic_node(@_, class => "TN_leaf"); } #---------------------------------------------------------------------- # utilities #---------------------------------------------------------------------- sub slurp_file { my ($self, $file, $io_layer) = @_; open my $fh, $file or die "open $file: $!"; binmode($fh, $io_layer) if $io_layer; local $/ = undef; return <$fh>; } # parse_version: code copied and adapted from Module::Build::ModuleInfo, # but working on in-memory string instead of opening the file my $VARNAME_REGEXP = qr/ # match fully-qualified VERSION name ([\$*]) # sigil - $ or * ( ( # optional leading package name (?:::|\')? # possibly starting like just :: (ala $::VERSION) (?:\w+(?:::|\'))* # Foo::Bar:: ... )? VERSION )\b /x; my $VERS_REGEXP = qr/ # match a VERSION definition (?: \(\s*$VARNAME_REGEXP\s*\) # with parens | $VARNAME_REGEXP # without parens ) \s* =[^=~] # = but not ==, nor =~ /x; sub parse_version { # my ($self, $content) = @_ # don't copy $content for efficiency, use $_[1] my $result; my $in_pod = 0; while ($_[1] =~ /^.*$/mg) { # $_[1] is $content my $line = $&; chomp $line; next if $line =~ /^\s*#/; $in_pod = $line =~ /^=(?!cut)/ ? 1 : $line =~ /^=cut/ ? 0 : $in_pod; # Would be nice if we could also check $in_string or something too last if !$in_pod && $line =~ /^__(?:DATA|END)__$/; next unless $line =~ $VERS_REGEXP; my( $sigil, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); $line =~ s/\bour\b//; my $eval = qq{q# Hide from _packages_inside() #; package Pod::POM::Web::_version; no strict; local $sigil$var; \$$var=undef; do { $line }; \$$var }; no warnings; $result = eval($eval) || ""; } return $result; } sub _extract_items { # recursively grab all nodes of type 'item' my $node = shift; for ($node->type) { /^item/ and return ($node); /^(pod|head|over)/ and return map {_extract_items($_)} $node->content; } return (); } 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/; # 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; } return $text; } # SUPER::view_seq_link needs some adaptations sub view_seq_link { my ($self, $link) = @_; # we handle the L 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[^(.*)]); # 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{$label}; } sub view_seq_link_transform_path { my($self, $page) = @_; $page =~ s[::][/]g; return "$self->{root_url}/$page"; } sub view_item { my ($self, $item) = @_; my $title = eval {$item->title->present($self)} || ""; $title = "" if $title =~ /^\s*\*\s*$/; my $class = ""; my $id = ""; if ($title =~ /^AnnoCPAN/) { $class = " class='AnnoCPAN'"; } else { $id = _title_to_id($title); $id &&= qq{ id="$id"}; } my $content = $item->content->present($self); $title = qq{$title} if $title; return qq{$title\n$content\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 $self->{path}
\n" . "Source"; # 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, $cpan_info, $module_refs) = ("") x 6; 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"; # hyperlinks to various internet resources $module_refs = qq{
meta::cpan | Anno }; if ($has_cpan) { my $mod = CPAN::Shell->expand("Module", $mod_name); if ($mod) { my $cpan_version = $mod->cpan_version; $cpan_info = "; CPAN has v. $cpan_version" if $cpan_version ne $self->{version}; } } } my $toc = $self->make_toc($pom, 0); return <<__EOHTML__ $name

$name

(${version}installed $installed$core_release$cpan_info) $description Source $module_refs

Table of contents

$toc

$content
__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 < $title
$content
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 =~ s/([&<>"])/$Pod::POM::Web::escape_entity{$1}/g; } # hyperlinks to other modules $text =~ s{(\buse\b(?:)?\ +(?:)?)([\w:]+)} {my $url = $self->view_seq_link_transform_path($2); qq{$1$2} }eg; if ($self->{line_numbering}) { my $line = 1; $text =~ s/^/sprintf "%6d\t", $line++/egm; } return qq{
$text
}; } sub PPI_coloring { my ($self, $text) = @_; my $ppi = PPI::HTML->new(); my $html = $ppi->html(\$text); if ($html) { $html =~ s/
//g; return $html; } else { # PPI failed to parse that text $text =~ s/([&<>"])/$Pod::POM::Web::escape_entity{$1}/g; return $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{
$node_content
}; $html .= qq{
} . qq{$title} . $node_content . qq{
}; } return $html; } sub DESTROY {} # avoid AUTOLOAD 1; __END__ =encoding ISO8859-1 =head1 NAME Pod::POM::Web - HTML Perldoc server =head1 DESCRIPTION L 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) =item * direct access to L entries (builtin Perl functions) =item * search through L headers =item * fulltext search, including names of Perl variables (this is an optional feature -- see section L). =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 CPAN sites =back The application may be hosted by an existing Web server, or otherwise may run its own builtin Web server. The DHTML code for navigating through documentation trees requires a modern browser. So far it has been tested on Microsoft Internet Explorer 8.0, Firefox 3.5, Google Chrome 3.0 and Safari 4.0.4. =head1 USAGE Usage is described in a separate document L. =head1 INSTALLATION =head2 Starting the Web application Once the code is installed (most probably through L or L), you have to configure the web server : =head3 As a mod_perl service If you have Apache2 with mod_perl 2.0, then edit your F as follows : PerlModule Apache2::RequestRec PerlModule Apache2::RequestIO SetHandler modperl PerlResponseHandler Pod::POM::Web->handler Then navigate to URL L. =head3 As a cgi-bin script Alternatively, you can run this application as a cgi-script by writing a simple file F in your C directory, containing : #!/path/to/perl use Pod::POM::Web; Pod::POM::Web->handler; Make this script executable, then navigate to URL L. The same can be done for running under mod_perl Registry (write the same script as above and put it in your Apache/perl directory). However, this does not make much sense, because if you have mod_perl Registry then you could as well run it as a basic mod_perl handler. =head3 As a standalone server A third 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. A different port may be specified, in several ways : perl -MPod::POM::Web -e server 8888 perl -MPod::POM::Web -e server(8888) perl -MPod::POM::Web -e server -- --port 8888 =head2 Opening a specific initial page By default, the initial page displayed by the application is F. This can be changed by supplying an C argument with the name of 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 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 access to any file installed under your C<@INC> path or Apache C directory (but not outside of those directories); so it is probably a B 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 will take advantage of the L module which is already installed on your system. Otherwise, you need to install L, available from CPAN. =head3 Fulltext indexing C can index the documentation and source code of all your installed modules, including Perl variable names, C, etc. To use this feature you need to =over =item * install L from CPAN =item * build the index as described in L documentation. =back =head3 AnnoCPAN comments The website L lets people add comments to the documentation of CPAN modules. The AnnoCPAN database is freely downloadable and can be easily integrated with locally installed modules via runtime filtering. If you want AnnoCPAN comments to show up in Pod::POM::Web, do the following: =over =item * install L from CPAN; =item * download the database from L and save it as F<$HOME/.annopod.db> (see the documentation in the above module for more details). You may also like to try L which is a crontab-friendly tool for periodically downloading the AnnoCPAN database. =back =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 or =for html Here it is assumed that auxiliary files C or C are in the same directory than the POD source; but of course relative or absolute links can be used. =head1 METHODS =head2 handler Pod::POM::Web->handler($request, $response, $options); Public entry point for serving a request. Objects C<$request> and C<$response> are specific to the hosting HTTP server (modperl, HTTP::Daemon or cgi-bin); C<$options> is a hashref that currently contains only one possible entry : C, for specifying the HTML title of the application (useful if you run several concurrent instances of Pod::POM::Web). =head2 server Pod::POM::Web->server($port, $options); Starts the event loop for the builtin HTTP server. The C<$port> number can be given as optional first argument (default is 8080). The second argument C<$options> may be used to specify a page title (see L method above). This function is exported into the C namespace if perl is called with the C<-e> flag, so that you can write perl -MPod::POM::Web -e server Options and port may be specified on the command line : perl -MPod::POM::Web -e server -- --port 8888 --title FooBar =head1 ACKNOWLEDGEMENTS This web application was deeply inspired by : =over =item * the structure of HTML Perl documentation released with ActivePerl (L). =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. =item * the wide possibilities of Andy Wardley's L parser. =back Thanks to Philippe Bruhat who mentioned a weakness in the API, to Chris Dolan who supplied many useful suggestions and patches (esp. integration with AnnoCPAN), 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, and to Olivier 'dolmen' Mengué who suggested to export "server" into C. =head1 RELEASE NOTES Indexed information since version 1.04 is not compatible with previous versions. So if you upgraded from a previous version and want to use the index, you need to rebuild it entirely, by running the command : perl -MPod::POM::Web::Indexer -e "index(-from_scratch => 1)" =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 AUTHOR Laurent Dami, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2007-2014 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. =head1 TODO - real tests ! - factorization (esp. initial in html pages) - use Getopts to choose colouring package, toggle CPAN, etc. - declare Pod::POM bugs - perlre : line 1693 improper parsing of Lpattern) >>> - bug: doc files taken as pragmas (lwptut, lwpcook, pip, pler) - exploit doc index X<...> - do something with perllocal (installation history) - restrict to given set of paths/ modules - ned to change toc (no perlfunc, no scripts/pragmas, etc) - treenav with letter entries or not ? - port to Plack