File Coverage

lib/OODoc/Format/Html.pm
Criterion Covered Total %
statement 39 490 7.9
branch 0 272 0.0
condition 0 79 0.0
subroutine 13 63 20.6
pod 30 38 78.9
total 82 942 8.7


]; \n]; \n];
line stmt bran cond sub pod time code
1             # Copyrights 2003-2015 by [Mark Overmeer].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.01.
5              
6             package OODoc::Format::Html;
7 1     1   1388 use vars '$VERSION';
  1         2  
  1         47  
8             $VERSION = '2.01';
9              
10 1     1   4 use base 'OODoc::Format';
  1         2  
  1         401  
11              
12 1     1   6 use strict;
  1         2  
  1         20  
13 1     1   4 use warnings;
  1         2  
  1         24  
14              
15 1     1   5 use Log::Report 'oodoc';
  1         2  
  1         3  
16 1     1   1059 use OODoc::Template ();
  1         10791  
  1         25  
17              
18 1     1   9 use IO::File ();
  1         3  
  1         14  
19 1     1   5 use File::Spec ();
  1         2  
  1         20  
20 1     1   4 use File::Find qw/find/;
  1         2  
  1         59  
21 1     1   5 use File::Basename qw/basename dirname/;
  1         3  
  1         47  
22 1     1   871 use File::Copy qw/copy/;
  1         2437  
  1         60  
23 1     1   6 use POSIX qw/strftime/;
  1         1  
  1         9  
24 1     1   59 use List::Util qw/first/;
  1         2  
  1         7612  
25              
26              
27             sub init($)
28 0     0 0   { my ($self, $args) = @_;
29 0 0         $self->SUPER::init($args) or return;
30              
31 0   0       my $html = delete $args->{html_root} || '/';
32 0           $html =~ s! /$ !!x;
33              
34 0           $self->{OFH_html} = $html;
35 0   0       $self->{OFH_jump} = delete $args->{jump_script} || "$html/jump.cgi";
36              
37 0   0       my $meta = delete $args->{html_meta_data} || '';
38 0 0         if(my $ss = $self->{OFH_style} = delete $args->{html_stylesheet})
39 0           { my $base = basename $ss;
40 0           $meta .= qq[];
41             }
42 0           $self->{OFH_meta} = $meta;
43 0           $self;
44             }
45              
46             #-------------------------------------------
47              
48              
49 0 0   0 1   sub manual(;$) {my $s = shift; @_ ? $s->{OFH_manual}=shift : $s->{OFH_manual}}
  0            
