File Coverage

blib/lib/Pod/Tree/PerlPod.pm
Criterion Covered Total %
statement 26 116 22.4
branch 0 16 0.0
condition 0 3 0.0
subroutine 9 20 45.0
pod 5 5 100.0
total 40 160 25.0


line stmt bran cond sub pod time code
1             package Pod::Tree::PerlPod;
2 1     1   5483286 use 5.006;
  1         31  
3 1     1   17 use strict;
  1         33  
  1         101  
4 1     1   23 use warnings;
  1         4  
  1         203  
5 1     1   11 use File::Find;
  1         3  
  1         434  
6 1     1   1484 use HTML::Stream;
  1         4174  
  1         86  
7 1     1   561 use IO::File;
  1         9497  
  1         129  
8 1     1   518 use Pod::Tree::HTML;
  1         2  
  1         10  
9 1     1   662 use Pod::Tree::PerlUtil;
  1         3  
  1         12  
10              
11             our $VERSION = '1.30';
12              
13 1     1   49 use base qw(Pod::Tree::PerlUtil);
  1         2  
  1         1373  
14              
15             sub new {
16 0     0 1   my ( $class, $perl_dir, $html_dir, $link_map, %options ) = @_;
17              
18 0           my %defaults = (
19             col_width => 20,
20             bgcolor => '#ffffff',
21             text => '#000000'
22             );
23              
24 0           my $options = { %defaults, %options, link_map => $link_map };
25              
26 0           my %special = map { $_ => 1 } qw(pod/perl pod/perlfunc);
  0            
27              
28 0           my $perl_pod = {
29             perl_dir => $perl_dir,
30             html_dir => $html_dir,
31             top_page => 'pod.html',
32             special => \%special,
33             options => $options
34             };
35              
36 0           bless $perl_pod, $class;
37             }
38              
39             sub scan {
40 0     0 1   my $perl_pod = shift;
41 0           $perl_pod->report1("scan");
42 0           my $perl_dir = $perl_pod->{perl_dir};
43              
44             File::Find::find(
45             {
46 0     0     wanted => sub { $perl_pod->_scan }, # Perl rocks!
47 0           no_chdir => 1
48             },
49             $perl_dir
50             );
51             }
52              
53             sub _scan {
54 0     0     my $perl_pod = shift;
55 0           my $source = $File::Find::name;
56 0           my $dest = $source;
57 0           my $perl_dir = $perl_pod->{perl_dir};
58 0           my $html_dir = $perl_pod->{html_dir};
59 0           $dest =~ s(^$perl_dir)($html_dir);
60              
61 0 0         -d $source and $perl_pod->_scan_dir($dest);
62 0 0         -f $source and $perl_pod->_scan_file( $source, $dest );
63             }
64              
65             sub _scan_dir {
66 0     0     my ( $perl_pod, $dir ) = @_;
67              
68             $dir =~ m(/ext$) and do # extensions are handled by Pod::Tree::PerlLib
69 0 0         {
70 0           $File::Find::prune = 1;
71 0           return;
72             };
73              
74 0 0 0       -d $dir
75             or mkdir $dir, 0755
76             or die "Pod::Tree::PerlPod::_scan_dir: Can't mkdir $dir: $!\n";
77             }
78              
79             sub _scan_file {
80 0     0     my ( $perl_pod, $source, $dest ) = @_;
81              
82 0 0         $source =~ m( (\w+)\.pod$ )x or return;
83              
84 0           my $link = $source;
85 0           my $perl_dir = $perl_pod->{perl_dir};
86 0           $link =~ s(^$perl_dir/)();
87 0           $link =~ s( \.pod$ )()x;
88 0           $perl_pod->report2($link);
89              
90 0           my $name = ( split m(/), $link )[-1];
91 0           my $desc = $perl_pod->get_description($source);
92              
93 0           $dest =~ s( \.\w+$ )(.html)x;
94              
95 0           my $pod = {
96             name => $name, # perldata
97             desc => $desc, # Perl data types
98             link => $link, # pod/perldata
99             source => $source, # .../perl5.5.650/pod/perldata.pod
100             dest => $dest
101             }; # .../public_html/perl/pod/perldata.html
102              
103 0           $perl_pod->{pods}{$link} = $pod;
104 0           $perl_pod->{options}{link_map}->add_page( $name, $link );
105             }
106              
107             sub index {
108 0     0 1   my $perl_pod = shift;
109 0           $perl_pod->report1("index");
110 0           my $html_dir = $perl_pod->{html_dir};
111 0           my $top_page = $perl_pod->{top_page};
112 0           my $dest = "$html_dir/$top_page";
113              
114 0           my $fh = IO::File->new(">$dest");
115 0 0         defined $fh or die "Pod::Tree::PerlPod::index: Can't open $dest: $!\n";
116 0           my $stream = HTML::Stream->new($fh);
117              
118 0           my $options = $perl_pod->{options};
119 0           my $bgcolor = $options->{bgcolor};
120 0           my $text = $options->{text};
121 0           my $title = "Perl PODs";
122              
123 0           $stream->HTML->HEAD;
124 0           $stream->TITLE->text($title)->_TITLE;
125 0           $stream->_HEAD->BODY( BGCOLOR => $bgcolor, TEXT => $text );
126 0           $stream->H1->t($title)->_H1;
127              
128 0           $perl_pod->_emit_entries($stream);
129              
130 0           $stream->_BODY->_HTML;
131             }
132              
133             sub get_top_entry {
134 0     0 1   my $perl_dist = shift;
135              
136             +{
137             URL => $perl_dist->{top_page},
138 0           description => 'PODs'
139             };
140             }
141              
142             sub _emit_entries {
143 0     0     my ( $perl_pod, $stream ) = @_;
144 0           my $pods = $perl_pod->{pods};
145 0           my $options = $perl_pod->{options};
146 0           my $col_width = $options->{col_width};
147              
148 0           $stream->PRE;
149              
150 0           $pods = $perl_pod->{pods};
151 0           for my $link ( sort keys %$pods ) {
152 0           my $pad = $col_width - length $link;
153 0           $stream->A( HREF => "$link.html" )->t($link)->_A;
154              
155 0 0         $pad < 1 and do {
156 0           $stream->nl;
157 0           $pad = $col_width;
158             };
159              
160 0           $stream->t( ' ' x $pad, $pods->{$link}{desc} )->nl;
161             }
162              
163 0           $stream->_PRE;
164             }
165              
166             sub translate {
167 0     0 1   my $perl_pod = shift;
168 0           $perl_pod->report1("translate");
169 0           my $pods = $perl_pod->{pods};
170 0           my $special = $perl_pod->{special};
171              
172 0           for my $link ( sort keys %$pods ) {
173 0 0         $special->{$link} and next;
174 0           $perl_pod->report2($link);
175 0           $perl_pod->_translate($link);
176             }
177             }
178              
179             sub _translate {
180 0     0     my ( $perl_pod, $link ) = @_;
181              
182 0           my $pod = $perl_pod->{pods}{$link};
183 0           my $source = $pod->{source};
184 0           my $dest = $pod->{dest};
185 0           my $options = $perl_pod->{options};
186              
187 0           my @path = split m(\/), $link;
188 0           my $depth = @path - 1;
189 0           $options->{link_map}->set_depth($depth);
190              
191 0           my $html = Pod::Tree::HTML->new( $source, $dest, %$options );
192 0           $html->translate;
193             }
194              
195             1
196              
197             __END__