File Coverage

lib/OODoc/Parser/Markov.pm
Criterion Covered Total %
statement 54 402 13.4
branch 0 202 0.0
condition 0 86 0.0
subroutine 18 51 35.2
pod 14 33 42.4
total 86 774 11.1


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::Parser::Markov;
7 1     1   1017 use vars '$VERSION';
  1         2  
  1         56  
8             $VERSION = '2.01';
9              
10 1     1   5 use base 'OODoc::Parser';
  1         2  
  1         350  
11              
12 1     1   5 use strict;
  1         1  
  1         21  
13 1     1   4 use warnings;
  1         3  
  1         23  
14              
15 1     1   5 use Log::Report 'oodoc';
  1         2  
  1         3  
16              
17 1     1   231 use OODoc::Text::Chapter;
  1         2  
  1         27  
18 1     1   4 use OODoc::Text::Section;
  1         2  
  1         20  
19 1     1   5 use OODoc::Text::SubSection;
  1         2  
  1         26  
20 1     1   350 use OODoc::Text::SubSubSection;
  1         3  
  1         27  
21 1     1   6 use OODoc::Text::Subroutine;
  1         2  
  1         31  
22 1     1   5 use OODoc::Text::Option;
  1         2  
  1         25  
23 1     1   5 use OODoc::Text::Default;
  1         2  
  1         19  
24 1     1   5 use OODoc::Text::Diagnostic;
  1         1  
  1         23  
25 1     1   5 use OODoc::Text::Example;
  1         1  
  1         19  
26 1     1   397 use OODoc::Manual;
  1         2  
  1         32  
27              
28 1     1   6 use File::Spec;
  1         2  
  1         20  
29 1     1   5 use IO::File;
  1         2  
  1         1139  