50              
51             #-------------------------------------------
52              
53              
54             sub cleanupString($$)
55 0     0 1   { my $self = shift;
56 0           my $text = $self->cleanup(@_);
57 0           $text =~ s!

\s*

!
!gs;

58 0           $text =~ s!\!!g;
59 0           $text;
60             }
61              
62              
63             sub link($$;$)
64 0     0 1   { my ($self, $manual, $object, $text) = @_;
65 0 0         $text = $object->name unless defined $text;
66              
67 0           my $jump;
68 0 0         if($object->isa('OODoc::Manual'))
69 0           { (my $manname = $object->name) =~ s!\:\:!_!g;
70 0           $jump = "$self->{OFH_html}/$manname/index.html";
71             }
72             else
73 0           { (my $manname = $manual->name) =~ s!\:\:!_!g;
74 0           $jump = $self->{OFH_jump}.'?'.$manname.'&'.$object->unique;
75             }
76              
77 0           qq[$text];
78             }
79              
80              
81             sub mark($$)
82 0     0 1   { my ($self, $manual, $id) = @_;
83 0           $manual =~ s/\:\:/_/g;
84 0           $self->{OFH_markers}->print("$id $manual $self->{OFH_filename}\n");
85             }
86              
87              
88             sub createManual($@)
89 0     0 1   { my ($self, %args) = @_;
90 0   0       my $verbose = $args{verbose} || 0;
91 0 0         my $manual = $args{manual} or panic;
92 0   0       my $options = $args{format_options} || [];
93              
94             # Location for the manual page files.
95              
96 0   0       my $template = $args{template} || File::Spec->catdir('html', 'manual');
97 0           my %template = $self->expandTemplate($template, $options);
98              
99 0           (my $manfile = "$manual") =~ s!\:\:!_!g;
100 0           my $dest = File::Spec->catdir($self->workdir, $manfile);
101 0           $self->mkdirhier($dest);
102              
103             # File to trace markers must be open.
104              
105 0 0         unless(defined $self->{OFH_markers})
106 0           { my $markers = File::Spec->catdir($self->workdir, 'markers');
107 0 0         my $mark = IO::File->new($markers, 'w')
108             or fault __x"cannot write markers to {fn}", fn => $markers;
109 0           $self->{OFH_markers} = $mark;
110 0           $mark->print($self->{OFH_html}, "\n");
111             }
112              
113             #
114             # Process template
115             #
116              
117 0           my $manifest = $self->manifest;
118 0           while(my($raw, $options) = each %template)
119 0           { my $cooked = File::Spec->catfile($dest, basename $raw);
120              
121 0 0         print "$manual: $cooked\n" if $verbose > 2;
122 0           $manifest->add($cooked);
123              
124 0 0         my $output = IO::File->new($cooked, 'w')
125             or fault __x"cannot write html manual to {fn}", fn => $cooked;
126              
127 0           $self->{OFH_filename} = basename $raw;
128              
129 0           $self->manual($manual);
130 0           $self->format
131             ( output => $output
132             , template_fn => $raw
133             , @$options
134             );
135 0           $self->manual(undef);
136 0           $output->close;
137             }
138              
139 0           delete $self->{OFH_filename};
140 0           $self;
141             }
142              
143              
144             sub createOtherPages(@)
145 0     0 1   { my ($self, %args) = @_;
146              
147 0   0       my $verbose = $args{verbose} || 0;
148              
149             #
150             # Collect files to be processed
151             #
152            
153 0           my $source = $args{source};
154 0 0         if(defined $source)
155 0 0         { -d $source
156             or fault __x"html source directory {dir}", dir => $source;
157             }
158             else
159 0           { $source = File::Spec->catdir("html", "other");
160 0 0         -d $source or return $self;
161             }
162              
163 0   0       my $process = $args{process} || qr/\.(s?html|cgi)$/;
164              
165 0           my $dest = $self->workdir;
166 0           $self->mkdirhier($dest);
167              
168 0           my @sources;
169             find( { no_chdir => 1
170 0     0     , wanted => sub { my $fn = $File::Find::name;
171 0 0         push @sources, $fn if -f $fn;
172             }
173 0           }, $source
174             );
175              
176             #
177             # Process files, one after the other
178             #
179              
180 0           my $manifest = $self->manifest;
181 0           foreach my $raw (@sources)
182 0           { (my $cooked = $raw) =~ s/\Q$source\E/$dest/;
183              
184 0 0         print "create $cooked\n" if $verbose > 2;
185 0           $manifest->add($cooked);
186              
187 0 0         if($raw =~ $process)
188 0           { $self->mkdirhier(dirname $cooked);
189 0 0         my $output = IO::File->new($cooked, 'w')
190             or fault __x"cannot write html to {fn}", fn => $cooked;
191              
192 0           my $options = [];
193 0           $self->format
194             ( manual => undef
195             , output => $output
196             , template_fn => $raw
197             , @$options
198             );
199 0           $output->close;
200             }
201             else
202 0 0         { copy($raw, $cooked)
203             or fault __x"copy from {from} to {to} failed"
204             , from => $raw, to => $cooked;
205             }
206              
207 0           my $rawmode = (stat $raw)[2] & 07777;
208 0 0         chmod $rawmode, $cooked
209             or fault __x"chmod of {fn} to {mode%o} failed"
210             , fn => $cooked, mode => $rawmode;
211             }
212              
213 0           $self;
214             }
215              
216            
217             sub expandTemplate($$)
218 0     0 1   { my $self = shift;
219 0   0       my $loc = shift || panic;
220 0   0       my $defaults = shift || [];
221              
222 0           my @result;
223 0 0         if(ref $loc eq 'HASH')
    0          
    0          
224 0           { foreach my $n (keys %$loc)
225 0           { my %options = (@$defaults, @{$loc->{$n}});
  0            
226 0           push @result, $self->expandTemplate($n, [ %options ])
227             }
228             }
229             elsif(-d $loc)
230             { find( { no_chdir => 1,
231 0     0     wanted => sub { my $fn = $File::Find::name;
232 0 0         push @result, $fn, $defaults
233             if -f $fn;
234             }
235 0           }, $loc
236             );
237             }
238 0           elsif(-f $loc) { push @result, $loc => $defaults }
239 0           else { error __x"cannot find template source '{name}'", name => $loc }
240              
241 0           @result;
242             }
243              
244             sub showStructureExpand(@)
245 0     0 0   { my ($self, %args) = @_;
246              
247 0   0       my $examples = $args{show_chapter_examples} || 'EXPAND';
248 0 0         my $text = $args{structure} or panic;
249              
250 0           my $name = $text->name;
251 0           my $level = $text->level +1; # header level, chapter = H2
252 0 0         my $output = $args{output} or panic;
253 0 0         my $manual = $args{manual} or panic;
254              
255             # Produce own chapter description
256              
257 0           my $descr = $self->cleanup($manual, $text->description);
258 0           my $unique = $text->unique;
259 0           (my $id = $name) =~ s/\W+/_/g;
260              
261 0           $output->print(
262             qq[\n$name\n$descr]
263             );
264              
265 0           $self->mark($manual, $unique);
266              
267             # Link to inherited documentation.
268              
269 0           my $super = $text;
270 0           while($super = $super->extends)
271 0 0         { last if $super->description !~ m/^\s*$/;
272             }
273              
274 0 0         if(defined $super)
275 0           { my $superman = $super->manual; # :-)
276 0           $output->print( "

See ", $self->link($superman, $super), " in "

277             , $self->link(undef, $superman), "

\n");
278             }
279              
280             # Show the subroutines and examples.
281              
282 0           $self->showSubroutines(%args, subroutines => [$text->subroutines]);
283 0 0         $self->showExamples(%args, examples => [$text->examples])
284             if $examples eq 'EXPAND';
285              
286 0           $self;
287             }
288              
289             sub showStructureRefer(@)
290 0     0 1   { my ($self, %args) = @_;
291              
292 0 0         my $text = $args{structure} or panic;
293 0           my $name = $text->name;
294 0           my $level = $text->level;
295              
296 0 0         my $output = $args{output} or panic;
297 0 0         my $manual = $args{manual} or panic;
298              
299 0           my $link = $self->link($manual, $text);
300 0           $output->print(
301             qq[\n$name\n]);
302 0           $self;
303             }
304              
305             sub chapterDiagnostics(@)
306 0     0 0   { my ($self, %args) = @_;
307              
308 0 0         my $manual = $args{manual} or panic;
309 0           my $diags = $manual->chapter('DIAGNOSTICS');
310              
311 0           my @diags = map {$_->diagnostics} $manual->subroutines;
  0            
312 0 0 0       $diags = OODoc::Text::Chapter->new(name => 'DIAGNOSTICS')
313             if !$diags && @diags;
314              
315 0 0         return unless $diags;
316              
317 0 0         $self->showChapter(chapter => $diags, %args)
318             if defined $diags;
319              
320 0           $self->showDiagnostics(%args, diagnostics => \@diags);
321 0           $self;
322             }
323              
324             sub showExamples(@)
325 0     0 1   { my ($self, %args) = @_;
326 0 0         my $examples = $args{examples} or panic;
327 0 0         return unless @$examples;
328              
329 0 0         my $manual = $args{manual} or panic;
330 0 0         my $output = $args{output} or panic;
331              
332 0           $output->print( qq[
\n] );
333              
334 0           foreach my $example (@$examples)
335 0           { my $name = $example->name;
336 0           my $descr = $self->cleanup($manual, $example->description);
337 0           my $unique = $example->unique;
338 0           $output->print( <
339            
» Example: $name
340            
$descr
341             EXAMPLE
342              
343 0           $self->mark($manual, $unique);
344             }
345 0           $output->print( qq[\n] );
346              
347 0           $self;
348             }
349              
350             sub showDiagnostics(@)
351 0     0 0   { my ($self, %args) = @_;
352 0 0         my $diagnostics = $args{diagnostics} or panic;
353 0 0         return unless @$diagnostics;
354              
355 0 0         my $manual = $args{manual} or panic;
356 0 0         my $output = $args{output} or panic;
357              
358 0           $output->print( qq[
\n] );
359              
360 0           foreach my $diag (sort @$diagnostics)
361 0           { my $name = $diag->name;
362 0           my $type = $diag->type;
363 0           my $text = $self->cleanup($manual, $diag->description);
364 0           my $unique = $diag->unique;
365              
366 0           $output->print( <
367            
» $type: $name
368            
$text
369             DIAG
370              
371 0           $self->mark($manual, $unique);
372             }
373              
374 0           $output->print( qq[\n] );
375 0           $self;
376             }
377              
378             sub showSubroutine(@)
379 0     0 1   { my $self = shift;
380 0           my %args = @_;
381 0 0         my $output = $args{output} or panic;
382 0 0         my $sub = $args{subroutine} or panic;
383 0           my $type = $sub->type;
384 0           my $name = $sub->name;
385              
386 0           $self->SUPER::showSubroutine(@_);
387              
388 0           $output->print( qq[\n\n\n] );
389 0           $self;
390             }
391              
392             sub showSubroutineUse(@)
393 0     0 1   { my ($self, %args) = @_;
394 0 0         my $subroutine = $args{subroutine} or panic;
395 0 0         my $manual = $args{manual} or panic;
396 0 0         my $output = $args{output} or panic;
397              
398 0           my $type = $subroutine->type;
399 0           my $name = $self->cleanupString($manual, $subroutine->name);
400 0           my $paramlist = $self->cleanupString($manual, $subroutine->parameters);
401 0           my $unique = $subroutine->unique;
402              
403 0           my $class = $manual->package;
404              
405 0           my $call = qq[$name];
406 0 0         $call .= "( $paramlist )" if length $paramlist;
407 0           $self->mark($manual, $unique);
408              
409 0 0         my $use
    0          
    0          
    0          
    0          
    0          
410             = $type eq 'i_method' ? qq[\$obj->$call]
411             : $type eq 'c_method' ? qq[\$class->$call]
412             : $type eq 'ci_method'? qq[\$obj->$call
\$class->$call]
413             : $type eq 'overload' ? qq[overload: $call]
414             : $type eq 'function' ? qq[$call]
415             : $type eq 'tie' ? $call
416             : warning("unknown subroutine type {type} for {name} in {manual}"
417             , type => $type, name => $name, manual => $manual);
418              
419 0           $output->print( <
420            
421            
422            
$use
423            
424             SUBROUTINE
425              
426 0 0         if($manual->inherited($subroutine))
427 0           { my $defd = $subroutine->manual;
428 0           my $sublink = $self->link($defd, $subroutine, $name);
429 0           my $manlink = $self->link($manual, $defd);
430 0           $output->print( qq[See $sublink in $manlink.
\n] );
431             }
432 0           $self;
433             }
434              
435             sub showSubsIndex(@)
436 0     0 0   { my ($self, %args) = @_;
437 0 0         my $output = $args{output} or panic;
438             }
439              
440             sub showSubroutineName(@)
441 0     0 1   { my ($self, %args) = @_;
442 0 0         my $subroutine = $args{subroutine} or panic;
443 0 0         my $manual = $args{manual} or panic;
444 0 0         my $output = $args{output} or panic;
445 0           my $name = $subroutine->name;
446              
447 0 0         my $url
448             = $manual->inherited($subroutine)
449             ? "M<".$subroutine->manual."::$name>"
450             : "M<$name>";
451              
452             $output->print
453             ( $self->cleanupString($manual, $url)
454 0 0         , ($args{last} ? ".\n" : ",\n")
455             );
456             }
457              
458             sub showOptions(@)
459 0     0 1   { my $self = shift;
460 0           my %args = @_;
461 0 0         my $output = $args{output} or panic;
462 0           $output->print( qq[
\n] );
463              
464 0           $self->SUPER::showOptions(@_);
465              
466 0           $output->print( qq[\n] );
467 0           $self;
468             }
469              
470             sub showOptionUse(@)
471 0     0 1   { my ($self, %args) = @_;
472 0 0         my $output = $args{output} or panic;
473 0 0         my $option = $args{option} or panic;
474 0 0         my $manual = $args{manual} or panic;
475              
476 0           my $params = $self->cleanupString($manual, $option->parameters);
477 0           $params =~ s/\s+$//;
478 0           $params =~ s/^\s+//;
479 0 0         $params = qq[ => $params]
480             if length $params;
481            
482 0           my $use = qq[$option];
483 0           $output->print( qq[
$use$params
\n] );
484 0           $self;
485             }
486              
487             sub showOptionExpand(@)
488 0     0 1   { my ($self, %args) = @_;
489 0 0         my $output = $args{output} or panic;
490 0 0         my $option = $args{option} or panic;
491 0 0         my $manual = $args{manual} or panic;
492              
493 0           $self->showOptionUse(%args);
494              
495 0 0         my $where = $option->findDescriptionObject or return $self;
496 0           my $descr = $self->cleanupString($manual, $where->description);
497              
498 0 0         $output->print( qq[
$descr
\n] )
499             if length $descr;
500              
501 0           $self;
502             }
503              
504              
505             sub writeTable($@)
506 0     0 1   { my ($self, %args) = @_;
507              
508 0 0         my $rows = $args{rows} or panic;
509 0 0         return unless @$rows;
510              
511 0 0         my $head = $args{header} or panic;
512 0 0         my $output = $args{output} or panic;
513              
514 0           $output->print( qq[\n] ); \n] ); \n] )
515              
516 0           local $" = qq[ ];
517 0           $output->print( qq[
@$head
518              
519 0           local $" = qq[ ];
520             $output->print( qq[
@$_
521 0           foreach @$rows;
522              
523 0           $output->print( qq[
\n] );
524 0           $self;
525             }
526              
527             sub showSubroutineDescription(@)
528 0     0 1   { my ($self, %args) = @_;
529 0 0         my $manual = $args{manual} or panic;
530 0 0         my $subroutine = $args{subroutine} or panic;
531              
532 0           my $text = $self->cleanup($manual, $subroutine->description);
533 0 0         return $self unless length $text;
534              
535 0 0         my $output = $args{output} or panic;
536 0           $output->print($text);
537              
538 0 0         my $extends = $self->extends or return $self;
539 0 0         my $refer = $extends->findDescriptionObject or return $self;
540              
541 0           $output->print("
\n");
542 0           $self->showSubroutineDescriptionRefer(%args, subroutine => $refer);
543             }
544              
545             sub showSubroutineDescriptionRefer(@)
546 0     0 0   { my ($self, %args) = @_;
547 0 0         my $manual = $args{manual} or panic;
548 0 0         my $subroutine = $args{subroutine} or panic;
549 0 0         my $output = $args{output} or panic;
550 0           $output->print("\nSee ", $self->link($manual, $subroutine), "\n");
551             }
552              
553             #----------------------
554              
555              
556             our %producers =
557             ( a => 'templateHref'
558             , chapter => 'templateChapter'
559             , date => 'templateDate'
560             , index => 'templateIndex'
561             , inheritance => 'templateInheritance'
562             , list => 'templateList'
563             , manual => 'templateManual'
564             , meta => 'templateMeta'
565             , distribution=> 'templateDistribution'
566             , name => 'templateName'
567             , project => 'templateProject'
568             , title => 'templateTitle'
569             , version => 'templateVersion'
570             );
571            
572             sub format(@)
573 0     0 1   { my ($self, %args) = @_;
574 0           my $output = delete $args{output};
575              
576 0           my %permitted = %args;
577 0           my $template = OODoc::Template->new;
578 0           while(my ($tag, $method) = each %producers)
579             { $permitted{$tag} = sub
580             { # my ($istag, $attrs, $ifblock, $elseblock) = @_;
581 0     0     shift;
582 0           $self->$method($template, @_)
583 0           };
584             }
585              
586             $output->print(
587 0           scalar $template->processFile($args{template_fn}, \%permitted));
588             }
589              
590              
591             sub templateProject($$)
592 0     0 0   { my ($self, $templ, $attrs, $if, $else) = @_;
593 0           $self->project;
594             }
595              
596              
597             sub templateTitle($$)
598 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
599              
600 0 0         my $manual = $self->manual
601             or error __x"not a manual, so no automatic title in {fn}"
602             , fn => scalar $templ->valueFor('template_fn');
603              
604 0           my $name = $self->cleanupString($manual, $manual->name);
605 0           $name =~ s/\<[^>]*\>//g;
606 0           $name;
607             }
608              
609              
610             sub templateManual($$)
611 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
612              
613 0 0         my $manual = $self->manual
614             or error __x"not a manual, so no manual name for {fn}"
615             , fn => scalar $templ->valueFor('template_fn');
616              
617 0           $self->cleanupString($manual, $manual->name);
618             }
619              
620              
621             sub templateDistribution($$)
622 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
623 0           my $manual = $self->manual;
624 0 0         defined $manual ? $manual->distribution : '';
625             }
626              
627              
628             sub templateVersion($$)
629 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
630 0           my $manual = $self->manual;
631 0 0         defined $manual ? $manual->version : $self->version;
632             }
633              
634              
635             sub templateDate($$)
636 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
637 0           strftime "%Y/%m/%d", localtime;
638             }
639              
640              
641             sub templateName($$)
642 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
643              
644 0 0         my $manual = $self->manual
645             or error __x"not a manual, so no name for {fn}"
646             , fn => scalar $templ->valueFor('template_fn');
647              
648 0 0         my $chapter = $manual->chapter('NAME')
649             or error __x"cannot find chapter NAME in manual {fn}", $manual->source;
650              
651 0           my $descr = $chapter->description;
652              
653 0 0         return $1 if $descr =~ m/^ \s*\S+\s*\-\s*(.*?)\s* $ /x;
654              
655 0           error __x"chapter NAME in manual {manual} has illegal shape"
656             , manual => $manual;
657             }
658              
659              
660             our %path_lookup =
661             ( front => "/index.html"
662             , manuals => "/manuals/index.html"
663             , methods => "/methods/index.html"
664             , diagnostics => "/diagnostics/index.html"
665             , details => "/details/index.html"
666             );
667              
668             sub templateHref($$)
669 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
670 0   0       my $window = delete $attrs->{window} || '_top';
671 0 0         keys %$attrs==1
672             or error __x"expect one name with 'a'";
673 0           (my $to) = keys %$attrs;
674              
675 0 0         my $path = $path_lookup{$to}
676             or error __x"missing path for {dest}", dest => $to;
677              
678 0           qq[];
679             }
680              
681              
682             sub templateMeta($$)
683 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
684 0           $self->{OFH_meta};
685             }
686              
687              
688             sub templateInheritance(@)
689 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
690              
691 0           my $manual = $self->manual;
692 0 0         my $chapter = $manual->chapter('INHERITANCE')
693             or return '';
694              
695 0           my $buffer = '';
696 0           open my $out, '>', \$buffer;
697 0           $self->showChapter
698             ( %$attrs
699             , manual => $self->manual
700             , chapter => $chapter
701             , output => $out
702             );
703 0           close $out;
704              
705 0           for($buffer)
706 0           { s#\\s*(.*?)\\n*#\n$1#gs; # over-eager cleanup
707 0           s#^( +)#' ' x length($1)#gme;
  0            
708 0           s# $ #
#gmx;
709 0           s#(\)(\\n?)+#$1\n#;
710             }
711              
712 0           $buffer;
713             }
714              
715              
716             sub templateChapter($$)
717 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
718 0 0 0       warning __x"no meaning for container {c} in chapter block", c => $if
719             if defined $if && length $if;
720              
721 0     0     my $name = first { !/[a-z]/ } keys %$attrs;
  0            
