blib/lib/Pod/Site.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 274 | 293 | 93.5 |
branch | 95 | 130 | 73.0 |
condition | 41 | 62 | 66.1 |
subroutine | 45 | 46 | 97.8 |
pod | 19 | 19 | 100.0 |
total | 474 | 550 | 86.1 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Pod::Site; | ||||||
2 | |||||||
3 | 4 | 4 | 217107 | use strict; | |||
4 | 11 | ||||||
4 | 157 | ||||||
4 | 4 | 4 | 23 | use warnings; | |||
4 | 11 | ||||||
4 | 136 | ||||||
5 | 4 | 4 | 23 | use File::Spec; | |||
4 | 10 | ||||||
4 | 101 | ||||||
6 | 4 | 4 | 22 | use Carp; | |||
4 | 9 | ||||||
4 | 366 | ||||||
7 | 4 | 4 | 5709 | use Pod::Simple '3.12'; | |||
4 | 201914 | ||||||
4 | 133 | ||||||
8 | 4 | 4 | 4482 | use HTML::Entities; | |||
4 | 30372 | ||||||
4 | 4992 | ||||||
9 | 4 | 4 | 48 | use File::Path; | |||
4 | 10 | ||||||
4 | 321 | ||||||
10 | 4 | 29 | use Object::Tiny qw( | ||||
11 | module_roots | ||||||
12 | doc_root | ||||||
13 | base_uri | ||||||
14 | index_file | ||||||
15 | css_path | ||||||
16 | js_path | ||||||
17 | versioned_title | ||||||
18 | replace_css | ||||||
19 | replace_js | ||||||
20 | label | ||||||
21 | verbose | ||||||
22 | mod_files | ||||||
23 | bin_files | ||||||
24 | 4 | 4 | 5088 | ); | |||
4 | 1602 | ||||||
25 | |||||||
26 | 4 | 4 | 1847 | use vars '$VERSION'; | |||
4 | 7 | ||||||
4 | 22648 | ||||||
27 | $VERSION = '0.53'; | ||||||
28 | |||||||
29 | sub go { | ||||||
30 | 0 | 0 | 1 | 0 | my $class = shift; | ||
31 | 0 | 0 | $class->new( $class->_config )->build; | ||||
32 | } | ||||||
33 | |||||||
34 | sub new { | ||||||
35 | 5 | 5 | 1 | 21744 | my ( $class, $params ) = @_; | ||
36 | 5 | 100 | 92 | my $self = bless { | |||
37 | index_file => 'index.html', | ||||||
38 | verbose => 0, | ||||||
39 | js_path => '', | ||||||
40 | css_path => '', | ||||||
41 | 5 | 23 | %{ $params || {} } | ||||
42 | } => $class; | ||||||
43 | |||||||
44 | 5 | 100 | 22 | if (my @req = grep { !$self->{$_} } qw(doc_root base_uri module_roots)) { | |||
15 | 71 | ||||||
45 | 1 | 50 | 7 | my $pl = @req > 1 ? 's' : ''; | |||
46 | 1 | 4 | my $last = pop @req; | ||||
47 | 1 | 50 | 10 | my $disp = @req ? join(', ', @req) . (@req > 1 ? ',' : '') | |||
50 | |||||||
48 | . " and $last" : $last; | ||||||
49 | 1 | 260 | croak "Missing required parameters $disp"; | ||||
50 | } | ||||||
51 | |||||||
52 | 4 | 100 | 28 | my $roots = ref $self->{module_roots} eq 'ARRAY' | |||
53 | ? $self->{module_roots} | ||||||
54 | : ( $self->{module_roots} = [$self->{module_roots}] ); | ||||||
55 | 4 | 9 | for my $path (@{ $roots }) { | ||||
4 | 10 | ||||||
56 | 4 | 100 | 464 | croak "The module root $path does not exist\n" unless -e $path; | |||
57 | } | ||||||
58 | |||||||
59 | 3 | 100 | 22 | $self->{base_uri} = [$self->{base_uri}] unless ref $self->{base_uri}; | |||
60 | 3 | 26 | return $self; | ||||
61 | } | ||||||
62 | |||||||
63 | sub build { | ||||||
64 | 2 | 2 | 1 | 6 | my $self = shift; | ||
65 | 2 | 579 | File::Path::mkpath($self->{doc_root}, 0, 0755); | ||||
66 | |||||||
67 | 2 | 12 | $self->batch_html; | ||||
68 | |||||||
69 | # The index file is the home page. | ||||||
70 | 2 | 171 | my $idx_file = File::Spec->catfile( $self->doc_root, $self->index_file ); | ||||
71 | 2 | 50 | 341 | open my $idx_fh, '>', $idx_file or die qq{Cannot open "$idx_file": $!\n}; | |||
72 | |||||||
73 | # The TOC file has the table of contents for all modules and programs in | ||||||
74 | # the distribution. | ||||||
75 | 2 | 28 | my $toc_file = File::Spec->catfile( $self->{doc_root}, 'toc.html' ); | ||||
76 | 2 | 50 | 1262 | open my $toc_fh, '>', $toc_file or die qq{Cannot open "$toc_file": $!\n}; | |||
77 | |||||||
78 | # Set things up. | ||||||
79 | 2 | 19 | $self->{toc_fh} = $toc_fh; | ||||
80 | 2 | 12 | $self->{seen} = {}; | ||||
81 | 2 | 8 | $self->{indent} = 1; | ||||
82 | 2 | 11 | $self->{base_space} = ' '; | ||||
83 | 2 | 7 | $self->{spacer} = ' '; | ||||
84 | 2 | 11 | $self->{uri} = ''; | ||||
85 | |||||||
86 | # Make it so! | ||||||
87 | 2 | 16 | $self->sort_files; | ||||
88 | 2 | 11 | $self->start_nav($idx_fh); | ||||
89 | 2 | 18 | $self->start_toc($toc_fh); | ||||
90 | 2 | 49 | $self->output($idx_fh, $self->mod_files); | ||||
91 | 2 | 14 | $self->output_bin($idx_fh); | ||||
92 | 2 | 7 | $self->finish_nav($idx_fh); | ||||
93 | 2 | 9 | $self->finish_toc($toc_fh); | ||||
94 | 2 | 13 | $self->copy_etc; | ||||
95 | |||||||
96 | # Close up shop. | ||||||
97 | 2 | 50 | 323434 | close $idx_fh or die qq{Could not close "$idx_file": $!\n}; | |||
98 | 2 | 50 | 15257 | close $toc_fh or die qq{Could not close "$toc_file": $!\n}; | |||
99 | } | ||||||
100 | |||||||
101 | sub sort_files { | ||||||
102 | 2 | 2 | 1 | 4 | my $self = shift; | ||
103 | |||||||
104 | # Let's see what the search has found. | ||||||
105 | 2 | 23 | my $stuff = Pod::Site::Search->instance->name2path; | ||||
106 | |||||||
107 | # Sort the modules from the scripts. | ||||||
108 | 2 | 21 | my (%mods, %bins); | ||||
109 | 2 | 3 | while (my ($name, $path) = each %{ $stuff }) { | ||||
16 | 63 | ||||||
110 | 14 | 50 | 52 | if ($name =~ /[.]p(?:m|od)$/) { | |||
50 | |||||||
111 | # Likely a module. | ||||||
112 | 0 | 0 | _set_mod(\%mods, $name, $stuff->{$name}); | ||||
113 | } elsif ($name =~ /[.](?:plx?|bat)$/) { | ||||||
114 | # Likely a script. | ||||||
115 | 0 | 0 | (my $script = $name) =~ s{::}{/}g; | ||||
116 | 0 | 0 | $bins{$script} = $stuff->{$name}; | ||||
117 | } else { | ||||||
118 | # Look for a shebang line. | ||||||
119 | 14 | 50 | 602 | if (open my $fh, '<', $path) { | |||
120 | 14 | 124 | my $shebang = <$fh>; | ||||
121 | 14 | 160 | close $fh; | ||||
122 | 14 | 50 | 33 | 90 | if ($shebang && $shebang =~ /^#!.*\bperl/) { | ||
123 | # Likely a script. | ||||||
124 | 0 | 0 | (my $script = $name) =~ s{::}{/}g; | ||||
125 | 0 | 0 | $bins{$script} = $stuff->{$name}; | ||||
126 | } else { | ||||||
127 | # Likely a module. | ||||||
128 | 14 | 44 | _set_mod(\%mods, $name, $stuff->{$name}); | ||||
129 | } | ||||||
130 | } else { | ||||||
131 | # Who knows? Default to module. | ||||||
132 | 0 | 0 | _set_mod(\%mods, $name, $stuff->{$name}); | ||||
133 | } | ||||||
134 | } | ||||||
135 | } | ||||||
136 | |||||||
137 | # Save our findings. | ||||||
138 | 2 | 16 | $self->{mod_files} = \%mods; | ||||
139 | 2 | 12 | $self->{bin_files} = \%bins; | ||||
140 | } | ||||||
141 | |||||||
142 | sub start_nav { | ||||||
143 | 2 | 2 | 1 | 3 | my ($self, $fh) = @_; | ||
144 | 2 | 8 | my $class = ref $self; | ||||
145 | 2 | 31 | my $version = __PACKAGE__->VERSION; | ||||
146 | 2 | 26 | my $title = encode_entities $self->title; | ||||
147 | 2 | 240 | my $head = encode_entities $self->nav_header; | ||||
148 | |||||||
149 | 2 | 50 | 94 | print STDERR "Starting site navigation file\n" if $self->verbose > 1; | |||
150 | 2 | 18 | my $base = join "\n ", map { | ||||
151 | 2 | 7 | qq{} | ||||
152 | 2 | 16 | } @{ $self->{base_uri} }; | ||||
153 | |||||||
154 | 2 | 22 | print $fh _udent( <<" EOF" ); | ||||
155 | |||||||
156 | "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> | ||||||
157 | |||||||
158 | |||||||
159 | |||||||
160 | |
||||||
161 | |||||||
162 | $base | ||||||
163 | |||||||
164 | |||||||
165 | |||||||
166 | |||||||
167 | |||||||
168 | $head |
||||||
169 | |
||||||
170 | |
||||||
171 | EOF | ||||||
172 | } | ||||||
173 | |||||||
174 | sub start_toc { | ||||||
175 | 2 | 2 | 1 | 7 | my ($self, $fh) = @_; | ||
176 | |||||||
177 | 2 | 8 | my $sample = encode_entities $self->sample_module; | ||||
178 | 2 | 51 | my $version = Pod::Site->VERSION; | ||||
179 | 2 | 10 | my $title = encode_entities $self->title; | ||||
180 | |||||||
181 | 2 | 50 | 683 | print STDERR "Starting browser TOC file\n" if $self->verbose > 1; | |||
182 | 2 | 35 | print $fh _udent( <<" EOF"); | ||||
183 | |||||||
184 | "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> | ||||||
185 | |||||||
186 | |||||||
187 | |||||||
188 | |
||||||
189 | |||||||
190 | |||||||
191 | |||||||
192 | |||||||
193 | $title |
||||||
194 | Instructions |
||||||
195 | |||||||
196 | Select class names from the navigation tree to the left. The tree |
||||||
197 | shows a hierarchical list of modules and programs. In addition to | ||||||
198 | this URL, you can link directly to the page for a particular module | ||||||
199 | or program. For example, if you wanted to access | ||||||
200 | $sample, any of these links will work: | ||||||
201 | |||||||
202 | |
||||||
203 | |
||||||
204 | |
||||||
205 | |||||||
206 | |||||||
207 | Happy Hacking! |
||||||
208 | |||||||
209 | Classes & Modules |
||||||
210 | |
||||||
211 | EOF | ||||||
212 | } | ||||||
213 | |||||||
214 | sub output { | ||||||
215 | 10 | 10 | 1 | 38 | my ($self, $fh, $tree) = @_; | ||
216 | 10 | 26 | for my $key (sort keys %{ $tree }) { | ||||
10 | 62 | ||||||
217 | 22 | 39 | my $data = $tree->{$key}; | ||||
218 | 22 | 76 | (my $fn = $key) =~ s/\.[^.]+$//; | ||||
219 | 22 | 1196 | my $class = join ('::', split('/', $self->{uri}), $fn); | ||||
220 | 22 | 50 | 580 | print STDERR "Reading $class\n" if $self->verbose > 1; | |||
221 | 22 | 100 | 123 | if (ref $data) { | |||
222 | # It's a directory tree. Output a class for it, first, if there | ||||||
223 | # is one. | ||||||
224 | 8 | 14 | my $item = $key; | ||||
225 | 8 | 100 | 29 | if ($tree->{"$key.pm"}) { | |||
226 | 6 | 14 | my $path = $tree->{"$key.pm"}; | ||||
227 | 6 | 50 | 25 | if (my $desc = $self->get_desc($class, $path)) { | |||
228 | 6 | 21 | $item = qq{$key}; | ||||
229 | 6 | 20 | $self->_output_navlink($fh, $fn, $path, $class, 1, $desc); | ||||
230 | } | ||||||
231 | 6 | 20 | $self->{seen}{$class} = 1; | ||||
232 | } | ||||||
233 | |||||||
234 | # Now recursively descend the tree. | ||||||
235 | 8 | 50 | 236 | print STDERR "Outputting nav link\n" if $self->verbose > 2; | |||
236 | 8 | 87 | print $fh $self->{base_space}, $self->{spacer} x $self->{indent}, | ||||
237 | qq{ |
||||||
238 | $self->{spacer} x ++$self->{indent}, "
|
||||||
239 | 8 | 12 | ++$self->{indent}; | ||||
240 | 8 | 17 | $self->{uri} .= "$key/"; | ||||
241 | 8 | 50 | $self->output($fh, $data); | ||||
242 | 8 | 37 | print $fh $self->{base_space}, $self->{spacer} x --$self->{indent}, | ||||
243 | "\n", $self->{base_space}, | ||||||
244 | $self->{spacer} x --$self->{indent}, "\n"; | ||||||
245 | 8 | 165 | $self->{uri} =~ s|$key/$||; | ||||
246 | } else { | ||||||
247 | # It's a class. Create a link to it. | ||||||
248 | 14 | 100 | 668 | $self->_output_navlink($fh, $fn, $data, $class) | |||
249 | unless $self->{seen}{$class}; | ||||||
250 | } | ||||||
251 | } | ||||||
252 | } | ||||||
253 | |||||||
254 | sub output_bin { | ||||||
255 | 2 | 2 | 1 | 4 | my ($self, $fh) = @_; | ||
256 | 2 | 55 | my $files = $self->bin_files; | ||||
257 | 2 | 50 | 9 | return unless %{ $files }; | |||
2 | 12 | ||||||
258 | |||||||
259 | # Start the list in the tree browser. | ||||||
260 | 0 | 0 | print $fh $self->{base_space}, $self->{spacer} x $self->{indent}, | ||||
261 | qq{
|
||||||
262 | 0 | 0 | ++$self->{indent}; | ||||
263 | |||||||
264 | 0 | 0 | for my $pl (sort { lc $a cmp lc $b } keys %{ $files }) { | ||||
0 | 0 | ||||||
0 | 0 | ||||||
265 | 0 | 0 | my $file = $files->{$pl}; | ||||
266 | 0 | 0 | $self->_output_navlink($fh, $pl, $file, $pl); | ||||
267 | } | ||||||
268 | |||||||
269 | 0 | 0 | print $fh $self->{base_space}, $self->{spacer} x --$self->{indent}, "\n", | ||||
270 | $self->{base_space}, $self->{spacer} x --$self->{indent}, "\n"; | ||||||
271 | } | ||||||
272 | |||||||
273 | sub finish_nav { | ||||||
274 | 2 | 2 | 1 | 7 | my ($self, $fh) = @_; | ||
275 | 2 | 50 | 51 | print STDERR "Finishing browser navigation file\n" if $self->verbose > 1; | |||
276 | 2 | 20 | print $fh _udent( <<" EOF" ); | ||||
277 | |||||||
278 | |||||||
279 | |||||||
280 | |||||||
281 | |||||||
282 | EOF | ||||||
283 | } | ||||||
284 | |||||||
285 | sub finish_toc { | ||||||
286 | 2 | 2 | 1 | 5 | my ($self, $fh) = @_; | ||
287 | 2 | 50 | 48 | print STDERR "finishing browser TOC file\n" if $self->verbose > 1; | |||
288 | 2 | 16 | print $fh _udent( <<" EOF" ); | ||||
289 | |||||||
290 | |||||||
291 | |||||||
292 | EOF | ||||||
293 | } | ||||||
294 | |||||||
295 | sub batch_html { | ||||||
296 | 2 | 2 | 1 | 6 | my $self = shift; | ||
297 | 2 | 1389 | require Pod::Simple::HTMLBatch; | ||||
298 | 2 | 50 | 84768 | print STDERR "Creating HTML with Pod::Simple::XHTML\n" if $self->verbose > 1; | |||
299 | 2 | 38 | my $batchconv = Pod::Simple::HTMLBatch->new; | ||||
300 | 2 | 567 | $batchconv->index(1); | ||||
301 | 2 | 70 | $batchconv->verbose($self->verbose); | ||||
302 | 2 | 47 | $batchconv->contents_file( undef ); | ||||
303 | 2 | 18 | $batchconv->css_flurry(0); | ||||
304 | 2 | 17 | $batchconv->javascript_flurry(0); | ||||
305 | 2 | 16 | $batchconv->html_render_class('Pod::Site::XHTML'); | ||||
306 | 2 | 15 | $batchconv->search_class('Pod::Site::Search'); | ||||
307 | 2 | 13 | our $BASE_URI; | ||||
308 | 2 | 56 | local $BASE_URI = $self->base_uri->[0]; | ||||
309 | 2 | 60 | $batchconv->batch_convert( $self->module_roots, $self->{doc_root} ); | ||||
310 | 2 | 856 | return 1; | ||||
311 | } | ||||||
312 | |||||||
313 | sub copy_etc { | ||||||
314 | 2 | 2 | 1 | 6 | my $self = shift; | ||
315 | 2 | 2258 | require File::Copy; | ||||
316 | 2 | 7113 | (my $from = __FILE__) =~ s/[.]pm$//; | ||||
317 | 2 | 6 | for my $ext (qw(css js)) { | ||||
318 | 4 | 877 | my $dest = File::Spec->catfile($self->{doc_root}, "podsite.$ext"); | ||||
319 | 4 | 100 | 66 | 1071 | File::Copy::copy( | ||
320 | File::Spec->catfile( $from, "podsite.$ext" ), | ||||||
321 | $self->{doc_root} | ||||||
322 | ) unless -e $dest && !$self->{"replace_$ext"}; | ||||||
323 | } | ||||||
324 | } | ||||||
325 | |||||||
326 | sub get_desc { | ||||||
327 | 16 | 16 | 1 | 580 | my ($self, $what, $file) = @_; | ||
328 | |||||||
329 | 16 | 50 | 1 | 812 | open my $fh, '<', $file or die "Cannot open $file: $!\n"; | ||
1 | 32 | ||||||
1 | 2 | ||||||
1 | 9 | ||||||
330 | 16 | 1341 | my ($desc, $encoding); | ||||
331 | 16 | 76 | local $_; | ||||
332 | # Cribbed from Module::Build::PodParser. | ||||||
333 | 16 | 100 | 308 | while (not ($desc and $encoding) and $_ = <$fh>) { | |||
66 | |||||||
334 | 540 | 100 | 3698 | next unless /^=(?!cut)/ .. /^=cut/; # in POD | |||
335 | 504 | 100 | 842 | ($desc) = /^ (?: [a-z0-9:]+ \s+ - \s+ ) (.*\S) /ix unless $desc; | |||
336 | 504 | 100 | 3742 | ($encoding) = /^=encoding\s+(.*\S)/ unless $encoding; | |||
337 | } | ||||||
338 | 16 | 100 | 66 | 75 | Encode::from_to($desc, $encoding, 'UTF-8') if $desc && $encoding; | ||
339 | |||||||
340 | 16 | 50 | 320 | close $fh or die "Cannot close $file: $!\n"; | |||
341 | 16 | 50 | 33 | 61 | print "$what has no POD or no description in a =head1 NAME section\n" | ||
342 | if $self->{verbose} && !$desc; | ||||||
343 | 16 | 50 | 116 | return $desc || ''; | |||
344 | } | ||||||
345 | |||||||
346 | sub sample_module { | ||||||
347 | 3 | 3 | 1 | 7 | my $self = shift; | ||
348 | 3 | 66 | 34 | $self->{sample_module} ||= $self->main_module; | |||
349 | } | ||||||
350 | |||||||
351 | sub main_module { | ||||||
352 | 16 | 16 | 1 | 27 | my $self = shift; | ||
353 | 16 | 66 | 268 | $self->{main_module} ||= $self->_find_module; | |||
354 | } | ||||||
355 | |||||||
356 | sub name { | ||||||
357 | 12 | 12 | 1 | 2831 | my $self = shift; | ||
358 | 12 | 50 | 84 | $self->{name} || $self->main_module; | |||
359 | } | ||||||
360 | |||||||
361 | sub title { | ||||||
362 | 6 | 6 | 1 | 16 | my $self = shift; | ||
363 | 6 | 100 | 66 | 48 | return $self->{title} ||= join ' ', | ||
100 | |||||||
364 | $self->name, | ||||||
365 | ( $self->versioned_title ? $self->version : () ), | ||||||
366 | ( $self->label ? $self->label : () ); | ||||||
367 | } | ||||||
368 | |||||||
369 | sub nav_header { | ||||||
370 | 4 | 4 | 1 | 446 | my $self = shift; | ||
371 | 4 | 100 | 16 | $self->name . ($self->versioned_title ? ' ' . $self->version : ''); | |||
372 | } | ||||||
373 | |||||||
374 | sub version { | ||||||
375 | 5 | 5 | 1 | 41 | my $self = shift; | ||
376 | 5 | 100 | 163 | return $self->{version} if $self->{version}; | |||
377 | 1 | 1322 | require Module::Build::ModuleInfo; | ||||
378 | 1 | 73977 | my $mod = $self->main_module; | ||||
379 | 1 | 50 | 89 | my $file = Pod::Site::Search->instance->name2path->{$mod} | |||
380 | or die "Could not find $mod\n"; | ||||||
381 | 1 | 50 | 30 | my $info = Module::Build::ModuleInfo->new_from_file( $file ) | |||
382 | or die "Could not find $file\n"; | ||||||
383 | 1 | 33 | 13054 | return $self->{version} ||= $info->version; | |||
384 | } | ||||||
385 | |||||||
386 | sub _pod2usage { | ||||||
387 | 1 | 1 | 26038 | shift; | |||
388 | 1 | 13 | require Pod::Usage; | ||||
389 | 1 | 6 | Pod::Usage::pod2usage( | ||||
390 | '-verbose' => 99, | ||||||
391 | '-sections' => '(?i:(Usage|Options))', | ||||||
392 | '-exitval' => 1, | ||||||
393 | '-input' => __FILE__, | ||||||
394 | @_ | ||||||
395 | ); | ||||||
396 | } | ||||||
397 | |||||||
398 | sub _config { | ||||||
399 | 13 | 13 | 6692 | my $self = shift; | |||
400 | 13 | 1580 | require Getopt::Long; | ||||
401 | 13 | 11580 | Getopt::Long::Configure( qw(bundling) ); | ||||
402 | |||||||
403 | 13 | 446 | my %opts = ( | ||||
404 | verbose => 0, | ||||||
405 | css_path => '', | ||||||
406 | js_path => '', | ||||||
407 | index_file => 'index.html', | ||||||
408 | base_uri => undef, | ||||||
409 | ); | ||||||
410 | |||||||
411 | 13 | 50 | 142 | Getopt::Long::GetOptions( | |||
412 | 'name|n=s' => \$opts{name}, | ||||||
413 | 'doc-root|d=s' => \$opts{doc_root}, | ||||||
414 | 'base-uri|u=s@' => \$opts{base_uri}, | ||||||
415 | 'sample-module|s=s' => \$opts{sample_module}, | ||||||
416 | 'main-module|m=s' => \$opts{main_module}, | ||||||
417 | 'versioned-title|t!' => \$opts{versioned_title}, | ||||||
418 | 'label|l=s' => \$opts{label}, | ||||||
419 | 'index-file|i=s' => \$opts{index_file}, | ||||||
420 | 'css-path|c=s' => \$opts{css_path}, | ||||||
421 | 'js-path|j=s' => \$opts{js_path}, | ||||||
422 | 'replace-css' => \$opts{replace_css}, | ||||||
423 | 'replace-js' => \$opts{replace_js}, | ||||||
424 | 'verbose|V+' => \$opts{verbose}, | ||||||
425 | 'help|h' => \$opts{help}, | ||||||
426 | 'man|M' => \$opts{man}, | ||||||
427 | 'version|v' => \$opts{version}, | ||||||
428 | ) or $self->_pod2usage; | ||||||
429 | |||||||
430 | # Handle documentation requests. | ||||||
431 | 13 | 100 | 100 | 17068 | $self->_pod2usage( | ||
100 | |||||||
432 | ( $opts{man} ? ( '-sections' => '.+' ) : ()), | ||||||
433 | '-exitval' => 0, | ||||||
434 | ) if $opts{help} or $opts{man}; | ||||||
435 | |||||||
436 | # Handle version request. | ||||||
437 | 13 | 50 | 51 | if ($opts{version}) { | |||
438 | 0 | 0 | require File::Basename; | ||||
439 | 0 | 0 | print File::Basename::basename($0), ' (', __PACKAGE__, ') ', | ||||
440 | __PACKAGE__->VERSION, $/; | ||||||
441 | 0 | 0 | exit; | ||||
442 | } | ||||||
443 | |||||||
444 | # Check required options. | ||||||
445 | 13 | 100 | 28 | if (my @missing = map { | |||
4 | 18 | ||||||
446 | 26 | 79 | ( my $opt = $_ ) =~ s/_/-/g; | ||||
447 | 4 | 17 | "--$opt"; | ||||
448 | } grep { !$opts{$_} } qw(doc_root base_uri)) { | ||||||
449 | 3 | 100 | 11 | my $pl = @missing > 1 ? 's' : ''; | |||
450 | 3 | 4 | my $last = pop @missing; | ||||
451 | 3 | 50 | 11 | my $disp = @missing ? join(', ', @missing) . (@missing > 1 ? ',' : '') | |||
100 | |||||||
452 | . " and $last" : $last; | ||||||
453 | 3 | 19 | $self->_pod2usage( '-message' => "Missing required $disp option$pl" ); | ||||
454 | } | ||||||
455 | |||||||
456 | # Check for one or more module roots. | ||||||
457 | 13 | 100 | 47 | $self->_pod2usage( '-message' => "Missing path to module root" ) | |||
458 | unless @ARGV; | ||||||
459 | |||||||
460 | 13 | 31 | $opts{module_roots} = \@ARGV; | ||||
461 | |||||||
462 | # Modify options and set defaults as appropriate. | ||||||
463 | 13 | 100 | 15 | for (@{ $opts{base_uri} }) { $_ .= '/' unless m{/$}; } | |||
13 | 34 | ||||||
12 | 75 | ||||||
464 | |||||||
465 | 13 | 106 | return \%opts; | ||||
466 | } | ||||||
467 | |||||||
468 | sub _set_mod { | ||||||
469 | 14 | 14 | 22 | my ($mods, $mod, $file) = @_; | |||
470 | 14 | 100 | 41 | if ($mod =~ /::/) { | |||
471 | 10 | 38 | my @names = split /::/ => $mod; | ||||
472 | 10 | 100 | 47 | my $data = $mods->{shift @names} ||= {}; | |||
473 | 10 | 17 | my $lln = pop @names; | ||||
474 | 10 | 50 | 18 | for (@names) { $data = $data->{$_} ||= {} } | |||
4 | 29 | ||||||
475 | 10 | 63 | $data->{"$lln.pm"} = $file; | ||||
476 | } else { | ||||||
477 | 4 | 26 | $mods->{"$mod.pm"} = $file; | ||||
478 | } | ||||||
479 | } | ||||||
480 | |||||||
481 | sub _udent { | ||||||
482 | 8 | 8 | 21 | my $string = shift; | |||
483 | 8 | 137 | $string =~ s/^[ ]{4}//gm; | ||||
484 | 8 | 78 | return $string; | ||||
485 | } | ||||||
486 | |||||||
487 | sub _output_navlink { | ||||||
488 | 14 | 14 | 33 | my ($self, $fh, $key, $fn, $class, $no_link, $desc) = @_; | |||
489 | |||||||
490 | 14 | 66 | 56 | $desc ||= $self->get_desc($class, $fn); | |||
491 | 14 | 50 | 43 | $desc = "—$desc" if $desc; | |||
492 | |||||||
493 | # Output the Tree Browser Link. | ||||||
494 | 14 | 50 | 35 | print "Outputting $class nav link\n" if $self->{verbose} > 2; | |||
495 | 14 | 100 | 59 | print $fh $self->{base_space}, $self->{spacer} x $self->{indent}, | |||
496 | qq{ |
||||||
497 | unless $no_link; | ||||||
498 | |||||||
499 | # Output the TOC link. | ||||||
500 | 14 | 50 | 31 | print "Outputting $class TOC link\n" if $self->{verbose} > 2; | |||
501 | 14 | 15 | print {$self->{toc_fh}} $self->{base_space}, $self->{spacer}, | ||||
14 | 58 | ||||||
502 | qq{ |
||||||
503 | 14 | 43 | return 1; | ||||
504 | } | ||||||
505 | |||||||
506 | sub _find_module { | ||||||
507 | 2 | 2 | 5 | my $self = shift; | |||
508 | 2 | 50 | 11 | my $search = Pod::Site::Search->instance or return; | |||
509 | 2 | 50 | 1156 | my $bins = $self->bin_files || {}; | |||
510 | 2 | 17 | for my $mod (sort { | ||||
28 | 98 | ||||||
511 | 2 | 6 | lc $a cmp lc $b | ||||
512 | } keys %{ $search->instance->name2path }) { | ||||||
513 | 2 | 50 | 76 | return $mod unless $bins->{$mod}; | |||
514 | } | ||||||
515 | } | ||||||
516 | |||||||
517 | ############################################################################## | ||||||
518 | package Pod::Site::Search; | ||||||
519 | |||||||
520 | 4 | 4 | 87 | use base 'Pod::Simple::Search'; | |||
4 | 10 | ||||||
4 | 7442 | ||||||
521 | 4 | 4 | 63721 | use strict; | |||
4 | 12 | ||||||
4 | 123 | ||||||
522 | 4 | 4 | 23 | use warnings; | |||
4 | 9 | ||||||
4 | 750 | ||||||
523 | |||||||
524 | my $instance; | ||||||
525 | 15 | 15 | 75 | sub instance { $instance } | |||
526 | |||||||
527 | sub new { | ||||||
528 | 2 | 2 | 349 | my $self = shift->SUPER::new(@_); | |||
529 | 2 | 113 | $self->laborious(1); | ||||
530 | 2 | 20 | $self->inc(0); | ||||
531 | 2 | 12 | $instance = $self; | ||||
532 | 2 | 38 | return $self; | ||||
533 | } | ||||||
534 | |||||||
535 | ############################################################################## | ||||||
536 | package Pod::Site::XHTML; | ||||||
537 | |||||||
538 | 4 | 4 | 22 | use strict; | |||
4 | 8 | ||||||
4 | 660 | ||||||
539 | 4 | 4 | 37 | use base 'Pod::Simple::XHTML'; | |||
4 | 9 | ||||||
4 | 11140 | ||||||
540 | |||||||
541 | sub new { | ||||||
542 | 14 | 14 | 33598 | my $self = shift->SUPER::new; | |||
543 | 14 | 4562 | $self->index(1); | ||||
544 | |||||||
545 | # Strip leading spaces from verbatim blocks equivalent to the indent of | ||||||
546 | # the first line. | ||||||
547 | $self->strip_verbatim_indent(sub { | ||||||
548 | 14 | 14 | 60183 | my $lines = shift; | |||
549 | 14 | 93 | (my $indent = $lines->[0]) =~ s/\S.*//; | ||||
550 | 14 | 50 | return $indent; | ||||
551 | 14 | 271 | }); | ||||
552 | |||||||
553 | 14 | 197 | return $self; | ||||
554 | } | ||||||
555 | |||||||
556 | sub start_L { | ||||||
557 | 8 | 8 | 23305 | my ($self, $flags) = @_; | |||
558 | 8 | 50 | 59 | my $search = Pod::Site::Search->instance | |||
559 | or return $self->SUPER::start_L($self); | ||||||
560 | 8 | 100 | 44 | my $to = $flags->{to} || ''; | |||
561 | 8 | 100 | 100 | 146 | my $url = $to && $search->name2path->{$to} ? $Pod::Site::BASE_URI . join('/', split /::/ => $to) . '.html' : ''; | ||
562 | 8 | 329 | my $id = $flags->{section}; | ||||
563 | 8 | 100 | 66 | 45 | return $self->SUPER::start_L($flags) unless $url || ($id && !$to); | ||
66 | |||||||
564 | 6 | 100 | 88 | my $rel = $id ? 'subsection' : 'section'; | |||
565 | 6 | 100 | 89 | $url .= '#' . $self->idify($id, 1) if $id; | |||
566 | 6 | 50 | 546 | $to ||= $self->title || $self->default_title || ''; | |||
66 | |||||||
567 | 6 | 143 | $self->{scratch} .= qq{}; | ||||
568 | } | ||||||
569 | |||||||
570 | sub html_header { | ||||||
571 | 70 | 70 | 173924 | my $self = shift; | |||
572 | 70 | 50 | 221 | my $title = $self->force_title || $self->title || $self->default_title || ''; | |||
573 | 70 | 5569 | my $version = Pod::Site->VERSION; | ||||
574 | 70 | 433 | return qq{ | ||||
575 | "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd"> | ||||||
576 | |||||||
577 | |||||||
578 | |||||||
579 | |||||||
580 | |
||||||
581 | |||||||
582 | }; | ||||||
583 | } | ||||||
584 | |||||||
585 | 1; | ||||||
586 | __END__ |