File Coverage

blib/lib/Pod/Tree/PerlDist.pm

Criterion	Covered	Total	%
statement	23	126	18.2
branch	0	20	0.0
condition	0	6	0.0
subroutine	8	17	47.0
pod	5	8	62.5
total	36	177	20.3

package Pod::Tree::PerlDist;
use 5.006;
use strict;
use warnings;
use HTML::Stream;
use Pod::Tree;
use Pod::Tree::HTML;
use Pod::Tree::PerlUtil;

our $VERSION = '1.31';

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

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

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

	my @stop_base = qw(Configure
		configpm configure
		installhtml installman installperl
		mv-if-diff
		perlsh);

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

	my $perl_dist = {
		perl_dir  => $perl_dir,
		html_dir  => $html_dir,
		top_page  => 'dist.html',
		stop_ext  => [qw(SH c diff fixer h pl sym y)],
		stop_base => [@stop_base],
		depth     => 0,
		options   => $options
	};

	bless $perl_dist, $class;
}

sub scan {
	my $perl_dist = shift;
	$perl_dist->report1("scan");

	my $perl_dir = $perl_dist->{perl_dir};
	my $html_dir = $perl_dist->{html_dir};
	opendir( DIR, $perl_dir ) or die "Can't opendir $perl_dir: $!\n";

	my $stop_ext = $perl_dist->{stop_ext};
	my %stop_ext = map { $_ => 1 } @$stop_ext;

	my $stop_base = $perl_dist->{stop_base};
	my %stop_base = map { $_ => 1 } @$stop_base;

	for my $file ( readdir(DIR) ) {
		-f "$perl_dir/$file" and -T "$perl_dir/$file" or next;

		my ( $base, $ext ) = split m(\.), $file;
		$stop_ext{$ext}   and next;
		$stop_base{$base} and next;

		$perl_dist->report2($file);
		$perl_dist->scan_file($file);
	}
}

sub scan_file {
	my ( $perl_dist, $file ) = @_;

	my $perl_dir = $perl_dist->{perl_dir};
	my $html_dir = $perl_dist->{html_dir};

	my $source = "$perl_dir/$file";
	my $dest   = "$html_dir/$file.html";

	my $entry = {
		file   => $file,
		source => $source,
		dest   => $dest
	};

	$perl_dist->{index}{$file} = $entry;
	$perl_dist->{options}{link_map}->add_page( $file, $file );

	my ( $base, $ext ) = split m(\.), $file;
	$base eq 'README'
		and $ext
		and $perl_dist->{options}{link_map}->add_page( "perl$ext", $file );
}

sub index {
	my $perl_dist = shift;
	$perl_dist->report1("index");

	my $html_dir = $perl_dist->{html_dir};
	my $top_page = $perl_dist->{top_page};
	my $dest     = "$html_dir/$top_page";

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

	my $options = $perl_dist->{options};
	my $bgcolor = $options->{bgcolor};
	my $text    = $options->{text};
	my $title   = "Perl Distribution Documents";

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

	$perl_dist->_emit_entries($stream);

	$stream->_BODY->_HTML;
}

sub get_top_entry {
	my $perl_dist = shift;

	+{
		URL         => $perl_dist->{top_page},
		description => 'distribution documents'
	};
}

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

	my $index   = $perl_dist->{index};
	my $options = $perl_dist->{options};

	$stream->PRE;

	for my $name ( sort keys %$index ) {
		$stream->A( HREF => "$name.html" )->t($name)->_A->nl;
	}

	$stream->_PRE;
}

sub translate {
	my $perl_dist = shift;
	$perl_dist->report1("translate");

	my $depth = $perl_dist->{depth};
	my $index = $perl_dist->{index};

	$perl_dist->{options}{link_map}->set_depth($depth);

	for my $name ( sort keys %$index ) {
		$perl_dist->report2($name);

		my $entry  = $index->{$name};
		my $source = $entry->{source};
		open( my $FILE, '<', $source )
			or die "Pod::Tree::PerlDist::translate: Can't open $source: $!\n";
		my @file = <$FILE>;
		close $FILE;

		my $translate
			= ( grep {/^=\w+/} @file )
			? 'translate_pod'
			: 'translate_text';

		$perl_dist->$translate($entry);
	}
}

sub translate_pod {
	my ( $perl_dist, $entry ) = @_;

	my $source  = $entry->{source};
	my $dest    = $entry->{dest};
	my $options = $perl_dist->{options};
	my $html    = Pod::Tree::HTML->new( $source, $dest, %$options );
	$html->translate;
}

sub translate_text {
	my ( $perl_dist, $entry ) = @_;

	my $source = $entry->{source};
	my $dest   = $entry->{dest};

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

	my $options = $perl_dist->{options};
	my $bgcolor = $options->{bgcolor};
	my $text    = $options->{text};
	my $title   = $entry->{file};

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

	open( my $SOURCE, '<', $source )
		or die "Pod::Tree::PerlDist::translate_text: Can't open $source: $!\n";

	while ( my $line = <$SOURCE> ) {
		$stream->t($line);
	}
	close $SOURCE;

	$stream->_PRE;
	$stream->_BODY->_HTML;
}

1

__END__