722 0 0         defined $name
723             or error __x"chapter without name in template {fn}"
724             , fn => scalar $templ->valueFor('template_fn');
725              
726 0           my $manual = $self->manual;
727 0 0         defined $manual or panic;
728 0 0         my $chapter = $manual->chapter($name) or return '';
729              
730 0           my $buffer = '';
731 0           open my $out, '>', \$buffer;
732 0           $self->showChapter
733             ( %$attrs
734             , manual => $self->manual
735             , chapter => $chapter
736             , output => $out
737             );
738 0           close $out;
739              
740 0           $buffer;
741             }
742              
743              
744             sub templateIndex($$)
745 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
746              
747 0 0 0       warning __x"no meaning for container {c} in list block", c => $if
748             if defined $if && length $if;
749              
750 0     0     my $group = first { !/[a-z]/ } keys %$attrs;
  0            
751 0 0         defined $group
752             or error __x"no group named as attribute for list";
753              
754 0   0       my $start = $attrs->{starting_with} || 'ALL';
755 0   0       my $types = $attrs->{type} || 'ALL';
756              
757 0     0     my $select = sub { @_ };
  0            
758 0 0         unless($start eq 'ALL')
759 0           { $start =~ s/_/[\\W_]/g;
760 0           my $regexp = qr/^$start/i;
761 0     0     $select = sub { grep $_->name =~ $regexp, @_ };
  0            
762             }
763 0 0         unless($types eq 'ALL')
764 0 0         { my @take = map { $_ eq 'method' ? '.*method' : $_ }
  0            
765             split /[_|]/, $types;
766 0           local $" = ')|(';
767 0           my $regexp = qr/^(@take)$/i;
768 0           my $before = $select;
769 0     0     $select = sub { grep $_->type =~ $regexp, $before->(@_) };
  0            
770             }
771              
772 0   0       my $columns = $attrs->{table_columns} || 2;
773 0           my @rows;
774              
775 0 0         if($group eq 'SUBROUTINES')
    0          
    0          
    0          
