Created
October 5, 2010 23:29
-
-
Save kits/612535 to your computer and use it in GitHub Desktop.
POD Viewer
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/usr/bin/env perl | |
### PodV start ### | |
package PodV; | |
use strict; | |
use warnings; | |
no warnings 'redefine'; | |
use Encode qw(decode FB_HTMLCREF); | |
use Pod::Perldoc; | |
use Pod::Html (); | |
use ExtUtils::Installed; | |
use Storable qw(store retrieve); | |
use Carp qw(croak); | |
use File::Spec; | |
use Digest::MD5 qw(md5_hex); | |
my $PERLDOC = Pod::Perldoc->new; | |
my $PERLFUNC_PATH = path('perlfunc'); | |
my $PERLVAR_PATH = path('perlvar'); | |
#my $PERLLOCAL_PATH = path('perllocal'); | |
my $TMPDIR = File::Spec->tmpdir; | |
my $INSTALLED; | |
my $LINK_PREFIX = './pod='; | |
my $INSTALLED_STORE = 'inst-' . md5_hex($^X) . '.stor'; | |
$INSTALLED_STORE = File::Spec->catfile($TMPDIR, $INSTALLED_STORE); | |
my $INC_RE = join '|', map { quotemeta File::Spec->canonpath($_) } @INC; | |
$INC_RE .= ($INC_RE) ? '|' : ''; | |
$INC_RE .= q{.+\bbin}; | |
$INC_RE = qr{^(?:$INC_RE)\b}; | |
_load_installed(); | |
# redefine &Pod::Html::page_sect | |
{ | |
my $page_sect = sub ($$) { | |
my ($page, $section) = @_; | |
return if $page =~ /[()]/; | |
my $link = ''; | |
$page and $link = "$LINK_PREFIX$page"; | |
$section and $link .= "#" . Pod::Html::anchorify($section); | |
return $link; | |
}; | |
no warnings 'redefine'; | |
*Pod::Html::page_sect = $page_sect; | |
} | |
# redefine &Pod::Html::anchorify | |
{ | |
my $anchorify = sub { | |
my ($anchor) = @_; | |
$anchor = Pod::Html::htmlify($anchor); | |
$anchor =~ s/([\x80-\xff])/sprintf '.%02X', ord($1)/ge; | |
$anchor =~ s/[^0-9A-Za-z_:.-]+/_/g; | |
return $anchor; | |
}; | |
no warnings 'redefine'; | |
*Pod::Html::anchorify = $anchorify; | |
} | |
# method | |
sub path { | |
my $module = (@_ == 2) ? $_[1] : $_[0]; | |
# for case-insensitive filesystem (like cygwin) | |
my $podpath = $PERLDOC->searchfor(0, $module, @INC); | |
my $cmdpath = $PERLDOC->searchfor(0, $module, $PERLDOC->{bindir}); | |
if ($podpath && $cmdpath) { | |
return ($module =~ /^[A-Z]/) ? $podpath : $cmdpath; | |
} | |
return $podpath || $cmdpath; | |
} | |
sub pod_to_html { | |
my ($self, $module) = @_; | |
my $path = path($module); | |
defined $path or return; | |
_x_to_html($path); | |
} | |
sub func_to_html { | |
my ($self, $func) = @_; | |
defined $func or return; | |
$PERLDOC->opt_f($func); | |
my @pod; | |
eval { $PERLDOC->search_perlfunc([ $PERLFUNC_PATH ], \@pod) }; | |
return if $@; | |
my $enc = _pod_encoding( $PERLFUNC_PATH ); | |
my $pod = ''; | |
$pod .= "=encoding $enc\n\n" if defined $enc; | |
$pod .= join '', @pod; | |
local *IN; | |
open IN, '<', \$pod or croak "cannot open IN : $!"; | |
my $html = _x_to_html('&=PodV::IN'); | |
close IN; | |
return $html; | |
} | |
sub var_to_html { | |
my ($self, $var) = @_; | |
defined $var or return; | |
# fix variable name | |
$var = '$PROGRAM_NAME' if $var eq '$0'; | |
$var = '$<I<digits>>' if $var eq '$<digits>'; | |
$PERLDOC->opt_v($var); | |
my @pod; | |
eval { $PERLDOC->search_perlvar([ $PERLVAR_PATH ], \@pod) }; | |
return if $@; | |
my $enc = _pod_encoding( $PERLFUNC_PATH ); | |
my $pod = ''; | |
$pod .= "=encoding $enc\n\n" if defined $enc; | |
$pod .= join '', @pod; | |
local *IN; | |
open IN, '<', \$pod or croak "cannot open IN : $!"; | |
my $html = _x_to_html('&=PodV::IN'); | |
close IN; | |
return $html; | |
} | |
sub _x_to_html { | |
my $arg = shift; | |
# $arg | |
# - file path : '/path/to/module.pm' | |
# - file handle : '&=PodV::IN' | |
defined $arg or return; | |
my $html; | |
local *OUT; | |
open OUT, '>', \$html or croak "cannot open OUT : $!"; | |
Pod::Html::pod2html( | |
'--infile=' . $arg, | |
'--outfile=&=PodV::OUT', | |
'--cachedir=' . File::Spec->tmpdir, | |
'--quiet', | |
); | |
close OUT; | |
my $enc = _pod_encoding($arg); | |
defined $enc and $html = decode $enc, $html, FB_HTMLCREF; | |
$html =~ s{^.+<body[^>]*>\s*}{}s; | |
$html =~ s{</body>\s*</html>\s*$}{}; | |
$html =~ s{^<p>\n</p>}{}mg; | |
if ( $arg =~ m{\bperl\.pod$} ) { | |
$html =~ s{^(\s+)(perl[0-9a-z]*)}{$1<a href="$LINK_PREFIX$2">$2</a>}mg; | |
} | |
$html =~ s{>([^>]+) in the ([0-9A-Za-z_:()-]+) manpage</a>}{>"$1" in $2</a>}g; | |
$html =~ s{>the ([0-9A-Za-z_:()-]+) manpage</a>}{>$1</a>}g; | |
$html =~ s{</pre>\n<pre>}{\n}g; | |
_trim_pre_indent(\$html); | |
return $html; | |
} | |
sub _pod_encoding { | |
my $arg = shift; | |
my $fh; | |
if ($arg =~ /^&=/) { | |
open $fh, "<$arg" or croak "cannot open $arg : $!"; | |
} | |
else { | |
open $fh, '<', $arg or croak "cannot open $arg : $!"; | |
} | |
my $encoding; | |
while (my $line = <$fh>) { | |
next if $line !~ /^=encoding\s*([0-9A-Za-z_-]+)/; | |
close $fh; | |
return $1; | |
} | |
close $fh; | |
return; | |
} | |
sub _trim_pre_indent { | |
my $html_ref = shift; | |
$$html_ref =~ s{^(<pre>.*?</pre>)$}{_trim_pre_indent2($1)}msge; | |
} | |
sub _trim_pre_indent2 { | |
my $pre = shift; | |
my @indents = ($pre =~ m{^(\s+)}mg); | |
my $indent = shift @indents; | |
for my $idt (@indents) { | |
if (length $idt < length $indent) { | |
$indent = $idt; | |
} | |
} | |
$pre =~ s{^$indent}{}mg; | |
return $pre; | |
} | |
sub pod_source { | |
my ($self, $pod) = @_; | |
my $path = path($pod); | |
defined $path or return; | |
return Mojo::Asset::File->new(path => $path)->slurp; | |
} | |
sub _load_installed { | |
eval { $INSTALLED = retrieve $INSTALLED_STORE }; | |
if ($@) { | |
new_installed(); | |
} | |
} | |
#sub _check_installed { | |
# if (!-f $INSTALLED_STORE) { | |
# _new_installed(); | |
# return; | |
# } | |
# my $inst_mod = (stat $INSTALLED_STORE)[9]; | |
# my $perllocal_mod = (stat $PERLLOCAL_PATH)[9]; | |
# if ($inst_mod < $perllocal_mod) { | |
# _new_installed(); | |
# } | |
#} | |
sub new_installed { | |
local @INC = grep { File::Spec->file_name_is_absolute($_) } @INC; | |
$INSTALLED = ExtUtils::Installed->new; | |
store $INSTALLED, $INSTALLED_STORE; | |
chmod 0666, $INSTALLED_STORE; | |
} | |
sub all_funcs { | |
my %funcs; | |
open my $fh, '<', $PERLFUNC_PATH or croak "cannot open perlfunc : $!"; | |
while (my $line = <$fh>) { | |
next if 1 .. $line =~ /^=.+by Category/; | |
last if $line =~ /^=.+Portability/; | |
for my $func ($line =~ m{C<([^<>"]+)>}g) { | |
$funcs{$func}++; | |
} | |
} | |
delete @funcs{qw(given when default)}; | |
$funcs{-X}++; | |
return sort keys %funcs; | |
} | |
sub all_vars { | |
my @vars; | |
open my $fh, '<', $PERLVAR_PATH or croak "cannot open perlvar : $!"; | |
while (my $line = <$fh>) { | |
if ( $line =~ /^=item ((?:[\$\@\%]|ARG).+)/ ) { | |
my $var = $1; | |
$var = '$<digits>' if $var =~ /digits/; | |
push @vars, $var; | |
} | |
} | |
close $fh; | |
return sort @vars; | |
} | |
sub all_dists { | |
return sort {lc $a cmp lc $b} $INSTALLED->modules; | |
} | |
sub pods_in_dist { | |
my ($self, $dist) = @_; | |
my @files; | |
eval { @files = $INSTALLED->files($dist) }; | |
return if $@; | |
$_ = File::Spec->canonpath($_) for @files; | |
my @ret; | |
for my $file ( @files ) { | |
next if $file =~ m{/(?:man|auto)/}; | |
next if $dist eq 'Perl' && $file =~ m{(?:\.h$|/unicore/)}; | |
next if !-f $file; | |
next if $file !~ m{\.pod$} && !$PERLDOC->containspod($file); | |
$file =~ s{$INC_RE}{} or next; | |
my @path = File::Spec->splitdir($file); | |
shift @path; | |
$path[0] =~ m{^pods?$} and shift @path; | |
$file = join '::', @path; | |
$file =~ s{\.(?:pm|pod|bat)$}{}; | |
push @ret, $file; | |
} | |
return sort @ret; | |
} | |
sub can_search_var { | |
$PERLDOC->can('search_perlvar'); | |
} | |
1; | |
### PodV end ### | |
package main; | |
use Mojolicious::Lite; | |
#use PodV; | |
use lib qw(pod mypod); | |
get '/' | |
=> 'root'; | |
get '/functions' | |
=> 'functions'; | |
get '/variables' | |
=> 'variables'; | |
get '/pod=:pod' | |
=> [pod => qr{[0-9A-Za-z.:_-]+}] | |
=> sub { | |
my $self = shift; | |
my $pod = $self->param('pod'); | |
my $html = PodV->pod_to_html($pod); | |
defined $html or $self->render_not_found; | |
$self->stash(html => $html); | |
} | |
=> 'pod'; | |
get '/source=:pod' | |
=> [pod => qr{[0-9A-Za-z.:_-]+}] | |
=> sub { | |
my $self = shift; | |
my $pod = $self->param('pod'); | |
my $source = PodV->pod_source($pod); | |
defined $source or $self->render_not_found; | |
$self->render(data => $source, format => 'txt'); | |
}; | |
get '/func=:func' | |
=> [func => qr{-X|[a-z2]+}] | |
=> sub { | |
my $self = shift; | |
my $func = $self->param('func'); | |
my $html = PodV->func_to_html($func); | |
defined $html or $self->render_not_found; | |
$self->stash(html => $html); | |
} | |
=> 'func'; | |
get '/dist=:dist' | |
=> [dist => qr{[0-9A-Za-z.:_-]+}] | |
=> sub { | |
my $self = shift; | |
my $dist = $self->param('dist'); | |
my @pods = PodV->pods_in_dist($dist); | |
@pods or $self->render_not_found; | |
$self->stash(pods => \@pods); | |
} | |
=> 'dist'; | |
if (PodV->can_search_var) { | |
get '/var=(.var)' | |
=> [var => qr{[!-~]+}] | |
=> sub { | |
my $self = shift; | |
# /var=$/ (not escaped) is invalid. | |
if ( $self->req->url->to_string =~ m{^/.*/}) { | |
$self->render_not_found; | |
} | |
my $var = $self->param('var'); | |
my $html = PodV->var_to_html($var); | |
defined $html or $self->render_not_found; | |
$self->stash(html => $html); | |
} | |
=> 'var'; | |
} | |
post '/refresh' | |
=> sub { | |
my $self = shift; | |
PodV->new_installed; | |
$self->redirect_to('root'); | |
}; | |
app->secret('test'); | |
app->start | |
__DATA__ | |
@@ root.html.ep | |
% layout 'default', title => 'POD Viewer'; | |
<h2>Perl Manual</h2> | |
<ul> | |
<li><%= link_to 'perl' => './pod=perl' %> (overview)</li> | |
<li> | |
<%= link_to 'functions' => 'functions' %> | |
(all: <%= link_to 'perlfunc' => './pod=perlfunc' %>) | |
</li> | |
% if (PodV->can_search_var) { | |
<li> | |
<%= link_to 'variables' => 'variables' %> | |
(all: <%= link_to 'perlvar' => './pod=perlvar' %>) | |
</li> | |
% } | |
% else { | |
<li> | |
variables: <%= link_to 'perlvar' => './pod=perlvar' %> (all) | |
</li> | |
% } | |
</ul> | |
<h2>Installed Distributions</h2> | |
<p>Core modules' documents are in <%= link_to 'Perl' => "./dist=Perl" %>.</p> | |
<ul> | |
% for my $dist ( PodV->all_dists ) { | |
<li><%= link_to $dist => "./dist=$dist" %></a></li> | |
% } | |
</ul> | |
<%= form_for 'refresh' => (method => 'post') => begin%> | |
<%= submit_button 'refresh distributions data' %> | |
<% end %> | |
@@ functions.html.ep | |
% layout 'default', title => 'Functions'; | |
% content_for nav => begin | |
<%= link_to 'top page' => 'root' %> | |
% end | |
<ul id="functions"> | |
% for my $func ( PodV->all_funcs ) { | |
<li><%= link_to $func => "./func=$func" %></li> | |
% } | |
</ul> | |
@@ variables.html.ep | |
% layout 'default', title => 'Variables'; | |
% content_for nav => begin | |
<%= link_to 'top page' => 'root' %> | |
% end | |
<ul id="variables"> | |
% for my $var ( PodV->all_vars ) { | |
% my $url = url_for; | |
% $url->path->parts([ "var=$var" ]); | |
<li><a href="<%= $url %>"><%= $var %></a></li> | |
% } | |
</ul> | |
@@ pod.html.ep | |
% layout 'default', title => $pod; | |
% content_for nav => begin | |
<%= link_to 'top page' => 'root' %> | |
| <%= link_to 'source' => "./source=$pod" %> | |
% end | |
%== $html | |
@@ func.html.ep | |
% layout 'default', title => $func; | |
% content_for nav => begin | |
<%= link_to 'top page' => 'root' %> | |
| <%= link_to 'functions' => 'functions' %> | |
% end | |
%== $html | |
@@ var.html.ep | |
% layout 'default', title => $var; | |
% content_for nav => begin | |
<%= link_to 'top page' => 'root' %> | |
| <%= link_to 'variables' => 'variables' %> | |
% end | |
%== $html | |
@@ dist.html.ep | |
% layout 'default', title => qq{PODs in "$dist"}; | |
% content_for nav => begin | |
<%= link_to 'top page' => 'root' %> | |
% end | |
<ul> | |
% for my $pod (@$pods) { | |
<li><%= link_to $pod => "./pod=$pod" %></a></li> | |
% } | |
</ul> | |
@@ not_found.html.ep | |
<p>not found!</p> | |
@@ layouts/default.html.ep | |
<!DOCTYPE html> | |
<html> | |
<head> | |
<%= stylesheet 'cpan.css' %> | |
<title><%= $title %></title> | |
</head> | |
<body> | |
<div id="nav"> | |
<%= content_for 'nav' %> | |
</div> | |
<h1><%= $title %></h1> | |
<%= content %> | |
%# turn 0 to 1 if you want prettyprint. | |
% if (0) { | |
<%= javascript 'js/prettify.js' %> | |
<%= javascript begin %> | |
(function(){ | |
var pres = document.getElementsByTagName("pre"); | |
var i = pres.length; | |
while (i--) { | |
pres[i].className = 'prettyprint'; | |
} | |
prettyPrint(); | |
})(); | |
<% end %> | |
% } | |
</body> | |
</html> | |
@@ cpan.css | |
a:link { | |
background: transparent; | |
color: #069; | |
} | |
a:visited { | |
background: transparent; | |
color: #037; | |
} | |
body { | |
color: #000; | |
font-family: Arial, sans-serif; | |
margin: 0 32px; | |
padding: 0 0 100px; | |
} | |
img { | |
border: 0; | |
vertical-align: top; | |
} | |
div { | |
border-width: 0; | |
} | |
dt { | |
margin-top: 1em; | |
} | |
pre { | |
background: #eee; | |
border: 1px solid #888; | |
color: black; | |
padding: 1em; | |
white-space: pre; | |
} | |
/*pre + pre { | |
margin-top:-2em; | |
border-top:none; | |
}*/ | |
h1, h2, h3, h4 { | |
background: transparent; | |
color: #069; | |
} | |
h1 { | |
font-size: large; | |
} | |
h2 { | |
font-size: medium; | |
} | |
h3 { | |
font-size: medium; | |
font-style: italic; | |
} | |
h4 { | |
font-size: medium; | |
font-weight: normal; | |
} | |
hr { | |
border-width: 1px 0 0; | |
border-style: solid; | |
border-color: #ccc; | |
} | |
#nav { | |
margin-top: 0; | |
float: right; | |
text-align: right; | |
} | |
span.str { color: #080; } | |
span.kwd { color: #008; } | |
span.com { color: #800; } | |
span.typ { color: #606; } | |
span.lit { color: #066; } | |
span.pun { color: #660; } | |
span.pln { color: #000; } | |
span.tag { color: #008; } | |
span.atn { color: #606; } | |
span.atv { color: #080; } | |
span.dec { color: #606; } |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
*todo | |
- 考え中。 | |
*changes | |
** 2011-02-24 | |
- 連続するpre要素を1つにまとめた。(pre要素の行頭の空白の削除が正しく行われるようになった) | |
** 2011-02-02 | |
- Installedデータの更新を手動にした。 | |
- prettify.js を使ってみた。 | |
** 2011-01-28 | |
- Windows ActivePerl に対応(5.10.1で確認)。 | |
- Pod::Perldoc::search_perlvar() が使用できない場合の表示を変更。 | |
**2011-01-27 | |
- PodV::pods_in_dist で、.packlistにあるファイルが存在しなかった場合について対応。 | |
**2011-01-26 | |
- $INSTALLED_STORE ファイルをperl実行ファイルごとに変更するようにした。 | |
**2011-01-24 | |
- 変数の一覧・個別表示に対応。 | |
**2011-01-22 | |
- POD操作部分をパッケージに分離(PodV)。 | |
- パスを大幅に変更。 | |
- CGIでも動かせるようになった。 | |
**2011-01-14 | |
- pods_in_dist を修正(PODを含むファイルのみを出力) | |
- search_pod を修正(case insensitive なfilesystemに対応)。 | |
**2011-01-13 | |
- code block (pre) の先頭空白文字を削除するようにした。 | |
- ExtUtils::Installed をキャッシュするようにした。 | |
**2011-01-12 | |
- distribution ごとのインデックス(ExtUtils::Installedを使用) | |
- POD.html 用のテンプレートを作成。(Pod::Html デフォルトのheadを使わずに) | |
**2011-01-11 | |
- =encoding に対応 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment