File Coverage

lib/OODoc/Manual.pm
Criterion Covered Total %
statement 33 292 11.3
branch 0 100 0.0
condition 0 27 0.0
subroutine 11 52 21.1
pod 29 31 93.5
total 73 502 14.5


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::Manual;
7 1     1   5 use vars '$VERSION';
  1         2  
  1         44  
8             $VERSION = '2.01';
9              
10 1     1   5 use base 'OODoc::Object';
  1         2  
  1         61  
11              
12 1     1   5 use strict;
  1         1  
  1         24  
13 1     1   5 use warnings;
  1         1  
  1         37  
14              
15 1     1   4 use Log::Report 'oodoc';
  1         2  
  1         6  
16              
17 1     1   229 use OODoc::Text::Chapter;
  1         2  
  1         27  
18              
19 1     1   5 use List::Util 'first';
  1         2  
  1         70  
20              
21              
22 1     1   4 use overload '""' => sub { shift->name };
  1     0   2  
  1         9  
  0         0  
23 1     1   67 use overload bool => sub {1};
  1     0   1  
  1         10  
  0         0  
24              
25              
26 1     1   75 use overload cmp => sub {$_[0]->name cmp "$_[1]"};
  1     0   2  
  1         80  
  0         0  
27              
28             #-------------------------------------------
29              
30              
31             sub init($)
32 0     0 0   { my ($self, $args) = @_;
33 0 0         $self->SUPER::init($args) or return;
34              
35             my $name = $self->{OP_package} = delete $args->{package}
36 0 0         or error __x"package name is not specified";
37              
38             $self->{OP_source} = delete $args->{source}
39 0 0         or error __x"no source is specified for manual {name}", name => $name;
40              
41             $self->{OP_version} = delete $args->{version}
42 0 0         or error __x"no version is specified for manual {name}", name => $name;
43              
44             $self->{OP_distr} = delete $args->{distribution}
45 0 0         or error __x"no distribution specified for manual {name}", name=> $name;
46              
47 0 0         $self->{OP_parser} = delete $args->{parser} or panic;
48 0           $self->{OP_stripped} = delete $args->{stripped};
49              
50 0   0       $self->{OP_pure_pod} = delete $args->{pure_pod} || 0;
51 0           $self->{OP_chapter_hash} = {};
52 0           $self->{OP_chapters} = [];
53 0           $self->{OP_subclasses} = [];
54 0           $self->{OP_realizers} = [];
55 0           $self->{OP_extra_code} = [];
56              
57 0           $self;
58             }
59              
60             #-------------------------------------------
61              
62              
63 0     0 1   sub package() {shift->{OP_package}}
64              
65              
66 0     0 1   sub parser() {shift->{OP_parser}}
67              
68              
69 0     0 1   sub source() {shift->{OP_source}}
70              
71              
72 0     0 1   sub version() {shift->{OP_version}}
73              
74              
75 0     0 1   sub distribution() {shift->{OP_distr}}
76              
77              
78 0     0 1   sub stripped() {shift->{OP_stripped}}
79              
80              
81 0     0 1   sub isPurePod() {shift->{OP_pure_pod}}
82              
83             #-------------------------------------------
84              
85              
86             sub chapter($)
87 0     0 1   { my ($self, $it) = @_;
88 0 0         $it or return;
89              
90             ref $it
91 0 0         or return $self->{OP_chapter_hash}{$it};
92              
93 0 0         $it->isa("OODoc::Text::Chapter")
94             or panic "$it is not a chapter";
95              
96 0           my $name = $it->name;
97 0 0         if(my $old = $self->{OP_chapter_hash}{$name})
98 0           { my ($fn, $ln2) = $it->where;
99 0           my ($fn2, $ln1) = $old->where;
100 0           error __x"two chapters named {name} in {file} line {line1} and {line2}"
101             , name => $name, file => $fn, line1 => $ln2, line2 => $ln1;
102             }
103              
104 0           $self->{OP_chapter_hash}{$name} = $it;
105 0           push @{$self->{OP_chapters}}, $it;
  0            
106 0           $it;
107             }
108              
109              
110             sub chapters(@)
111 0     0 1   { my $self = shift;
112 0 0         if(@_)
113 0           { $self->{OP_chapters} = [ @_ ];
114 0           $self->{OP_chapter_hash} = { map { ($_->name => $_) } @_ };
  0            
115             }
116 0           @{$self->{OP_chapters}};
  0            
117             }
118              
119              
120             sub name()
121 0     0 1   { my $self = shift;
122 0 0         return $self->{OP_name} if defined $self->{OP_name};
123              
124 0 0         my $chapter = $self->chapter('NAME')
125             or error __x"no chapter NAME in scope of package {pkg} in file {file}"
126             , pkg => $self->package, file => $self->source;
127              
128 0   0       my $text = $chapter->description || '';
129 0 0         $text =~ m/^\s*(\S+)\s*\-\s/
130             or error __x"the NAME chapter does not have the right format in {file}"
131             , file => $self->source;
132              
133 0           $self->{OP_name} = $1;
134             }
135              
136              
137              
138 0     0 1   sub subroutines() { shift->all('subroutines') }
139              
140              
141             sub subroutine($)
142 0     0 1   { my ($self, $name) = @_;
143 0           my $sub;
144              
145 0           my $package = $self->package;
146 0 0         my @parts = defined $package ? $self->manualsForPackage($package) : $self;
147              
148 0           foreach my $part (@parts)
149 0           { foreach my $chapter ($part->chapters)
150 0     0     { $sub = first {defined $_} $chapter->all(subroutine => $name);
  0            
151 0 0         return $sub if defined $sub;
152             }
153             }
154              
155 0           ();
156             }
157              
158              
159             sub examples()
160 0     0 1   { my $self = shift;
161             ( $self->all('examples')
162 0           , map {$_->examples} $self->subroutines
  0            
163             );
164             }
165              
166              
167             sub diagnostics(@)
168 0     0 1   { my ($self, %args) = @_;
169 0 0         my @select = $args{select} ? @{$args{select}} : ();
  0            
170              
171 0           my @diag = map {$_->diagnostics} $self->subroutines;
  0            
172 0 0         return @diag unless @select;
173              
174 0           my $select;
175 0           { local $" = '|';
  0            
176 0           $select = qr/^(@select)$/i;
177             }
178              
179 0           grep {$_->type =~ $select} @diag;
  0            
180             }
181              
182              
183             #-------------------------------------------
184              
185              
186             sub superClasses(;@)
187 0     0 1   { my $self = shift;
188 0           push @{$self->{OP_isa}}, @_;
  0            
189 0           @{$self->{OP_isa}};
  0            
190             }
191              
192              
193             sub realizes(;$)
194 0     0 1   { my $self = shift;
195 0 0         @_ ? ($self->{OP_realizes} = shift) : $self->{OP_realizes};
196             }
197              
198              
199             sub subClasses(;@)
200 0     0 1   { my $self = shift;
201 0           push @{$self->{OP_subclasses}}, @_;
  0            
202 0           @{$self->{OP_subclasses}};
  0            
203             }
204              
205              
206             sub realizers(;@)
207 0     0 1   { my $self = shift;
208 0           push @{$self->{OP_realizers}}, @_;
  0            
209 0           @{$self->{OP_realizers}};
  0            
210             }
211              
212              
213             sub extraCode()
214 0     0 1   { my $self = shift;
215 0           my $name = $self->name;
216              
217             $self->package eq $name
218 0 0         ? grep {$_->name ne $name} $self->manualsForPackage($name)
  0            
219             : ();
220             }
221              
222              
223             sub all($@)
224 0     0 1   { my $self = shift;
225 0           map { $_->all(@_) } $self->chapters;
  0            
226             }
227              
228              
229 0     0 1   sub inherited($) {$_[0]->name ne $_[1]->manual->name}
230              
231              
232             sub ownSubroutines
233 0     0 1   { my $self = shift;
234 0   0       my $me = $self->name || return 0;
235 0           grep {not $self->inherited($_)} $self->subroutines;
  0            
236             }
237              
238             #-------------------------------------------
239              
240              
241             sub collectPackageRelations()
242 0     0 1   { my $self = shift;
243 0 0         return () if $self->isPurePod;
244              
245 0           my $name = $self->package;
246 0           my %return;
247              
248             # The @ISA / use base
249 1     1   1470 { no strict 'refs';
  1         2  
  1         2023  
  0            
250 0           $return{isa} = [ @{"${name}::ISA"} ];
  0            
251             }
252              
253             # Support for Object::Realize::Later
254 0 0         $return{realizes} = $name->willRealize if $name->can('willRealize');
255              
256 0           %return;
257             }
258              
259              
260             sub expand()
261 0     0 1   { my $self = shift;
262 0 0         return $self if $self->{OP_is_expanded};
263              
264             #
265             # All super classes much be expanded first. Manuals for
266             # extra code are considered super classes as well. Super
267             # classes which are external are ignored.
268             #
269              
270             my @supers = reverse # multiple inheritance, first isa wins
271 0           grep { ref $_ }
  0            
272             $self->superClasses;
273              
274 0           $_->expand for @supers;
275              
276             #
277             # Expand chapters, sections and subsections.
278             #
279              
280 0           my @chapters = $self->chapters;
281              
282             my $merge_subsections = sub
283 0     0     { my ($section, $inherit) = @_;
284 0           $section->extends($inherit);
285             $section->subsections($self->mergeStructure
286             ( this => [ $section->subsections ]
287             , super => [ $inherit->subsections ]
288 0           , merge => sub { $_[0]->extends($_[1]); $_[0] }
  0            
289 0           , container => $section
290             ));
291 0           $section;
292 0           };
293              
294             my $merge_sections = sub
295 0     0     { my ($chapter, $inherit) = @_;
296 0           $chapter->extends($inherit);
297 0           $chapter->sections($self->mergeStructure
298             ( this => [ $chapter->sections ]
299             , super => [ $inherit->sections ]
300             , merge => $merge_subsections
301             , container => $chapter
302             ));
303 0           $chapter;
304 0           };
305              
306 0           foreach my $super (@supers)
307             {
308 0           $self->chapters($self->mergeStructure
309             ( this => \@chapters
310             , super => [ $super->chapters ]
311             , merge => $merge_sections
312             , container => $self
313             ));
314             }
315              
316             #
317             # Give all the inherited subroutines a new location in this manual.
318             #
319              
320 0           my %extended = map { ($_->name => $_) }
321 0           map { $_->subroutines }
  0            
322             ($self, $self->extraCode);
323              
324 0           my %used; # items can be used more than once, collecting multiple inherit
325              
326 0           my @inherited = map { $_->subroutines } @supers;
  0            
327 0           my %location;
328              
329 0           foreach my $inherited (@inherited)
330 0           { my $name = $inherited->name;
331 0 0         if(my $extended = $extended{$name})
332             { # on this page and upper pages
333 0           $extended->extends($inherited);
334              
335 0 0         unless($used{$name}++) # add only at first appearance
336 0           { my $path = $self->mostDetailedLocation($extended);
337 0           push @{$location{$path}}, $extended;
  0            
338             }
339             }
340             else
341             { # only defined on higher level manual pages
342 0           my $path = $self->mostDetailedLocation($inherited);
343 0           push @{$location{$path}}, $inherited;
  0            
344             }
345             }
346              
347 0           while(my($name, $item) = each %extended)
348 0 0         { next if $used{$name};
349 0           push @{$location{$item->path}}, $item;
  0            
350             }
351              
352 0           foreach my $chapter ($self->chapters)
353 0           { $chapter->setSubroutines(delete $location{$chapter->path});
354 0           foreach my $section ($chapter->sections)
355 0           { $section->setSubroutines(delete $location{$section->path});
356 0           foreach my $subsect ($section->subsections)
357 0           { $subsect->setSubroutines(delete $location{$subsect->path});
358             }
359             }
360             }
361              
362             warning __x"section without location in {manual}: {section}"
363             , manual => $self, section => $_
364 0           for keys %location;
365              
366 0           $self->{OP_is_expanded} = 1;
367 0           $self;
368             }
369              
370              
371             sub mergeStructure(@)
372 0     0 1   { my ($self, %args) = @_;
373 0 0         my @this = defined $args{this} ? @{$args{this}} : ();
  0            
374 0 0         my @super = defined $args{super} ? @{$args{super}} : ();
  0            
375 0 0         my $container = $args{container} or panic;
376              
377 0   0 0     my $equal = $args{equal} || sub {"$_[0]" eq "$_[1]"};
  0            
378 0   0 0     my $merge = $args{merge} || sub {$_[0]};
  0            
379              
380 0           my @joined;
381              
382 0           while(@super)
383 0           { my $take = shift @super;
384 0 0   0     unless(first {$equal->($take, $_)} @this)
  0            
385 0 0 0       { push @joined, $take->emptyExtension($container)
386             unless @joined && $joined[-1]->path eq $take->path;
387 0           next;
388             }
389              
390             # A low-level merge is needed.
391              
392 0           my $insert;
393 0           while(@this) # insert everything until equivalents
394 0           { $insert = shift @this;
395 0 0         last if $equal->($take, $insert);
396              
397 0 0   0     if(first {$equal->($insert, $_)} @super)
  0            
398 0           { my ($fn, $ln) = $insert->where;
399 0           warning __x"order conflict: '{h1}' before '{h2}' in {file} line {line}"
400             , h1 => $take, h2 => $insert, file => $fn, line => $ln;
401             }
402              
403 0 0 0       push @joined, $insert
404             unless @joined && $joined[-1]->path eq $insert->path;
405             }
406 0           push @joined, $merge->($insert, $take);
407             }
408              
409 0           (@joined, @this);
410             }
411              
412              
413             sub mostDetailedLocation($)
414 0     0 1   { my ($self, $thing) = @_;
415              
416 0 0         my $inherit = $thing->extends
417             or return $thing->path;
418              
419 0           my $path1 = $thing->path;
420 0           my $path2 = $self->mostDetailedLocation($inherit);
421 0           my ($lpath1, $lpath2) = (length($path1), length($path2));
422              
423 0 0         return $path1 if $path1 eq $path2;
424              
425 0 0 0       return $path2
426             if $lpath1 < $lpath2 && substr($path2, 0, $lpath1+1) eq "$path1/";
427              
428 0 0 0       return $path1
429             if $lpath2 < $lpath1 && substr($path1, 0, $lpath2+1) eq "$path2/";
430              
431 0 0         warning __x"subroutine '{name}' location conflict:\n {p1} in {man1}\n {p2} in {man2}"
432             , name => "$thing", p1 => $path1, man1 => $thing->manual
433             , p2 => $path2, man2 => $inherit->manual
434             if $self eq $thing->manual;
435              
436 0           $path1;
437             }
438              
439              
440             sub createInheritance()
441 0     0 1   { my $self = shift;
442              
443 0 0         if($self->name ne $self->package)
444             { # This is extra code....
445 0           my $from = $self->package;
446 0           return "\n $self\n contains extra code for\n M<$from>\n";
447             }
448              
449 0           my $output;
450 0           my @supers = $self->superClasses;
451              
452 0 0         if(my $realized = $self->realizes)
453 0           { $output .= "\n $self realizes a M<$realized>\n";
454 0 0         @supers = $realized->superClasses if ref $realized;
455             }
456              
457 0 0         if(my @extras = $self->extraCode)
458 0           { $output .= "\n $self has extra code in\n";
459 0           $output .= " M<$_>\n" foreach sort @extras;
460             }
461              
462 0           foreach my $super (@supers)
463 0           { $output .= "\n $self\n";
464 0           $output .= $self->createSuperSupers($super);
465             }
466              
467 0 0         if(my @subclasses = $self->subClasses)
468 0           { $output .= "\n $self is extended by\n";
469 0           $output .= " M<$_>\n" foreach sort @subclasses;
470             }
471              
472 0 0         if(my @realized = $self->realizers)
473 0           { $output .= "\n $self is realized by\n";
474 0           $output .= " M<$_>\n" foreach sort @realized;
475             }
476              
477 0 0 0       my $chapter = OODoc::Text::Chapter->new
478             ( name => 'INHERITANCE'
479             , manual => $self
480             , linenr => -1
481             , description => $output
482             ) if $output && $output =~ /\S/;
483              
484 0           $self->chapter($chapter);
485             }
486              
487             sub createSuperSupers($)
488 0     0 0   { my ($self, $package) = @_;
489 0           my $output = " is a M<$package>\n";
490 0 0         return $output
491             unless ref $package; # only the name of the package is known
492              
493 0 0         if(my $realizes = $package->realizes)
494 0           { $output .= $self->createSuperSupers($realizes);
495 0           return $output;
496             }
497              
498 0 0         my @supers = $package->superClasses or return $output;
499 0           $output .= $self->createSuperSupers(shift @supers);
500              
501 0           foreach(@supers)
502 0           { $output .= "\n\n $package also extends M<$_>\n";
503 0           $output .= $self->createSuperSupers($_);
504             }
505              
506 0           $output;
507             }
508              
509             #-------------------------------------------
510              
511              
512             sub stats()
513 0     0 1   { my $self = shift;
514 0   0       my $chapters = $self->chapters || return;
515 0           my $subs = $self->ownSubroutines;
516 0           my $options = map { $_->options } $self->ownSubroutines;
  0            
517 0           my $diags = $self->diagnostics;
518 0           my $examples = $self->examples;
519              
520 0           my $manual = $self->name;
521 0           my $package = $self->package;
522 0 0         my $head
523             = $manual eq $package
524             ? "manual $manual"
525             : "manual $manual for $package";
526              
527 0           <
528             $head
529             chapters: $chapters
530             documented subroutines: $subs
531             documented options: $options
532             documented diagnostics: $diags
533             shown examples: $examples
534             STATS
535             }
536              
537              
538             sub index()
539 0     0 1   { my $self = shift;
540 0           my @lines;
541 0           foreach my $chapter ($self->chapters)
542 0           { push @lines, $chapter->name;
543 0           foreach my $section ($chapter->sections)
544 0           { push @lines, " ".$section->name;
545 0           foreach ($section->subsections)
546 0           { push @lines, " ".$_->name;
547             }
548             }
549             }
550 0           join "\n", @lines, '';
551             }
552              
553             #-------------------------------------------
554              
555              
556             1;