30              
31             my $url_modsearch = "http://search.cpan.org/perldoc?";
32             my $url_coderoot = 'CODE';
33              
34              
35             #-------------------------------------------
36              
37             my @default_rules =
38             ( [ '=cut' => 'docCut' ]
39             , [ '=chapter' => 'docChapter' ]
40             , [ '=section' => 'docSection' ]
41             , [ '=subsection' => 'docSubSection' ]
42             , [ '=subsubsection' => 'docSubSubSection' ]
43             , [ '=method' => 'docSubroutine' ]
44             , [ '=i_method' => 'docSubroutine' ]
45             , [ '=c_method' => 'docSubroutine' ]
46             , [ '=ci_method' => 'docSubroutine' ]
47             , [ '=function' => 'docSubroutine' ]
48             , [ '=tie' => 'docSubroutine' ]
49             , [ '=overload' => 'docSubroutine' ]
50             , [ '=option' => 'docOption' ]
51             , [ '=default' => 'docDefault' ]
52             , [ '=requires' => 'docRequires' ]
53             , [ '=example' => 'docExample' ]
54             , [ '=examples' => 'docExample' ]
55             , [ '=error' => 'docDiagnostic' ]
56             , [ '=warning' => 'docDiagnostic' ]
57             , [ '=notice' => 'docDiagnostic' ]
58             , [ '=debug' => 'docDiagnostic' ]
59              
60             # deprecated
61             , [ '=head1' => 'docChapter' ]
62             , [ '=head2' => 'docSection' ]
63             , [ '=head3' => 'docSubSection' ]
64              
65             # problem spotter
66             , [ qr/^(warn|die|carp|confess|croak)\s/ => 'debugRemains' ]
67             , [ qr/^( sub \s+ \w
68             | (?:my|our) \s+ [\($@%]
69             | (?:package|use) \s+ \w+\:
70             )
71             /x => 'forgotCut' ]
72             );
73              
74              
75             sub init($)
76 0     0 0   { my ($self, $args) = @_;
77 0 0         $self->SUPER::init($args) or return;
78              
79 0           my @rules = @default_rules;
80 0           unshift @rules, @{delete $args->{additional_rules}}
81 0 0         if exists $args->{additional_rules};
82              
83 0           $self->{OP_rules} = [];
84 0           $self->rule(@$_) for @rules;
85 0           $self;
86             }
87              
88             #-------------------------------------------
89              
90              
91             sub rule($$)
92 0     0 1   { my ($self, $match, $action) = @_;
93 0           push @{$self->{OP_rules}}, [$match, $action];
  0            
94 0           $self;
95             }
96              
97             #-------------------------------------------
98              
99              
100             sub findMatchingRule($)
101 0     0 1   { my ($self, $line) = @_;
102              
103 0           foreach ( @{$self->{OP_rules}} )
  0            
104 0           { my ($match, $action) = @$_;
105 0 0         if(ref $match)
    0          
106 0 0         { return ($&, $action) if $line =~ $match;
107             }
108             elsif(substr($line, 0, length($match)) eq $match)
109 0           { return ($match, $action);
110             }
111             }
112              
113 0           ();
114             }
115              
116              
117             sub parse(@)
118 0     0 1   { my ($self, %args) = @_;
119              
120             my $input = $args{input}
121 0 0         or error __x"no input file to parse specified";
122              
123 0   0       my $output = $args{output} || File::Spec->devnull;
124 0 0         my $version = $args{version} or panic;
125 0 0         my $distr = $args{distribution} or panic;
126              
127 0 0         my $in = IO::File->new($input, 'r')
128             or die "ERROR: cannot read document from $input: $!\n";
129              
130 0 0         my $out = IO::File->new($output, 'w')
131             or die "ERROR: cannot write stripped code to $output: $!\n";
132              
133             # pure doc files have no package statement included, so it shall
134             # be created beforehand.
135              
136 0           my ($manual, @manuals);
137              
138 0           my $pure_pod = $input =~ m/\.pod$/;
139 0 0         if($pure_pod)
140 0           { $manual = OODoc::Manual->new
141             ( package => $self->filenameToPackage($input)
142             , pure_pod => 1
143             , source => $input
144             , parser => $self
145              
146             , distribution => $distr
147             , version => $version
148             );
149              
150 0           push @manuals, $manual;
151 0           $self->currentManual($manual);
152 0           $self->inDoc(1);
153             }
154             else
155 0 0         { $out->print($args{notice}) if $args{notice};
156 0           $self->inDoc(0);
157             }
158              
159             # Read through the file.
160              
161 0           while(my $line = $in->getline)
162 0           { my $ln = $in->input_line_number;
163              
164 0 0 0       if(!$self->inDoc && $line =~ s/^(\s*package\s*([\w\-\:]+)\;)//)
    0 0        
    0 0        
    0          
    0          
    0          
    0          
165 0           { $out->print($1);
166 0           my $package = $2;
167              
168             # I would like to use 'our' here, but in some cases, that will
169             # cause compaints about double declaration with our.
170 0           $out->print("\nuse vars '\$VERSION';\n\$VERSION = '$version';\n");
171 0           $out->print($line);
172              
173 0           $manual = OODoc::Manual->new
174             ( package => $package
175             , source => $input
176             , stripped => $output
177             , parser => $self
178              
179             , distribution => $distr
180             , version => $version
181             );
182 0           push @manuals, $manual;
183 0           $self->currentManual($manual);
184             }
185             elsif(!$self->inDoc && $line =~ m/^=package\s*([\w\-\:]+)\s*$/)
186 0           { my $package = $1;
187 0           $manual = OODoc::Manual->new
188             ( package => $package
189             , source => $input
190             , stripped => $output
191             , parser => $self
192             , distribution => $distr
193             , version => $version
194             );
195 0           push @manuals, $manual;
196 0           $self->currentManual($manual);
197             }
198             elsif(my($match, $action) = $self->findMatchingRule($line))
199             {
200              
201 0 0         if(ref $action)
202 0 0         { $action->($self, $match, $line, $input, $ln)
203             or $out->print($line);
204             }
205             else
206 1     1   5 { no strict 'refs';
  1         1  
  1         5198  
207 0 0         $self->$action($match, $line, $input, $ln)
208             or $out->print($line);
209             }
210             }
211             elsif($line =~ m/^=(over|back|item|for|pod|begin|end|head4|encoding)\b/)
212 0           { ${$self->{OPM_block}} .= "\n". $line;
  0            
213 0           $self->inDoc(1);
214             }
215             elsif(substr($line, 0, 1) eq '=')
216 0           { warn "WARNING: unknown markup in $input line $ln:\n $line";
217 0           ${$self->{OPM_block}} .= $line;
  0            
218 0           $self->inDoc(1);
219             }
220             elsif($pure_pod || $self->inDoc)
221             { # add the line to the currently open text block
222 0           my $block = $self->{OPM_block};
223 0 0         unless($block)
224 0           { warn "WARNING: no block for line $ln in file $input\n $line";
225 0           my $dummy = '';
226 0           $block = $self->setBlock(\$dummy);
227             }
228 0           $$block .= $line;
229             }
230             elsif($line eq "__DATA__\n") # flush rest file
231 0           { $out->print($line, $in->getlines);
232             }
233             else
234 0           { $out->print($line);
235             }
236             }
237              
238 0 0 0       warn "WARNING: doc did not end in $input.\n"
239             if $self->inDoc && ! $pure_pod;
240              
241 0           $self->closeChapter;
242 0 0         $in->close && $out->close;
243              
244 0           @manuals;
245             }
246              
247             #-------------------------------------------
248              
249              
250             sub setBlock($)
251 0     0 1   { my ($self, $ref) = @_;
252 0           $self->{OPM_block} = $ref;
253 0           $self->inDoc(1);
254 0           $self;
255             }
256              
257             #-------------------------------------------
258              
259              
260             sub inDoc(;$)
261 0     0 1   { my $self = shift;
262 0 0         $self->{OPM_in_pod} = shift if @_;
263 0           $self->{OPM_in_pod};
264             }
265              
266             #-------------------------------------------
267              
268              
269             sub currentManual(;$)
270 0     0 1   { my $self = shift;
271 0 0         @_ ? $self->{OPM_manual} = shift : $self->{OPM_manual};
272             }
273            
274             #-------------------------------------------
275              
276              
277             sub docCut($$$$)
278 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
279              
280 0 0         if($self->currentManual->isPurePod)
281 0           { warn "The whole file $fn is pod, so =cut in line $ln is useless.\n";
282 0           return;
283             }
284              
285 0 0         warn "WARNING: $match does not terminate any doc in $fn line $ln.\n"
286             unless $self->inDoc;
287              
288 0           $self->inDoc(0);
289 0           1;
290             }
291              
292             #-------------------------------------------
293             # CHAPTER
294              
295              
296             sub docChapter($$$$)
297 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
298 0           $line =~ s/^\=(chapter|head1)\s+//;
299 0           $line =~ s/\s+$//;
300              
301 0           $self->closeChapter;
302              
303 0           my $manual = $self->currentManual;
304 0 0         die "ERROR: chapter $line before package statement in $fn line $ln\n"
305             unless defined $manual;
306              
307 0           my $chapter = $self->{OPM_chapter} = OODoc::Text::Chapter->new
308             ( name => $line
309             , manual => $manual
310             , linenr => $ln
311             );
312              
313 0           $self->setBlock($chapter->openDescription);
314 0           $manual->chapter($chapter);
315 0           $chapter;
316             }
317              
318             sub closeChapter()
319 0     0 0   { my $self = shift;
320 0 0         my $chapter = delete $self->{OPM_chapter} or return;
321 0           $self->closeSection()->closeSubroutine();
322             }
323              
324             #-------------------------------------------
325             # SECTION
326              
327              
328             sub docSection($$$$)
329 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
330 0           $line =~ s/^\=(section|head2)\s+//;
331 0           $line =~ s/\s+$//;
332              
333 0           $self->closeSection;
334              
335 0           my $chapter = $self->{OPM_chapter};
336 0 0         die "ERROR: section `$line' outside chapter in $fn line $ln\n"
337             unless defined $chapter;
338              
339 0           my $section = $self->{OPM_section} = OODoc::Text::Section->new
340             ( name => $line
341             , chapter => $chapter
342             , linenr => $ln
343             );
344              
345 0           $chapter->section($section);
346 0           $self->setBlock($section->openDescription);
347 0           $section;
348             }
349              
350             sub closeSection()
351 0     0 0   { my $self = shift;
352 0 0         my $section = delete $self->{OPM_section} or return $self;
353 0           $self->closeSubSection();
354             }
355              
356             #-------------------------------------------
357             # SUBSECTION
358              
359              
360             sub docSubSection($$$$)
361 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
362 0           $line =~ s/^\=(subsection|head3)\s+//;
363 0           $line =~ s/\s+$//;
364              
365 0           $self->closeSubSection;
366              
367 0           my $section = $self->{OPM_section};
368 0 0         defined $section
369             or die "ERROR: subsection `$line' outside section in $fn line $ln\n";
370              
371 0           my $subsection = $self->{OPM_subsection} = OODoc::Text::SubSection->new
372             ( name => $line
373             , section => $section
374             , linenr => $ln
375             );
376              
377 0           $section->subsection($subsection);
378 0           $self->setBlock($subsection->openDescription);
379 0           $subsection;
380             }
381              
382             sub closeSubSection()
383 0     0 0   { my $self = shift;
384 0           my $subsection = delete $self->{OPM_subsection};
385 0           $self;
386             }
387              
388              
389             #-------------------------------------------
390             # SUBSECTION
391              
392              
393             sub docSubSubSection($$$$)
394 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
395 0           $line =~ s/^\=(subsubsection|head4)\s+//;
396 0           $line =~ s/\s+$//;
397              
398 0           $self->closeSubSubSection;
399              
400 0           my $subsection = $self->{OPM_subsection};
401 0 0         defined $subsection
402             or die "ERROR: subsubsection `$line' outside subsection in $fn line $ln\n";
403              
404             my $subsubsection
405 0           = $self->{OPM_subsubsection} = OODoc::Text::SubSubSection->new
406             ( name => $line
407             , subsection => $subsection
408             , linenr => $ln
409             );
410              
411 0           $subsection->subsubsection($subsubsection);
412 0           $self->setBlock($subsubsection->openDescription);
413 0           $subsubsection;
414             }
415              
416             sub closeSubSubSection()
417 0     0 0   { my $self = shift;
418 0           delete $self->{OPM_subsubsection};
419 0           $self;
420             }
421              
422             #-------------------------------------------
423             # SUBROUTINES
424              
425              
426             sub docSubroutine($$$$)
427 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
428              
429 0           chomp $line;
430 0           $line =~ s/^\=(\w+)\s+//;
431 0           my $type = $1;
432              
433 0 0         my ($name, $params)
434             = $type eq 'overload' ? ($line, '')
435             : $line =~ m/^(\w*)\s*(.*?)\s*$/;
436              
437             my $container = $self->{OPM_subsection}
438             || $self->{OPM_section}
439 0   0       || $self->{OPM_chapter};
440              
441 0 0         die "ERROR: subroutine $name outside chapter in $fn line $ln\n"
442             unless defined $container;
443              
444 0 0         $type = 'i_method' if $type eq 'method';
445 0           my $sub = $self->{OPM_subroutine} = OODoc::Text::Subroutine->new
446             ( type => $type
447             , name => $name
448             , parameters => $params
449             , linenr => $ln
450             , container => $container
451             );
452              
453 0           $self->setBlock($sub->openDescription);
454 0           $container->addSubroutine($sub);
455 0           $sub;
456             }
457              
458             sub closeSubroutine()
459 0     0 0   { my $self = shift;
460 0           delete $self->{OPM_subroutine};
461 0           $self;
462             }
463              
464             #-------------------------------------------
465             # SUBROUTINE ADDITIONALS
466              
467              
468             sub docOption($$$$)
469 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
470              
471 0 0         unless($line =~ m/^\=option\s+(\S+)\s*(.+?)\s*$/ )
472 0           { warn "WARNING: option line incorrect in $fn line $ln:\n$line";
473 0           return;
474             }
475 0           my ($name, $parameters) = ($1, $2);
476              
477 0           my $sub = $self->{OPM_subroutine};
478 0 0         die "ERROR: option $name outside subroutine in $fn line $ln\n"
479             unless defined $sub;
480              
481 0           my $option = OODoc::Text::Option->new
482             ( name => $name
483             , parameters => $parameters
484             , linenr => $ln
485             , subroutine => $sub
486             );
487              
488 0           $self->setBlock($option->openDescription);
489 0           $sub->option($option);
490 0           $sub;
491             }
492              
493             #-------------------------------------------
494              
495              
496             sub docDefault($$$$)
497 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
498              
499 0 0         unless($line =~ m/^\=default\s+(\S+)\s*(.+?)\s*$/ )
500 0           { warn "WARNING: default line incorrect in $fn line $ln:\n$line";
501 0           return;
502             }
503              
504 0           my ($name, $value) = ($1, $2);
505              
506 0           my $sub = $self->{OPM_subroutine};
507 0 0         die "ERROR: default for option $name outside subroutine in $fn line $ln\n"
508             unless defined $sub;
509              
510 0           my $default = OODoc::Text::Default->new
511             ( name => $name
512             , value => $value
513             , linenr => $ln
514             , subroutine => $sub
515             );
516              
517 0           $sub->default($default);
518 0           $sub;
519             }
520              
521             sub docRequires($$$$)
522 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
523              
524 0 0         unless($line =~ m/^\=requires\s+(\w+)\s*(.+?)\s*$/ )
525 0           { warn "WARNING: requires line incorrect in $fn line $ln:\n$line";
526 0           return;
527             }
528              
529 0           my ($name, $param) = ($1, $2);
530 0           $self->docOption ($match, "=option $name $param", $fn, $ln);
531 0           $self->docDefault($match, "=default $name ", $fn, $ln);
532             }
533              
534             #-------------------------------------------
535             # DIAGNOSTICS
536              
537              
538             sub docDiagnostic($$$$)
539 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
540              
541 0           $line =~ s/^\=(\w+)\s*//;
542 0           my $type = $1;
543              
544 0           $line =~ s/\s*$//;
545 0 0         unless(length $line)
546 0           { warn "WARNING: no diagnostic message supplied in $fn line $ln";
547 0           return;
548             }
549              
550 0           my $sub = $self->{OPM_subroutine};
551 0 0         die "ERROR: diagnostic $type outside subroutine in $fn line $ln\n"
552             unless defined $sub;
553              
554 0           my $diag = OODoc::Text::Diagnostic->new
555             ( type => ucfirst($type)
556             , name => $line
557             , linenr => $ln
558             , subroutine => $sub
559             );
560              
561 0           $self->setBlock($diag->openDescription);
562 0           $sub->diagnostic($diag);
563 0           $sub;
564             }
565              
566             #-------------------------------------------
567             # EXAMPLE
568              
569              
570             sub docExample($$$$)
571 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
572              
573 0           $line =~ s/^=examples?\s*//;
574 0           $line =~ s/^\#.*//;
575              
576             my $container = $self->{OPM_subroutine}
577             || $self->{OPM_subsubsection}
578             || $self->{OPM_subsection}
579             || $self->{OPM_section}
580 0   0       || $self->{OPM_chapter};
581            
582 0 0         die "ERROR: example outside chapter in $fn line $ln\n"
583             unless defined $container;
584              
585 0   0       my $example = OODoc::Text::Example->new
586             ( name => ($line || '')
587             , linenr => $ln
588             , container => $container
589             );
590              
591 0           $self->setBlock($example->openDescription);
592 0           $container->example($example);
593 0           $example;
594             }
595              
596             #-------------------------------------------
597              
598              
599             sub debugRemains($$$$)
600 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
601              
602 0 0 0       warn "WARNING: Debugging remains in $fn line $ln\n"
603             unless $self->inDoc || $self->currentManual->isPurePod;
604              
605 0           undef;
606             }
607              
608             #-------------------------------------------
609              
610              
611             sub forgotCut($$$$)
612 0     0 0   { my ($self, $match, $line, $fn, $ln) = @_;
613              
614 0 0 0       warn "WARNING: You may have accidentally captured code in doc $fn line $ln\n"
615             if $self->inDoc && ! $self->currentManual->isPurePod;
616              
617 0           undef;
618             }
619              
620             #-------------------------------------------
621              
622              
623             sub decomposeM($$)
624 0     0 1   { my ($self, $manual, $link) = @_;
625              
626 0 0         my ($subroutine, $option)
627             = $link =~ s/(?:^|\:\:) (\w+) \( (.*?) \)$//x ? ($1, $2)
628             : ('', '');
629              
630 0           my $man;
631 0 0         if(not length($link)) { $man = $manual }
  0 0          
632             elsif(defined($man = $self->manual($link))) { ; }
633             else
634 0           { eval "no warnings; require $link";
635 0 0 0       if( ! $@
    0 0        
636             || $@ =~ m/attempt to reload/i
637             || $self->skipManualLink($link)
638             ) { ; }
639             elsif($@ =~ m/Can't locate/ )
640 0           { warn "WARNING: module $link is not on your system, found in $manual\n";
641             }
642             else
643 0           { $@ =~ s/ at \(eval.*//;
644 0           warn "WARNING: use problem for module $link in $manual;\n$@";
645 0           warn " Did you use an 'M' tag on something which is not a module?\n";
646             }
647 0           $man = $link;
648             }
649              
650 0 0         unless(ref $man)
651 0 0         { return ( $manual
    0          
652             , $man
653             . (length($subroutine) ? " subroutine $subroutine" : '')
654             . (length($option) ? " option $option" : '')
655             );
656             }
657              
658 0 0 0       return (undef, $man)
659             unless defined $subroutine && length $subroutine;
660              
661 0           my $package = $self->manual($man->package);
662 0 0         unless(defined $package)
663 0           { my $want = $man->package;
664 0           warn "WARNING: no manual for $want (correct casing?)\n";
665 0           return (undef, "$want subroutine $subroutine");
666             }
667              
668 0           my $sub = $package->subroutine($subroutine);
669 0 0         unless(defined $sub)
670 0           { warn "WARNING: subroutine $subroutine() is not defined by $package, but linked to in $manual\n";
671 0           return ($package, "$package subroutine $subroutine");
672             }
673              
674 0           my $location = $sub->manual;
675 0 0 0       return ($location, $sub)
676             unless defined $option && length $option;
677              
678 0           my $opt = $sub->findOption($option);
679 0 0         unless(defined $opt)
680 0           { warn "WARNING: option \"$option\" unknown for $subroutine() in $location, found in $manual\n";
681 0           return ($location, "$package subroutine $subroutine option $option");
682             }
683              
684 0           ($location, $opt);
685             }
686              
687              
688             sub decomposeL($$)
689 0     0 1   { my ($self, $manual, $link) = @_;
690 0 0         my $text = $link =~ s/^([^|]*)\|// ? $1 : undef;
691              
692 0 0         unless(length $link)
693 0           { warn "WARNING: empty L link in $manual";
694 0           return ();
695             }
696              
697 0 0         if($link =~ m/^[a-z]+\:[^:]/ )
698 0 0         { $text = $link unless defined $text;
699 0           return (undef, undef, $link, $text);
700             }
701              
702 0           my ($name, $item) = $link =~ m[(.*?)(?:/(.*))?$];
703              
704 0 0         ($name, $item) = (undef, $name) if $name =~ m/^".*"$/;
705 0 0         $item =~ s/^"(.*)"$/$1/ if defined $item;
706              
707 0 0 0       my $man = length $name ? ($self->manual($name) || $name) : $manual;
708              
709 0           my $dest;
710 0 0         if(!ref $man)
    0          
    0          
711 0 0 0       { unless(defined $text && length $text)
712 0           { $text = "manual $man";
713 0 0 0       $text .= " entry $item" if defined $item && length $item;
714             }
715              
716 0 0         if($man !~ m/\(\d.*\)\s*$/)
717 0           { (my $escaped = $man) =~ s/\W+/_/g;
718 0           $dest = "$url_modsearch$escaped";
719             }
720             }
721             elsif(!defined $item)
722 0           { $dest = $man;
723 0 0         $text = $man->name unless defined $text;
724             }
725             elsif(my @obj = $man->all(findEntry => $item))
726 0           { $dest = shift @obj;
727 0 0         $text = $item unless defined $text;
728             }
729             else
730 0           { warn "WARNING: Manual $manual links to unknown entry \"$item\" in $man\n";
731 0           $dest = $man;
732 0 0         $text = "$man" unless defined $text;
733             }
734              
735 0           ($man, $dest, undef, $text);
736             }
737              
738              
739             sub cleanupPod($$$)
740 0     0 1   { my ($self, $formatter, $manual, $string) = @_;
741 0 0 0       return '' unless defined $string && length $string;
742              
743 0           my @lines = split /^/, $string;
744 0           my $protect;
745              
746 0           for(my $i=0; $i < @lines; $i++)
747 0 0         { $protect = $1 if $lines[$i] =~ m/^=(for|begin)\s+\w/;
748              
749 0 0         undef $protect if $lines[$i] =~ m/^=end/;
750              
751 0 0 0       undef $protect if $lines[$i] =~ m/^\s*$/
      0        
752             && $protect && $protect eq 'for';
753              
754 0 0         next if $protect;
755              
756 0           $lines[$i] =~
757 0           s/\bM\<([^>]*)\>/$self->cleanupPodM($formatter,$manual,$1)/ge;
758              
759 0 0         $lines[$i] =~
760 0           s/\bL\<([^>]*)\>/$self->cleanupPodL($formatter,$manual,$1)/ge
761             if substr($lines[$i], 0, 1) eq ' ';
762              
763             # permit losing blank lines around pod statements.
764 0 0         if(substr($lines[$i], 0, 1) eq '=')
765 0 0 0       { if($i > 0 && $lines[$i-1] ne "\n")
    0 0        
      0        
766 0           { splice @lines, $i-1, 0, "\n";
767 0           $i++;
768             }
769             elsif($i < $#lines && $lines[$i+1] ne "\n"
770             && substr($lines[$i], 0, 5) ne "=for ")
771 0           { splice @lines, $i+1, 0, "\n";
772             }
773             }
774             else
775 0           { $lines[$i] =~ s/^\\\=/\=/;
776             }
777              
778             # Remove superfluous blanks
779 0 0 0       if($i < $#lines && $lines[$i] eq "\n" && $lines[$i+1] eq "\n")
      0        
780 0           { splice @lines, $i+1, 1;
781             }
782             }
783              
784             # remove leading and trailing blank lines
785 0   0       shift @lines while @lines && $lines[0] eq "\n";
786 0   0       pop @lines while @lines && $lines[-1] eq "\n";
787              
788 0 0         @lines ? join('', @lines) : '';
789             }
790              
791              
792             sub cleanupPodM($$$)
793 0     0 1   { my ($self, $formatter, $manual, $link) = @_;
794 0           my ($toman, $to) = $self->decomposeM($manual, $link);
795 0 0         ref $to ? $formatter->link($toman, $to, $link) : $to;
796             }
797              
798              
799             sub cleanupPodL($$$)
800 0     0 1   { my ($self, $formatter, $manual, $link) = @_;
801 0           my ($toman, $to, $href, $text) = $self->decomposeL($manual, $link);
802 0           $text;
803             }
804              
805             #-------------------------------------------
806              
807              
808             sub cleanupHtml($$$;$)
809 0     0 1   { my ($self, $formatter, $manual, $string, $is_html) = @_;
810 0 0 0       return '' unless defined $string && length $string;
811              
812 0 0 0       if($string =~ m/(?:\A|\n) # start of line
813             \=begin\s+(:?\w+)\s* # begin statement
814             (.*?) # encapsulated
815             \n\=end\s+\1\s* # related end statement
816             /xs
817             || $string =~ m/(?:\A|\n) # start of line
818             \=for\s+(:?\w+)\b # for statement
819             (.*?)\n # encapsulated
820             (\n|\Z) # end of paragraph
821             /xs
822             )
823 0           { my ($before, $type, $capture, $after) = ($`, lc($1), $2, $');
824 0 0         if($type =~ m/^\:(text|pod)\b/ )
    0          
825 0           { $type = 'text';
826 0           $capture = $self->cleanupPod($formatter, $manual, $capture);
827             }
828             elsif($type =~ m/^\:?html\b/ )
829 0           { $type = 'html';
830 0           $capture = $self->cleanupHtml($formatter, $manual, $capture, 1);
831             }
832              
833 0 0         my $take = $type eq 'text' ? "
\n". $capture . "
\n"
    0          
834             : $type eq 'html' ? $capture
835             : ''; # ignore
836              
837 0           return $self->cleanupHtml($formatter, $manual, $before)
838             . $take
839             . $self->cleanupHtml($formatter, $manual, $after);
840             }
841              
842 0           for($string)
843 0 0         { unless($is_html)
844 0           { s#\&#\&#g;
845 0           s#(?
846 0           s#\-\>#-\>#g;
847             }
848 0           s/\bM\<([^>]*)\>/$self->cleanupHtmlM($formatter, $manual, $1)/ge;
  0            
849 0           s/\bL\<([^>]*)\>/$self->cleanupHtmlL($formatter, $manual, $1)/ge;
  0            
850 0           s#\bC\<([^>]*)\>#$1#g;
851 0           s#\bI\<([^>]*)\>#$1#g;
852 0           s#\bB\<([^>]*)\>#$1#g;
853 0           s#\bE\<([^>]*)\>#\&$1;#g;
854 0           s#^\=over\s+\d+\s*#\n
    \n#gms;
855 0           s#(?:\A|\n)\=item\s*(?:\*\s*)?([^\n]*)#\n
  • $1
    #gms;
  • 856 0           s#(?:\A|\s*)\=back\b#\n#gms;
    857 0           s#^=pod\b##gm;
    858            
    859             # when F<> contains a URL, it will be used. However, when it
    860             # contains a file, we cannot do anything with it yet.
    861 0           s#\bF\<(\w+\://[^>]*)\>#$1#g;
    862 0           s#\bF\<([^>]*)\>#$1#g;
    863              
    864 0           my ($label, $level, $title);
    865 0           s#^\=head([1-6])\s*([^\n]*)#
    866 0           ($title, $level) = ($1, $2);
    867 0           $label = $title;
    868 0           $label =~ s/\W+/_/g;
    869 0           qq[$title];
    870             #ge;
    871              
    872 0 0         next if $is_html;
    873              
    874 0           s!(?:(?:^|\n)
    875             [^\ \t\n]+[^\n]* # line starting with blank: para
    876             )+
    877             !

    $&

    !gsx;
    878              
    879 0           s!(?:(?:^|\n) # start of line
    880             [\ \t]+[^\n]+ # line starting with blank: pre
    881             )+
    882             !
    $&\n
    !gsx;
    883              
    884 0           s#\n
    ##gs; 
    885 0           s#

    \n#\n

    #gs;

    886             }
    887              
    888 0           $string;
    889             }
    890              
    891              
    892             sub cleanupHtmlM($$$)
    893 0     0 1   { my ($self, $formatter, $manual, $link) = @_;
    894 0           my ($toman, $to) = $self->decomposeM($manual, $link);
    895 0 0         ref $to ? $formatter->link($toman, $to, $link) : $to;
    896             }
    897              
    898              
    899             sub cleanupHtmlL($$$)
    900 0     0 1   { my ($self, $formatter, $manual, $link) = @_;
    901 0           my ($toman, $to, $href, $text) = $self->decomposeL($manual, $link);
    902              
    903 0 0         defined $href ? qq[$text]
        0          
        0          
    904             : !defined $to ? $text
    905             : ref $to ? $formatter->link($toman, $to, $text)
    906             : qq[$text]
    907             }
    908              
    909             #-------------------------------------------
    910              
    911              
    912             1;