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


line stmt bran cond sub pod time code
1             package Pod::Tree::PerlTop;
2 1     1   1162077 use 5.006;
  1         7  
3 1     1   13 use strict;
  1         13  
  1         67  
4 1     1   15 use warnings;
  1         2  
  1         123  
5              
6             our $VERSION = '1.31';
7              
8 1     1   546 use Pod::Tree::HTML;
  1         3  
  1         10  
9 1     1   627 use Pod::Tree::PerlUtil;
  1         3  
  1         13  
10 1     1   424 use Pod::Tree::HTML::PerlTop;
  1         3  
  1         9  
11              
12 1     1   32 use base qw(Pod::Tree::PerlUtil);
  1         2  
  1         1153  
13              
14             sub new {
15 0     0 1   my ( $class, $perl_dir, $html_dir, $link_map, %options ) = @_;
16              
17 0           my %defaults = (
18             bgcolor => '#ffffff',
19             text => '#000000'
20             );
21              
22 0           my $options = { %defaults, %options, link_map => $link_map };
23              
24 0 0         my $pod_src = -d "$perl_dir/pod"
25             ? 'pod' # for building the doc set from a Perl distribution
26             : 'lib/pod'; # for building the doc set from a Windows installation
27              
28 0           my $perl_top = {
29             perl_dir => $perl_dir,
30             html_dir => $html_dir,
31             index => 'index.html',
32             pod_src => 'pod',
33             pod_dst => 'pod',
34             page => 'perl',
35             options => $options
36             };
37              
38 0           bless $perl_top, $class;
39             }
40              
41             sub index {
42 0     0 1   my ( $perl_top, @translators ) = @_;
43 0           $perl_top->report1("index");
44              
45 0           my @entries = map { $_->get_top_entry } @translators;
  0            
46              
47 0           my $html_dir = $perl_top->{html_dir};
48 0           my $dest = "$html_dir/index.html";
49              
50 0           my $fh = IO::File->new(">$dest");
51 0 0         defined $fh or die "Pod::Tree::PerlTop::index: Can't open $dest: $!\n";
52 0           my $stream = HTML::Stream->new($fh);
53              
54 0           my $options = $perl_top->{options};
55 0           my $bgcolor = $options->{bgcolor};
56 0           my $text = $options->{text};
57 0           my $title = "Perl Documentation";
58              
59 0           $stream->HTML->HEAD;
60 0           $stream->TITLE->text($title)->_TITLE;
61 0           $stream->_HEAD->BODY( BGCOLOR => $bgcolor, TEXT => $text );
62 0           $stream->H1->t($title)->_H1;
63              
64 0           $perl_top->_emit_entries( $stream, @entries );
65              
66 0           $stream->_BODY->_HTML;
67             }
68              
69             sub _emit_entries {
70 0     0     my ( $perl_top, $stream, @entries ) = @_;
71              
72 0           $stream->UL;
73              
74 0           for my $entry (@entries) {
75 0           $stream->LI->A( HREF => $entry->{URL} )->t( $entry->{description} )->_A->_LI;
76             }
77              
78 0           $stream->_UL;
79             }
80              
81             sub translate {
82 0     0 1   my $perl_top = shift;
83 0           $perl_top->report1("translate");
84 0           my $perl_dir = $perl_top->{perl_dir};
85 0           my $options = $perl_top->{options};
86              
87 0           $options->{link_map}->set_depth(1);
88              
89 0           my $html_dir = $perl_top->{html_dir};
90 0           my $pod_src = $perl_top->{pod_src};
91 0           my $pod_dst = $perl_top->{pod_dst};
92 0           my $page = $perl_top->{page};
93 0           my $source = "$perl_dir/$pod_src/$page.pod";
94 0           my $dest = "$html_dir/$pod_dst/$page.html";
95 0           my $html = Pod::Tree::HTML::PerlTop->new( $source, $dest, %$options );
96 0           my $links = $perl_top->_get_links;
97              
98 0           $html->set_links($links);
99 0           $html->translate;
100             }
101              
102             sub get_top_entry {
103 0     0 1   my $perl_top = shift;
104              
105 0           my $pod_dst = $perl_top->{pod_dst};
106 0           my $page = $perl_top->{page};
107              
108             +{
109 0           URL => "$pod_dst/$page.html",
110             description => 'perl(1)'
111             };
112             }
113              
114             sub _get_links {
115 0     0     my $perl_top = shift;
116              
117 0           my $links = {};
118 0           $perl_top->_get_pod_links($links);
119 0           $perl_top->_get_dist_links($links);
120              
121 0           $links;
122             }
123              
124             sub _get_pod_links {
125 0     0     my ( $perl_top, $links ) = @_;
126              
127 0           my $perl_dir = $perl_top->{perl_dir};
128 0           my $pod_src = $perl_top->{pod_src};
129              
130 0           my $dir = "$perl_dir/$pod_src";
131 0 0         opendir( DIR, $dir )
132             or die "Pod::Tree::PerlTop::get_pod_links: Can't opendir $dir: $!\n";
133 0           my @files = readdir(DIR);
134 0           closedir(DIR);
135              
136 0           my @pods = grep {m( \.pod$ )x} @files;
  0            
137 0           my @others = grep { $_ ne 'perl.pod' } @pods;
  0            
138              
139 0           for my $other (@others) {
140 0           $other =~ s( \.pod$ )()x;
141 0           $links->{$other} = $other;
142             }
143             }
144              
145             sub _get_dist_links {
146 0     0     my ( $perl_top, $links ) = @_;
147              
148 0           my $dir = $perl_top->{perl_dir};
149 0 0         opendir( DIR, $dir )
150             or die "Pod::Tree::PerlTop::get_dist_links: Can't opendir $dir: $!\n";
151 0           my @files = readdir(DIR);
152 0           closedir(DIR);
153              
154 0           my @README = grep {/^README/} @files;
  0            
155              
156 0           for my $file (@README) {
157 0           my ( $base, $ext ) = split m(\.), $file;
158 0           $links->{"perl$ext"} = "../$file";
159             }
160             }
161              
162             1
163              
164             __END__