File Coverage

blib/lib/Pod/Tree/PerlBin.pm
Criterion Covered Total %
statement 26 113 23.0
branch 0 16 0.0
condition 0 6 0.0
subroutine 9 19 47.3
pod 5 7 71.4
total 40 161 24.8


line stmt bran cond sub pod time code
1             package Pod::Tree::PerlBin;
2 1     1   3998121 use 5.006;
  1         15  
3 1     1   8 use strict;
  1         2  
  1         79  
4 1     1   27 use warnings;
  1         10  
  1         110  
5 1     1   9 use File::Find;
  1         2  
  1         233  
6 1     1   780 use HTML::Stream;
  1         4056  
  1         60  
7 1     1   468 use Pod::Tree;
  1         4  
  1         10  
8 1     1   500 use Pod::Tree::HTML;
  1         3  
  1         11  
9 1     1   740 use Pod::Tree::PerlUtil;
  1         3  
  1         14  
10              
11             our $VERSION = '1.30';
12              
13 1     1   43 use base qw(Pod::Tree::PerlUtil);
  1         3  
  1         1280  
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 => 25,
20             bgcolor => '#ffffff',
21             text => '#000000'
22             );
23 0           my $options = { %defaults, %options, link_map => $link_map };
24              
25 0           my $perl_bin = {
26             perl_dir => $perl_dir,
27             html_dir => $html_dir,
28             bin_dir => 'bin',
29             top_page => 'bin.html',
30             depth => 1,
31             options => $options
32             };
33              
34 0           bless $perl_bin, $class;
35             }
36              
37             sub scan {
38 0     0 1   my ( $perl_bin, @dirs ) = @_;
39 0           $perl_bin->report1("scan");
40              
41 0           for my $dir (@dirs) {
42 0 0         opendir( DIR, $dir ) or next; # Windows apps sometimes leave non-existant dirs on $PATH
43 0           for my $file ( readdir(DIR) ) {
44 0           my $path = "$dir/$file";
45 0 0 0       -f $path and -x $path and -T $path or next;
      0        
46 0           $perl_bin->scan_file( $dir, $file );
47             }
48             }
49              
50 0           $perl_bin->scan_xsubpp;
51             }
52              
53             # A Very Special search for a Very Special executable
54             sub scan_xsubpp {
55 0     0 0   my $perl_bin = shift;
56              
57 0           my @inc = grep {m(^/)} @INC; # Don't ask.
  0            
58 0 0   0     File::Find::find( sub { $perl_bin->_scan_xsubpp }, @inc ) if @inc;
  0            
59             }
60              
61             sub _scan_xsubpp {
62 0     0     my $perl_bin = shift;
63              
64 0 0         /^xsubpp$/
65             and $perl_bin->scan_file( $File::Find::dir, $_ );
66             }
67              
68             sub scan_file {
69 0     0 0   my ( $perl_bin, $dir, $file ) = @_;
70              
71 0           my $source = "$dir/$file";
72 0           my $html_dir = $perl_bin->{html_dir};
73 0           my $bin_dir = $perl_bin->{bin_dir};
74 0           my $link = "$bin_dir/$file";
75 0           my $dest = "$html_dir/$link.html";
76              
77 0           my ( $name, $description ) = $perl_bin->get_name($source);
78 0 0         $name or return;
79              
80             # Translate the first copy found in $PATH
81 0 0         $perl_bin->{index}{$name} and return;
82              
83 0           $perl_bin->report2($source);
84              
85 0           my $entry = {
86             source => $source,
87             dest => $dest,
88             file => $file,
89             description => $description
90             };
91              
92 0           $perl_bin->{index}{$name} = $entry;
93 0           $perl_bin->{options}{link_map}->add_page( $file, $link );
94 0           $perl_bin->{options}{link_map}->add_page( $name, $link );
95             }
96              
97             sub index {
98 0     0 1   my $perl_bin = shift;
99 0           $perl_bin->report1("index");
100              
101 0           my $html_dir = $perl_bin->{html_dir};
102 0           my $bin_dir = $perl_bin->{bin_dir};
103 0           my $top_page = $perl_bin->{top_page};
104 0           my $dest = "$html_dir/$top_page";
105              
106 0           $perl_bin->mkdir("$html_dir/$bin_dir");
107              
108 0           my $fh = IO::File->new(">$dest");
109 0 0         defined $fh or die "Pod::Tree::PerlBin::index: Can't open $dest: $!\n";
110 0           my $stream = HTML::Stream->new($fh);
111              
112 0           my $options = $perl_bin->{options};
113 0           my $bgcolor = $options->{bgcolor};
114 0           my $text = $options->{text};
115 0           my $title = "Perl Executables";
116              
117 0           $stream->HTML->HEAD;
118 0           $stream->TITLE->text($title)->_TITLE;
119 0           $stream->_HEAD->BODY( BGCOLOR => $bgcolor, TEXT => $text );
120 0           $stream->H1->t($title)->_H1;
121              
122 0           $perl_bin->_emit_entries($stream);
123              
124 0           $stream->_BODY->_HTML;
125             }
126              
127             sub get_top_entry {
128 0     0 1   my $perl_bin = shift;
129              
130             +{
131             URL => $perl_bin->{top_page},
132 0           description => 'Executables'
133             };
134             }
135              
136             sub _emit_entries {
137 0     0     my ( $perl_bin, $stream ) = @_;
138              
139 0           my $bin_dir = $perl_bin->{bin_dir};
140 0           my $index = $perl_bin->{index};
141 0           my $options = $perl_bin->{options};
142 0           my $col_width = $options->{col_width};
143              
144 0           $stream->PRE;
145              
146 0           for my $name ( sort keys %$index ) {
147 0           my $entry = $index->{$name};
148 0           my $file = $entry->{file};
149 0           my $desc = $entry->{description};
150 0           my $pad = $col_width - length $name;
151              
152 0           $stream->A( HREF => "$bin_dir/$file.html" )->t($name)->_A;
153              
154 0 0         $pad < 1 and do {
155 0           $stream->nl;
156 0           $pad = $col_width;
157             };
158              
159 0           $stream->t( ' ' x $pad, $desc )->nl;
160             }
161              
162 0           $stream->_PRE;
163             }
164              
165             sub translate {
166 0     0 1   my $perl_bin = shift;
167 0           $perl_bin->report1("translate");
168              
169 0           my $index = $perl_bin->{index};
170 0           my $options = $perl_bin->{options};
171              
172 0           for my $name ( sort keys %$index ) {
173 0           $perl_bin->report2($name);
174 0           my $depth = $perl_bin->{depth};
175 0           $options->{link_map}->set_depth($depth);
176              
177 0           my $entry = $index->{$name};
178 0           my $source = $entry->{source};
179 0           my $dest = $entry->{dest};
180 0           my $html = Pod::Tree::HTML->new( $source, $dest, %$options );
181 0           $html->translate;
182             }
183             }
184              
185             1
186              
187             __END__