File Coverage

blib/lib/Pod/Tree/PerlTop.pm

Criterion	Covered	Total	%
statement	20	98	20.4
branch	0	8	0.0
condition			n/a
subroutine	7	15	46.6
pod	4	4	100.0
total	31	125	24.8

package Pod::Tree::PerlTop;
use 5.006;
use strict;
use warnings;

our $VERSION = '1.31';

use Pod::Tree::HTML;
use Pod::Tree::PerlUtil;
use Pod::Tree::HTML::PerlTop;

use base qw(Pod::Tree::PerlUtil);

sub new {
	my ( $class, $perl_dir, $html_dir, $link_map, %options ) = @_;

	my %defaults = (
		bgcolor => '#ffffff',
		text    => '#000000'
	);

	my $options = { %defaults, %options, link_map => $link_map };

	my $pod_src = -d "$perl_dir/pod"
		? 'pod'         # for building the doc set from a Perl distribution
		: 'lib/pod';    # for building the doc set from a Windows installation

	my $perl_top = {
		perl_dir => $perl_dir,
		html_dir => $html_dir,
		index    => 'index.html',
		pod_src  => 'pod',
		pod_dst  => 'pod',
		page     => 'perl',
		options  => $options
	};

	bless $perl_top, $class;
}

sub index {
	my ( $perl_top, @translators ) = @_;
	$perl_top->report1("index");

	my @entries = map { $_->get_top_entry } @translators;

	my $html_dir = $perl_top->{html_dir};
	my $dest     = "$html_dir/index.html";

	my $fh = IO::File->new(">$dest");
	defined $fh or die "Pod::Tree::PerlTop::index: Can't open $dest: $!\n";
	my $stream = HTML::Stream->new($fh);

	my $options = $perl_top->{options};
	my $bgcolor = $options->{bgcolor};
	my $text    = $options->{text};
	my $title   = "Perl Documentation";

	$stream->HTML->HEAD;
	$stream->TITLE->text($title)->_TITLE;
	$stream->_HEAD->BODY( BGCOLOR => $bgcolor, TEXT => $text );
	$stream->H1->t($title)->_H1;

	$perl_top->_emit_entries( $stream, @entries );

	$stream->_BODY->_HTML;
}

sub _emit_entries {
	my ( $perl_top, $stream, @entries ) = @_;

	$stream->UL;

	for my $entry (@entries) {
		$stream->LI->A( HREF => $entry->{URL} )->t( $entry->{description} )->_A->_LI;
	}

	$stream->_UL;
}

sub translate {
	my $perl_top = shift;
	$perl_top->report1("translate");
	my $perl_dir = $perl_top->{perl_dir};
	my $options  = $perl_top->{options};

	$options->{link_map}->set_depth(1);

	my $html_dir = $perl_top->{html_dir};
	my $pod_src  = $perl_top->{pod_src};
	my $pod_dst  = $perl_top->{pod_dst};
	my $page     = $perl_top->{page};
	my $source   = "$perl_dir/$pod_src/$page.pod";
	my $dest     = "$html_dir/$pod_dst/$page.html";
	my $html     = Pod::Tree::HTML::PerlTop->new( $source, $dest, %$options );
	my $links    = $perl_top->_get_links;

	$html->set_links($links);
	$html->translate;
}

sub get_top_entry {
	my $perl_top = shift;

	my $pod_dst = $perl_top->{pod_dst};
	my $page    = $perl_top->{page};

	+{
		URL         => "$pod_dst/$page.html",
		description => 'perl(1)'
	};
}

sub _get_links {
	my $perl_top = shift;

	my $links = {};
	$perl_top->_get_pod_links($links);
	$perl_top->_get_dist_links($links);

	$links;
}

sub _get_pod_links {
	my ( $perl_top, $links ) = @_;

	my $perl_dir = $perl_top->{perl_dir};
	my $pod_src  = $perl_top->{pod_src};

	my $dir = "$perl_dir/$pod_src";
	opendir( DIR, $dir )
		or die "Pod::Tree::PerlTop::get_pod_links: Can't opendir $dir: $!\n";
	my @files = readdir(DIR);
	closedir(DIR);

	my @pods   = grep {m( \.pod$ )x} @files;
	my @others = grep { $_ ne 'perl.pod' } @pods;

	for my $other (@others) {
		$other =~ s( \.pod$ )()x;
		$links->{$other} = $other;
	}
}

sub _get_dist_links {
	my ( $perl_top, $links ) = @_;

	my $dir = $perl_top->{perl_dir};
	opendir( DIR, $dir )
		or die "Pod::Tree::PerlTop::get_dist_links: Can't opendir $dir: $!\n";
	my @files = readdir(DIR);
	closedir(DIR);

	my @README = grep {/^README/} @files;

	for my $file (@README) {
		my ( $base, $ext ) = split m(\.), $file;
		$links->{"perl$ext"} = "../$file";
	}
}

1

__END__