File Coverage

blib/lib/Pod/Site.pm

Criterion	Covered	Total	%
statement	273	295	92.5
branch	96	132	72.7
condition	39	62	62.9
subroutine	44	45	97.7
pod	19	19	100.0
total	471	553	85.1

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" );

    "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">



        $title

        $base
        $favicon





          $head

            TOC
    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");

    "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">



        $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:


          /?$sample
          /$sample


        Happy Hacking!

        Classes & Modules

    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->{indent};
            $self->{uri} .= "$key/";
            $self->output($fh, $data);
            print $fh $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{$key\n}
      unless $no_link;

    # Output the TOC link.
    print "Outputting $class TOC link\n" if $self->{verbose} > 2;
    print {$self->{toc_fh}} $self->{base_space}, $self->{spacer},
      qq{$class$desc\n};
    return 1;
}

sub _find_module {
    my $self = shift;
    my $search = Pod::Site::Search->instance or return;
    my $bins   = $self->bin_files || {};
    for my $mod (sort {
        lc $a cmp lc $b
    } keys %{ $search->instance->name2path }) {
        return $mod unless $bins->{$mod};
    }
}

##############################################################################
package Pod::Site::Search;

use base 'Pod::Simple::Search';
use strict;
use warnings;
our $VERSION = '0.56';

my $instance;
sub instance { $instance }

sub new {
    my $self = shift->SUPER::new(@_);
    $self->laborious(1);
    $self->inc(0);
    $instance = $self;
    return $self;
}

##############################################################################
package Pod::Site::XHTML;

use strict;
use base 'Pod::Simple::XHTML';
our $VERSION = '0.56';

sub new {
    my $self = shift->SUPER::new;
    $self->index(1);

    # Strip leading spaces from verbatim blocks equivalent to the indent of
    # the first line.
    $self->strip_verbatim_indent(sub {
        my $lines = shift;
        (my $indent = $lines->[0]) =~ s/\S.*//;
        return $indent;
    });

    return $self;
}

sub start_L {
    my ($self, $flags) = @_;
    my $search = Pod::Site::Search->instance
        or return $self->SUPER::start_L($self);
    my $to  = $flags->{to} || '';
    my $url = $to && $search->name2path->{$to} ? $Pod::Site::BASE_URI . join('/', split /::/ => $to) . '.html' : '';
    my $id  = $flags->{section};
    return $self->SUPER::start_L($flags) unless $url || ($id && !$to);
    my $rel = $id ? 'subsection' : 'section';
    $url   .= '#' . $self->idify($id, 1) if $id;
    $to   ||= $self->title || $self->default_title || '';
    $self->{scratch} .= qq{};
}

sub html_header {
    my $self = shift;
    my $title = $self->force_title || $self->title || $self->default_title || '';
    my $version = Pod::Site->VERSION;
    return qq{
  "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">




    $title

  };
}

1;
__END__