776 0           { my @subs;
777              
778 0           foreach my $manual ($self->manuals)
779 0           { foreach my $sub ($select->($manual->ownSubroutines))
780 0           { my $linksub = $self->link($manual, $sub, $sub->name);
781 0           my $linkman = $self->link(undef, $manual, $manual->name);
782 0           my $link = "$linksub -- $linkman";
783 0           push @subs, [ lc("$sub-$manual"), $link ];
784             }
785             }
786              
787 0           @rows = map { $_->[1] }
788 0           sort { $a->[0] cmp $b->[0] } @subs;
  0            
789             }
790             elsif($group eq 'DIAGNOSTICS')
791 0           { foreach my $manual ($self->manuals)
792 0           { foreach my $sub ($manual->ownSubroutines)
793 0 0         { my @diags = $select->($sub->diagnostics) or next;
794              
795 0           my $linksub = $self->link($manual, $sub, $sub->name);
796 0           my $linkman = $self->link(undef, $manual, $manual->name);
797              
798 0           foreach my $diag (@diags)
799 0           { my $type = uc($diag->type);
800 0           push @rows, <<"DIAG";
801             $type: $diag
802             · $linksub in $linkman
803             DIAG
804             }
805             }
806             }
807              
808 0           @rows = sort @rows;
809             }
810             elsif($group eq 'DETAILS')
811 0           { foreach my $manual (sort $select->($self->manuals))
812 0 0         { my $details = $manual->chapter("DETAILS") or next;
813 0           my @sections;
814 0           foreach my $section ($details->sections)
815 0   0       { my @subsect = grep !$manual->inherited($_) && $_->description
816             , $section->subsections;
817 0 0 0       push @sections, $section
818             if @subsect || $section->description;
819             }
820              
821 0 0 0       @sections || length $details->description
822             or next;
823              
824             my $sections = join "\n"
825 0           , map { "
  • ".$self->link($manual, $_)."
  • " }
      0            
    826             @sections;
    827              
    828 0           push @rows, $self->link($manual, $details, "Details in $manual")
    829             . qq[\n
      \n$sections
    \n]
    830             }
    831             }
    832             elsif($group eq 'MANUALS')
    833 0           { @rows = map $self->link(undef, $_, $_->name)
    834             , sort $select->($self->manuals);
    835             }
    836             else
    837 0           { error __x"unknown group {name} as list attribute", name => $group;
    838             }
    839              
    840 0           push @rows, ('') x ($columns-1);
    841 0           my $rows = int(@rows/$columns);
    842              
    843 0           my $output = qq[
    844 0           while(@rows >= $columns)
    845 0           { $output .= qq[]
    846             . join( "
    \n", splice(@rows, 0, $rows))
    847             . qq[
    848             }
    849 0           $output .= qq[
    850 0           $output;
    851             }
    852              
    853              
    854             sub templateList($$)
    855 0     0 1   { my ($self, $templ, $attrs, $if, $else) = @_;
    856 0 0 0       warning __x"no meaning for container {c} in index block", c => $if
    857             if defined $if && length $if;
    858              
    859 0     0     my $group = first { !/[a-z]/ } keys %$attrs;
      0            
    860 0 0         defined $group
    861             or error __x"no group named as attribute for list";
    862              
    863 0   0       my $show_sub = $attrs->{show_subroutines} || 'LIST';
    864 0   0       my $types = $attrs->{subroutine_types} || 'ALL';
    865 0 0         my $manual = $self->manual or panic;
    866 0           my $output = '';
    867              
    868 0     0     my $selected = sub { @_ };
      0            
    869 0 0         unless($types eq 'ALL')
    870 0 0         { my @take = map { $_ eq 'method' ? '.*method' : $_ }
      0            
    871             split /[_|]/, $types;
    872 0           local $" = ')|(?:';
    873 0           my $regexp = qr/^(?:@take)$/;
    874 0     0     $selected = sub { grep $_->type =~ $regexp, @_ };
      0            
    875             }
    876              
    877 0     0     my $sorted = sub { sort {$a->name cmp $b->name} @_ };
      0            
      0            
    878              
    879 0 0         if($group eq 'ALL')
    880 0           { my @subs = $sorted->($selected->($manual->subroutines));
    881 0 0 0       if(!@subs || $show_sub eq 'NO') { ; }
        0          
    882 0           elsif($show_sub eq 'COUNT') { $output .= @subs }
    883             else
    884 0           { $output .= $self->indexListSubroutines($manual,@subs);
    885             }
    886             }
    887             else # any chapter
    888 0 0         { my $chapter = $manual->chapter($group) or return '';
    889 0   0       my $show_sec = $attrs->{show_sections} || 'LINK';
    890 0 0         my @sections = $show_sec eq 'NO' ? () : $chapter->sections;
    891              
    892 0 0         my @subs = $sorted->($selected->( @sections
    893             ? $chapter->subroutines
    894             : $chapter->all('subroutines')
    895             )
    896             );
    897              
    898 0           $output .= $self->link($manual, $chapter, $chapter->niceName);
    899 0 0 0       my $count = @subs && $show_sub eq 'COUNT' ? ' ('.@subs.')' : '';
    900              
    901 0 0 0       if($show_sec eq 'NO') { $output .= qq[$count
    \n] }
      0 0          
    902             elsif($show_sec eq 'LINK' || $show_sec eq 'NAME')
    903 0           { $output .= qq[
    \n
      \n];
    904 0 0         if(!@subs) {;}
        0          
        0          
    905             elsif($show_sec eq 'LINK')
    906 0           { my $link = $self->link($manual, $chapter, 'unsorted');
    907 0           $output .= qq[
  • $link$count\n];
  • 908             }
    909             elsif($show_sec eq 'NAME')
    910 0           { $output .= qq[
  • ];
  • 911             }
    912              
    913 0 0 0       $output .= $self->indexListSubroutines($manual,@subs)
    914             if @subs && $show_sub eq 'LIST';
    915             }
    916             else
    917 0           { error __x"illegal value to show_sections: {v}", v => $show_sec;
    918             }
    919            
    920             # All sections within the chapter (if show_sec is enabled)
    921              
    922 0           foreach my $section (@sections)
    923 0           { my @subs = $sorted->($selected->($section->all('subroutines')));
    924              
    925 0 0         my $count = ! @subs ? ''
        0          
    926             : $show_sub eq 'COUNT' ? ' ('.@subs.')'
    927             : ': ';
    928              
    929 0 0         if($show_sec eq 'LINK')
    930 0           { my $link = $self->link($manual, $section, $section->niceName);
    931 0           $output .= qq[
  • $link$count\n];
  • 932             }
    933             else
    934 0           { $output .= qq[
  • $section$count\n];
  • 935             }
    936              
    937 0 0 0       $output .= $self->indexListSubroutines($manual,@subs)
    938             if $show_sub eq 'LIST' && @subs;
    939              
    940 0           $output .= qq[\n];
    941             }
    942              
    943 0 0 0       $output .= qq[\n]
    944             if $show_sec eq 'LINK' || $show_sec eq 'NAME';
    945             }
    946              
    947 0           $output;
    948             }
    949              
    950             sub indexListSubroutines(@)
    951 0     0 0   { my $self = shift;
    952 0           my $manual = shift;
    953            
    954             join ",\n"
    955 0           , map { $self->link($manual, $_, $_) }
      0            
    956             @_;
    957             }
    958              
    959             #-------------------------------------------
    960              
    961              
    962             1;