package Pod::Site;
use strict;
use warnings;
use File::Spec;
use Carp;
use Pod::Simple '3.12';
use HTML::Entities;
use File::Path;
use Object::Tiny qw(
module_roots
doc_root
base_uri
index_file
css_path
favicon_uri
js_path
versioned_title
replace_css
replace_js
label
verbose
mod_files
bin_files
);
our $VERSION = '0.56';
sub go {
my $class = shift;
$class->new( $class->_config )->build;
}
sub new {
my ( $class, $params ) = @_;
my $self = bless {
index_file => 'index.html',
verbose => 0,
js_path => '',
css_path => '',
%{ $params || {} }
} => $class;
if (my @req = grep { !$self->{$_} } qw(doc_root base_uri module_roots)) {
my $pl = @req > 1 ? 's' : '';
my $last = pop @req;
my $disp = @req ? join(', ', @req) . (@req > 1 ? ',' : '')
. " and $last" : $last;
croak "Missing required parameters $disp";
}
my $roots = ref $self->{module_roots} eq 'ARRAY'
? $self->{module_roots}
: ( $self->{module_roots} = [$self->{module_roots}] );
for my $path (@{ $roots }) {
croak "The module root $path does not exist\n" unless -e $path;
}
$self->{base_uri} = [$self->{base_uri}] unless ref $self->{base_uri};
return $self;
}
sub build {
my $self = shift;
File::Path::mkpath($self->{doc_root}, 0, 0755);
$self->batch_html;
# The index file is the home page.
my $idx_file = File::Spec->catfile( $self->doc_root, $self->index_file );
open my $idx_fh, '>', $idx_file or die qq{Cannot open "$idx_file": $!\n};
# The TOC file has the table of contents for all modules and programs in
# the distribution.
my $toc_file = File::Spec->catfile( $self->{doc_root}, 'toc.html' );
open my $toc_fh, '>', $toc_file or die qq{Cannot open "$toc_file": $!\n};
# Set things up.
$self->{toc_fh} = $toc_fh;
$self->{seen} = {};
$self->{indent} = 1;
$self->{base_space} = ' ';
$self->{spacer} = ' ';
$self->{uri} = '';
# Make it so!
$self->sort_files;
$self->start_nav($idx_fh);
$self->start_toc($toc_fh);
$self->output($idx_fh, $self->mod_files);
$self->output_bin($idx_fh);
$self->finish_nav($idx_fh);
$self->finish_toc($toc_fh);
$self->copy_etc;
# Close up shop.
close $idx_fh or die qq{Could not close "$idx_file": $!\n};
close $toc_fh or die qq{Could not close "$toc_file": $!\n};
}
sub sort_files {
my $self = shift;
# Let's see what the search has found.
my $stuff = Pod::Site::Search->instance->name2path;
# Sort the modules from the scripts.
my (%mods, %bins);
while (my ($name, $path) = each %{ $stuff }) {
if ($name =~ /[.]p(?:m|od)$/) {
# Likely a module.
_set_mod(\%mods, $name, $stuff->{$name});
} elsif ($name =~ /[.](?:plx?|bat)$/) {
# Likely a script.
(my $script = $name) =~ s{::}{/}g;
$bins{$script} = $stuff->{$name};
} else {
# Look for a shebang line.
if (open my $fh, '<', $path) {
my $shebang = <$fh>;
close $fh;
if ($shebang && $shebang =~ /^#!.*\bperl/) {
# Likely a script.
(my $script = $name) =~ s{::}{/}g;
$bins{$script} = $stuff->{$name};
} else {
# Likely a module.
_set_mod(\%mods, $name, $stuff->{$name});
}
} else {
# Who knows? Default to module.
_set_mod(\%mods, $name, $stuff->{$name});
}
}
}
# Save our findings.
$self->{mod_files} = \%mods;
$self->{bin_files} = \%bins;
}
sub start_nav {
my ($self, $fh) = @_;
my $class = ref $self;
my $version = __PACKAGE__->VERSION;
my $title = encode_entities $self->title;
my $head = encode_entities $self->nav_header;
print STDERR "Starting site navigation file\n" if $self->verbose > 1;
my $base = join "\n ", map {
qq{}
} @{ $self->{base_uri} };
my $favicon = '';
if (my $uri = $self->{favicon_uri}) {
my $type = $uri;
$type =~ s/.*\.([^.]+)/$1/;
$favicon = qq();
}
print $fh _udent( <<" EOF" );
EOF
}
sub start_toc {
my ($self, $fh) = @_;
my $sample = encode_entities $self->sample_module;
my $version = Pod::Site->VERSION;
my $title = encode_entities $self->title;
print STDERR "Starting browser TOC file\n" if $self->verbose > 1;
print $fh _udent( <<" EOF");
$title
$title
Instructions
Select class names from the navigation tree to the left. The tree
shows a hierarchical list of modules and programs. In addition to
this URL, you can link directly to the page for a particular module
or program. For example, if you wanted to access
$sample, any of these links will work:
EOF
}
sub output {
my ($self, $fh, $tree) = @_;
for my $key (sort keys %{ $tree }) {
my $data = $tree->{$key};
(my $fn = $key) =~ s/\.[^.]+$//;
my $class = join ('::', split('/', $self->{uri}), $fn);
print STDERR "Reading $class\n" if $self->verbose > 1;
if (ref $data) {
# It's a directory tree. Output a class for it, first, if there
# is one.
my $item = $key;
if ($tree->{"$key.pm"}) {
my $path = $tree->{"$key.pm"};
if (my $desc = $self->get_desc($class, $path)) {
$item = qq{$key};
$self->_output_navlink($fh, $fn, $path, $class, 1, $desc);
}
$self->{seen}{$class} = 1;
}
# Now recursively descend the tree.
print STDERR "Outputting nav link\n" if $self->verbose > 2;
print $fh $self->{base_space}, $self->{spacer} x $self->{indent},
qq{
$item\n}, $self->{base_space},
$self->{spacer} x ++$self->{indent}, "
\n", $self->{base_space},
$self->{spacer} x --$self->{indent}, "
\n";
$self->{uri} =~ s|$key/$||;
} else {
# It's a class. Create a link to it.
$self->_output_navlink($fh, $fn, $data, $class)
unless $self->{seen}{$class};
}
}
}
sub output_bin {
my ($self, $fh) = @_;
my $files = $self->bin_files;
return unless %{ $files };
# Start the list in the tree browser.
print $fh $self->{base_space}, $self->{spacer} x $self->{indent},
qq{
bin\n}, $self->{base_space}, $self->{spacer} x ++$self->{indent}, "
\n";
++$self->{indent};
for my $pl (sort { lc $a cmp lc $b } keys %{ $files }) {
my $file = $files->{$pl};
$self->_output_navlink($fh, $pl, $file, $pl);
}
print $fh $self->{base_space}, $self->{spacer} x --$self->{indent}, "
\n",
$self->{base_space}, $self->{spacer} x --$self->{indent}, "
\n";
}
sub finish_nav {
my ($self, $fh) = @_;
print STDERR "Finishing browser navigation file\n" if $self->verbose > 1;
print $fh _udent( <<" EOF" );
EOF
}
sub finish_toc {
my ($self, $fh) = @_;
print STDERR "finishing browser TOC file\n" if $self->verbose > 1;
print $fh _udent( <<" EOF" );
EOF
}
sub batch_html {
my $self = shift;
require Pod::Simple::HTMLBatch;
print STDERR "Creating HTML with Pod::Simple::XHTML\n" if $self->verbose > 1;
my $batchconv = Pod::Simple::HTMLBatch->new;
$batchconv->index(1);
$batchconv->verbose($self->verbose);
$batchconv->contents_file( undef );
$batchconv->css_flurry(0);
$batchconv->javascript_flurry(0);
$batchconv->html_render_class('Pod::Site::XHTML');
$batchconv->search_class('Pod::Site::Search');
our $BASE_URI;
local $BASE_URI = $self->base_uri->[0];
$batchconv->batch_convert( $self->module_roots, $self->{doc_root} );
return 1;
}
sub copy_etc {
my $self = shift;
require File::Copy;
(my $from = __FILE__) =~ s/[.]pm$//;
for my $ext (qw(css js)) {
my $dest = File::Spec->catfile($self->{doc_root}, "podsite.$ext");
File::Copy::copy(
File::Spec->catfile( $from, "podsite.$ext" ),
$self->{doc_root}
) unless -e $dest && !$self->{"replace_$ext"};
}
}
sub get_desc {
my ($self, $what, $file) = @_;
open my $fh, '<', $file or die "Cannot open $file: $!\n";
my ($desc, $encoding);
local $_;
# Cribbed from Module::Build::PodParser.
while (not ($desc and $encoding) and $_ = <$fh>) {
next unless /^=(?!cut)/ .. /^=cut/; # in POD
($desc) = /^ (?: [a-z0-9:]+ \s+ - \s+ ) (.*\S) /ix unless $desc;
($encoding) = /^=encoding\s+(.*\S)/ unless $encoding;
}
Encode::from_to($desc, $encoding, 'UTF-8') if $desc && $encoding;
close $fh or die "Cannot close $file: $!\n";
print "$what has no POD or no description in a =head1 NAME section\n"
if $self->{verbose} && !$desc;
return $desc || '';
}
sub sample_module {
my $self = shift;
$self->{sample_module} ||= $self->main_module;
}
sub main_module {
my $self = shift;
$self->{main_module} ||= $self->_find_module;
}
sub name {
my $self = shift;
$self->{name} || $self->main_module;
}
sub title {
my $self = shift;
return $self->{title} ||= join ' ',
$self->name,
( $self->versioned_title ? $self->version : () ),
( $self->label ? $self->label : () );
}
sub nav_header {
my $self = shift;
$self->name . ($self->versioned_title ? ' ' . $self->version : '');
}
sub version {
my $self = shift;
return $self->{version} if $self->{version};
require Module::Metadata;
my $mod = $self->main_module;
my $file = Pod::Site::Search->instance->name2path->{$mod}
or die "Could not find $mod\n";
my $info = Module::Metadata->new_from_file( $file )
or die "Could not find $file\n";
return $self->{version} ||= $info->version;
}
sub _pod2usage {
shift;
require Pod::Usage;
Pod::Usage::pod2usage(
'-verbose' => 99,
'-sections' => '(?i:(Usage|Options))',
'-exitval' => 1,
'-input' => __FILE__,
@_
);
}
sub _config {
my $self = shift;
require Getopt::Long;
Getopt::Long::Configure( qw(bundling) );
my %opts = (
verbose => 0,
css_path => '',
js_path => '',
index_file => 'index.html',
base_uri => undef,
);
Getopt::Long::GetOptions(
'name|n=s' => \$opts{name},
'doc-root|d=s' => \$opts{doc_root},
'base-uri|u=s@' => \$opts{base_uri},
'favicon-uri=s' => \$opts{favicon_uri},
'sample-module|s=s' => \$opts{sample_module},
'main-module|m=s' => \$opts{main_module},
'versioned-title|t!' => \$opts{versioned_title},
'label|l=s' => \$opts{label},
'index-file|i=s' => \$opts{index_file},
'css-path|c=s' => \$opts{css_path},
'js-path|j=s' => \$opts{js_path},
'replace-css' => \$opts{replace_css},
'replace-js' => \$opts{replace_js},
'verbose|V+' => \$opts{verbose},
'help|h' => \$opts{help},
'man|M' => \$opts{man},
'version|v' => \$opts{version},
) or $self->_pod2usage;
# Handle documentation requests.
$self->_pod2usage(
( $opts{man} ? ( '-sections' => '.+' ) : ()),
'-exitval' => 0,
) if $opts{help} or $opts{man};
# Handle version request.
if ($opts{version}) {
require File::Basename;
print File::Basename::basename($0), ' (', __PACKAGE__, ') ',
__PACKAGE__->VERSION, $/;
exit;
}
# Check required options.
if (my @missing = map {
( my $opt = $_ ) =~ s/_/-/g;
"--$opt";
} grep { !$opts{$_} } qw(doc_root base_uri)) {
my $pl = @missing > 1 ? 's' : '';
my $last = pop @missing;
my $disp = @missing ? join(', ', @missing) . (@missing > 1 ? ',' : '')
. " and $last" : $last;
$self->_pod2usage( '-message' => "Missing required $disp option$pl" );
}
# Check for one or more module roots.
$self->_pod2usage( '-message' => "Missing path to module root" )
unless @ARGV;
$opts{module_roots} = \@ARGV;
# Modify options and set defaults as appropriate.
for (@{ $opts{base_uri} }) { $_ .= '/' unless m{/$}; }
return \%opts;
}
sub _set_mod {
my ($mods, $mod, $file) = @_;
if ($mod =~ /::/) {
my @names = split /::/ => $mod;
my $data = $mods->{shift @names} ||= {};
my $lln = pop @names;
for (@names) { $data = $data->{$_} ||= {} }
$data->{"$lln.pm"} = $file;
} else {
$mods->{"$mod.pm"} = $file;
}
}
sub _udent {
my $string = shift;
$string =~ s/^[ ]{4}//gm;
return $string;
}
sub _output_navlink {
my ($self, $fh, $key, $fn, $class, $no_link, $desc) = @_;
$desc ||= $self->get_desc($class, $fn);
$desc = "—$desc" if $desc;
# Output the Tree Browser Link.
print "Outputting $class nav link\n" if $self->{verbose} > 2;
print $fh $self->{base_space}, $self->{spacer} x $self->{indent},
qq{