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

    $&

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

    \n#\n

    #gs;

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