File Coverage

lib/OODoc/Format/Html.pm
Criterion Covered Total %
statement 39 487 8.0
branch 0 270 0.0
condition 0 73 0.0
subroutine 13 63 20.6
pod 30 38 78.9
total 82 931 8.8


]; \n]; \n];
line stmt bran cond sub pod time code
1             # Copyrights 2003-2013 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.00.
5              
6             package OODoc::Format::Html;
7 1     1   1690 use vars '$VERSION';
  1         2  
  1         61  
8             $VERSION = '2.00';
9              
10 1     1   4 use base 'OODoc::Format';
  1         2  
  1         582  
11              
12 1     1   9 use strict;
  1         3  
  1         34  
13 1     1   6 use warnings;
  1         2  
  1         32  
14              
15 1     1   5 use Log::Report 'oodoc';
  1         2  
  1         5  
16 1     1   1436 use OODoc::Template ();
  1         12999  
  1         35  
17              
18 1     1   14 use IO::File ();
  1         3  
  1         23  
19 1     1   7 use File::Spec ();
  1         1  
  1         21  
20 1     1   5 use File::Find qw/find/;
  1         3  
  1         91  
21 1     1   6 use File::Basename qw/basename dirname/;
  1         2  
  1         52  
22 1     1   1148 use File::Copy qw/copy/;
  1         3041  
  1         85  
23 1     1   10 use POSIX qw/strftime/;
  1         3  
  1         12  
24 1     1   81 use List::Util qw/first/;
  1         2  
  1         7363  
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 = $self->{OFH_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;
43             }
44              
45             #-------------------------------------------
46              
47              
48 0 0   0 1   sub manual(;$) {my $s = shift; @_ ? $s->{OFH_manual}=shift : $s->{OFH_manual}}
  0            
49              
50             #-------------------------------------------
51              
52              
53             sub cleanupString($$)
54 0     0 1   { my $self = shift;
55 0           my $text = $self->cleanup(@_);
56 0           $text =~ s!

\s*

!
!gs;

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

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

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

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