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-2021 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.02.
5             # This code is part of perl distribution OODoc. It is licensed under the
6             # same terms as Perl itself: https://spdx.org/licenses/Artistic-2.0.html
7              
8             package OODoc::Format::Html;
9 1     1   1570 use vars '$VERSION';
  1         2  
  1         52  
10             $VERSION = '2.02';
11              
12 1     1   6 use base 'OODoc::Format';
  1         3  
  1         442  
13              
14 1     1   17 use strict;
  1         2  
  1         18  
15 1     1   6 use warnings;
  1         2  
  1         24  
16              
17 1     1   4 use Log::Report 'oodoc';
  1         10  
  1         3  
18 1     1   793 use OODoc::Template ();
  1         11262  
  1         35  
19              
20 1     1   6 use IO::File ();
  1         2  
  1         20  
21 1     1   4 use File::Spec ();
  1         3  
  1         23  
22 1     1   4 use File::Find qw/find/;
  1         2  
  1         64  
23 1     1   6 use File::Basename qw/basename dirname/;
  1         2  
  1         50  
24 1     1   571 use File::Copy qw/copy/;
  1         2732  
  1         58  
25 1     1   10 use POSIX qw/strftime/;
  1         2  
  1         10  
26 1     1   77 use List::Util qw/first/;
  1         2  
  1         7729  
27              
28              
29             sub init($)
30 0     0 0   { my ($self, $args) = @_;
31 0 0         $self->SUPER::init($args) or return;
32              
33 0   0       my $html = delete $args->{html_root} || '/';
34 0           $html =~ s! /$ !!x;
35              
36 0           $self->{OFH_html} = $html;
37 0   0       $self->{OFH_jump} = delete $args->{jump_script} || "$html/jump.cgi";
38              
39 0   0       my $meta = delete $args->{html_meta_data} || '';
40 0 0         if(my $ss = $self->{OFH_style} = delete $args->{html_stylesheet})
41 0           { my $base = basename $ss;
42 0           $meta .= qq[];
43             }
44 0           $self->{OFH_meta} = $meta;
45 0           $self;
46             }
47              
48             #-------------------------------------------
49              
50              
51 0 0   0 1   sub manual(;$) {my $s = shift; @_ ? $s->{OFH_manual}=shift : $s->{OFH_manual}}
  0            
52              
53             #-------------------------------------------
54              
55              
56             sub cleanupString($$)
57 0     0 1   { my $self = shift;
58 0           my $text = $self->cleanup(@_);
59 0           $text =~ s!

\s*

!
!gs;

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

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

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

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