File Coverage

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


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

    $&

    !gsx;
    883              
    884 0           s!(?:(?:^|\n) # start of line
    885             [\ \t]+[^\n]+ # line starting with blank: pre
    886             )+
    887             !
    $&\n
    !gsx;
    888              
    889 0           s#\n
    ##gs; 
    890 0           s#

    \n#\n

    #gs;

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