File Coverage

blib/lib/Text/SmartLinks.pm
Criterion Covered Total %
statement 138 473 29.1
branch 28 136 20.5
condition 18 50 36.0
subroutine 24 50 48.0
pod 10 34 29.4
total 218 743 29.3


\n};
line stmt bran cond sub pod time code
1             package Text::SmartLinks;
2 3     3   72165 use strict;
  3         7  
  3         110  
3 3     3   17 use warnings;
  3         6  
  3         83  
4 3     3   121 use 5.006;
  3         160  
  3         155  
5              
6             our $VERSION = '0.01';
7              
8 3     3   3020 use File::ShareDir;
  3         30390  
  3         179  
9 3     3   1611 use FindBin;
  3         1774  
  3         98  
10 3     3   20 use File::Spec;
  3         4  
  3         68  
11 3     3   14 use File::Path qw(mkpath);
  3         6  
  3         265  
12 3     3   16 use File::Basename qw(dirname basename);
  3         6  
  3         164  
13 3     3   3525 use File::Slurp;
  3         59283  
  3         249  
14 3     3   9081 use CGI;
  3         61515  
  3         25  
15 3     3   3640 use Pod::Simple::HTML;
  3         171288  
  3         118  
16 3     3   5473 use Data::Dumper;
  3         32582  
  3         342  
17              
18 3     3   29 use base 'Class::Accessor';
  3         6  
  3         3911  
19             __PACKAGE__->mk_accessors(qw(check count cssfile line_anchor
20             out_dir print_missing smoke_rev test_files version wiki));
21              
22             # TODO: treat non-breaking spaces as breaking spces in the smart links
23             # in docs/Perl6/Spec/S03-operators.pod the section called
24             # "Changes to Perl 5 operators" has a non-breaking space between Perl and 5
25             # while the smartlink pointing to it does not have. This should be acceptable.
26             # probably by replacing every space by [\s$nbsp]+ in the regex.
27             # use charnames ":full";
28             # my $nbsp = "\N{NO-BREAK SPACE}";
29              
30             =head1 NAME
31              
32             Text::SmartLinks - connecting test files with pod documentation
33              
34             =head1 SYNOPSIS
35              
36             smartlinks.pl t/*/*.t t/*/*/*.t
37             smartlinks.pl --dir t
38             smartlinks.pl --css foo.css --out-dir=public_html t/syntax/*.t
39             smartlinks.pl --check t/*/*.t t/*/*/*.t
40             smartlinks.pl --check t/some/test.t
41             smartlinks.pl --missing t/*/*.t t/*/*/*.t
42            
43             If in the root directory of a CPAN package type the following:
44              
45             smartlinks.pl --pod-dir lib/ --dir t/ --out-dir html/ --index
46              
47             In the root of Text::SmartLinks type in the following:
48              
49             perl -Ilib script/smartlinks.pl --pod-dir lib/ --dir t/ --out-dir html/ --index
50              
51             =head1 DESCRIPTION
52              
53             The plan is to change the Text::SmartLinks module and write a new
54             smartlinks.pl script so it will be usable in any Perl 5 or Perl 6
55             project to generate the HTML pages combining the POD content from
56             the .pod and .pm files and test scripts.
57              
58             In addition the script should be able to generate further reports
59             in HTML format that help the developers.
60              
61             The usage should default to parsing the files in lib/ for documentation
62             and the .t files in the t/ subdirectory.
63              
64             =head1 Requirements
65              
66             Process both Perl 5 and Perl 6 test files in an arbitraty directory
67             to collect smartlinks.
68             Default should be either the local t/ directory or the t/spec directory
69             of Pugs (for historical reasons).
70              
71             Process .pod and .pm files (but maybe other files as well) with either Perl 5
72             or Perl 6 pod in them and with possibly also code in them.
73              
74             Smartlinks should be able to say the name of the document where they link to.
75              
76             L
77             L
78              
79             Map to either Smolder.pm or Smolder.pod and Smolder/Util.pm or Smolder/Util.pod
80              
81             Need special cases for the Perl 6 documentation so the smartlinks can
82             have the following links pointing to S06-routines.pod and
83             S32-setting-library/Abstraction.pod
84              
85             L
86             L
87              
88              
89             =head1 Old Design Decisions
90              
91             =over
92              
93             =item *
94              
95             This script should have as few non-core module dependencies as possible.
96              
97             =item *
98              
99             One doesn't have to build pugs so as to run F. Of course,
100             optional advanced features may require the user to run pugs'
101             "make" or even "make smoke".
102              
103             =back
104              
105             =head1 Smartlink Syntax
106              
107             Smartlinks are planted in the test file, and are pointed to the appropriate sections
108             of the Synopsis you are using to write the test.
109              
110             They look like pod links:
111              
112             L # "S06" is synopsis 6, and "Blocks" is the section
113             L # quotes can be used when spaces are in the title,
114             # but is NOT required.
115             L # just fine
116              
117             The section name should be copied verbatim from the POD
118             (usually after C<=head>), including any POD tags like C<...>
119             and punctuations. The sections, however, are not supposed to be nested.
120             That is, a C<=head1> won't really contain a C<=head2>; they're disjoint
121             according to the current implementation.
122              
123             The smartlinks also have a weird (also important) extension:
124             you can specify some keyphrases, to skip forward from the linked
125             section, so the smartlink is put into
126             a more specific place:
127              
128             L
129              
130             The above smartlink is appropriate next to a test case checking rule application in
131             numeric context, and it will place the backlink appropriately.
132              
133             All the keyphrases listed after the second slash in a smartlink should appear in
134             a single sentence from the synopsis text, and the order is significant. If
135             there're spaces in a keyphrase, quote it using either double-quotes or signle-quotes.
136              
137             In contrast with the case of section name, you should never use POD tags like
138             C<...> in a keyphrase. util/smartlinks.pl will do the right thing. You can use,
139             however, pod directives in the keyphrases, just like this:
140              
141             # L
142              
143             Smartlinks in .t files can be preceded by nothing but spaces or "#", furthermore,
144             there should be no trailing text on the same line, otherwise
145             they can't be recognized by tools. Here're some *invalid* samples:
146              
147             # the following smartlink is INVALID!!!
148             # Link is L
149              
150             # the following smartlink is INVALID TOO!!!
151             # L # This is a comment
152              
153             There's also a variant for the smartlink syntax:
154              
155             # L>
156              
157             A smartlink can span at most 2 lines:
158              
159             # L
160             # "key2" key3 key4>
161              
162             Only the keyphrase list part can continue to the next line. So the following example
163             is invalid:
164              
165             # L
166             # name/blah blah blah> # WRONG!!!
167              
168             Please don't put a smartlink in the middle of a group of tests. Put it right
169             *before* the group of tests it is related to.
170              
171             Multiple adjacent smartlinks can share the same snippet of tests right below
172             them:
173              
174             # L
175             # L
176             { ... }
177              
178             By doing this, one can effectively link one group of tests to
179             multplie places in the Synopses, leading to m-to-n correspondance.
180              
181             smartlinks.pl can take care of this kind of special cases.
182              
183             You can put a URL to create a generic link:
184              
185             L<"http://groups.google.de/group/perl.perl6.language/msg/07aefb88f5fc8429">
186              
187             or without quotes:
188              
189             L
190              
191             To see some examples, or look at the *.t files in the t/ directory of this project.
192              
193             There were also some legacy smartlinks using the following syntax:
194              
195             L
196             L<>
197             L<>
198              
199             They're no longer supported by util/smartlinks.pl. Use the current syntax.
200              
201             =head1 Basic Algorithm
202              
203             =over
204              
205             =item 1.
206              
207             We scan over all the specified .t files; collect smartlinks and positional
208             info about the test code snippets as we go. When all these work have been finished,
209             we obtain a tree structure, which is named C<$linktree> in the source code.
210              
211             To make this tree minimal, we only store the .t file name and line numbers, rather
212             than the snippets' source code itself.
213              
214             The structure of $linktree is like this:
215              
216             {
217             'S12' => {
218             'Traits' => [
219             [
220             undef,
221             [
222             't/oo/traits/basic.t',
223             '13',
224             '38'
225             ]
226             ],
227             [
228             '/If you say/',
229             [
230             't/oo/delegation.t',
231             '56',
232             '69'
233             ]
234             ],
235             ],
236             },
237             'S02' => {
238             'Whitespace and Comments' => [
239             [
240             '"Embedded comments" "#" plus any bracket',
241             [
242             't/syntax/comments.t',
243             10,
244             48
245             ]
246             ],
247             ]
248             }
249             }
250              
251             This step is mostly done by sub C.
252              
253             =item 2.
254              
255             We process the synopsis .pod files one by one and generate
256             HTML files integrated with test code snippets using the
257             C<$linktree> structure discussed above.
258              
259             This is mostly done by sub C.
260              
261             Because it is an enormous step, we can further divide it into several
262             sub steps:
263              
264             =over
265              
266             =item *
267              
268             We parse each .pod into a tree, which is known as C<$podtree> in the
269             source code. (See sub C.)
270              
271             The structure of C<$podtree> looks like this:
272              
273             {
274             'Names and Variables' => [
275             '=over 4' . "\n",
276             '=item *' . "\n",
277             'The C<$Package\'var> syntax is gone. Use C<$Package::var> instead.' . "\n",
278             '=item *' . "\n",
279             'Perl 6 includes a system of B to mark the fundamental' . "\n".
280             'structural type of a variable:' . "\n",
281             ...
282             ],
283             ...
284             }
285              
286             =item *
287              
288             We look up every related smartlink from every C<$podtree>, generate .t code
289             snippets along the way, and insert placeholders (like "_SMART_LINK_3" into
290             the corresponding C<$podtree>. (See subs C, C,
291             and C.)
292              
293             =item *
294              
295             Now we emit Pod source back from the modified $C's. (See sub C.)
296              
297             =item *
298              
299             After that, we generate HTML source from the Pod source with snippet placeholders
300             using L. (See sub C.)
301              
302             =item *
303              
304             At last, we replace every snippet placeholders in the HTML source with the real
305             snippet code (also in HTML format).
306              
307             =back
308              
309             =back
310              
311             =head1 SEE ALSO
312              
313             =over
314              
315             =item *
316              
317             F in the Pugs source tree.
318              
319             =item *
320              
321             The articles on the Pugs blogs:
322              
323             L
324              
325             L
326              
327             L
328              
329             =item *
330              
331             The synopses in L are generated by this script.
332              
333             =back
334              
335             =head1 METHODS
336              
337             =cut
338              
339             =head2 new
340              
341             Constructor, can get a HASH reference as it is a base class
342             of L
343              
344             =cut
345              
346             sub new {
347 6     6 1 8030 my $class = shift;
348              
349 6         65 my $self = $class->SUPER::new(@_);
350              
351 6         95 $self->{link_count} = 0;
352 6         18 $self->{broken_link_count} = 0;
353 6         15 $self->{snippet_id} = 0;
354 6         19 $self->{test_files_missing_links} = [];
355 6   50     49 $self->{out_dir} ||= '.';
356 6         18 $self->{errors} = [];
357            
358 6         17 $self->{invalid_link} = 0;
359              
360 6         22 return $self;
361             }
362              
363             =head2 process_test_files
364              
365             Gets a list of .t test files, calls L on each on of them.
366              
367             =cut
368              
369             sub process_test_files {
370 0     0 1 0 my ($self, @t_files) = @_;
371              
372 0         0 $self->{test_files} = \@t_files;
373              
374 0         0 for my $t_file (@t_files) {
375 0         0 my $links = $self->process_t_file($t_file);
376 0 0       0 if ($links) {
377 0 0       0 print "Found $links links in <$t_file>\n" if defined $self->count;
378             } else {
379 0 0       0 print "No smartlink found in <$t_file>\n" if defined $self->print_missing;
380 0 0       0 print "\"$t_file\"\n" if defined $self->wiki;
381 0         0 push @{ $self->{test_files_missing_links} }, $t_file;
  0         0  
382             }
383             }
384             }
385              
386             =head2 process_t_file
387              
388             Gets a path to a .t file, reads line by line and collects
389             the smartlinks in it to a hash structure using the
390             C function.
391              
392             =cut
393              
394             sub process_t_file {
395 4     4 1 28 my ($self, $infile) = @_;
396              
397 4 50       280 open my $in, $infile or
398             die "error: Can't open $infile for reading: $!\n";
399 4         8 my ($setter, $from, $to);
400 4         7 my $found_link = 0;
401 4         136 while (<$in>) {
402 219         242 chomp;
403 219         223 my $new_from;
404 219         203 my ($synopsis, $section, $pattern);
405 219 100       940 if (m{L<"?http://}) {
    100          
    100          
    100          
    100          
406             # TODO shall we also collect the http links for later reuse?
407 5         15 next;
408             }
409             elsif (m{^ \s* \# \s* (L<<+)}xoi) {
410 3         25 $self->error("Legacy smartlink. Use L< instead of $1 in line $. '$_' in file '$infile'");
411 3         46 $self->{invalid_link}++;
412 3         9 next;
413             }
414             elsif (m{^ \s* \# \s* L< ([^/]+) / ([^/]+) >\s*$}xo) {
415 5         12 ($synopsis, $section) = ($1, $2);
416 5         19 $section =~ s/^\s+|\s+$//g;
417 5         6 $section =~ s/^"(.*)"$/$1/;
418             #warn "$synopsis $section" if $synopsis eq 'S06';
419 5         9 $new_from = $.;
420 5         6 $to = $. - 1;
421 5         5 $found_link++;
422             }
423             # extended and multiline smartlinks
424             elsif (m{^ \s* \# \s* L(<) ([^/]+) / ([^/]+) / (.*) }xo) {
425             #warn "$1, $2, $3\n";
426 10         12 my $brackets;
427 10         43 ($brackets, $synopsis, $section, $pattern) = ($1, $2, $3, $4);
428 10         15 $brackets = length($brackets);
429 10         51 $section =~ s/^\s+|\s+$//g;
430 10         21 $section =~ s/^"(.*)"$/$1/;
431 10 50       22 if (!$section) {
432 0         0 $self->error("$infile: line $.: section name can't be empty.");
433             }
434 10         56 $pattern =~ s/^\s+|\s+$//g;
435 10 100       26 if (substr($pattern, -1, 1) ne '>') {
436 2         6 $_ = <$in>;
437 2         17 s/^\s*\#?\s*|\s+$//g;
438 2 50       34 if (!s/>{$brackets}$//) {
439 0         0 $self->error("$infile: line $.: smart links must terminate in the second line.");
440 0         0 next;
441             }
442 2         7 $pattern .= " $_";
443 2         66 $new_from = $. - 1;
444 2         5 $to = $. - 2;
445             } else {
446 8         15 $new_from = $.;
447 8         11 $to = $. - 1;
448 8         98 $pattern =~ s/\s*>{$brackets}$//;
449             }
450             #warn "*$synopsis* *$section* *$pattern*\n";
451 10         19 $found_link++;
452             }
453             # there are some # L<"http://... links that we should skip for now
454             # and not even report them as errors.
455             # any other L< thing should be reported.
456             elsif (m{^ \s* \# \s* L<}xoi) {
457 1         9 $self->error("Could not parse smartlink in line $. '$_' in file '$infile'");
458 1         9 $self->{invalid_link}++;
459 1         4 next;
460             }
461             else {
462 195         521 next;
463             }
464              
465             #warn "*$synopsis* *$section*\n";
466 15 50 66     62 if ($from and $from == $to) {
467 0         0 my $old_setter = $setter;
468 0         0 my $old_from = $from;
469             $setter = sub {
470 0     0   0 $self->add_link($synopsis, $section, $pattern, $infile, $_[0], $_[1]);
471 0         0 $old_setter->($old_from, $_[1]);
472             #warn "$infile - $old_from ~ $_[1]";
473 0         0 };
474             #warn "$infile - $from ~ $to";
475             } else {
476 15 100 66     74 $setter->($from, $to) if $setter and $from;
477             $setter = sub {
478 15     15   44 $self->add_link($synopsis, $section, $pattern, $infile, $_[0], $_[1]);
479 15         57 };
480             }
481 15         81 $from = $new_from;
482             }
483 4 50 33     29 $setter->($from, $.) if $setter and $from;
484 4         56 close $in;
485             # print "No smartlink found in <$infile>\n" if (defined $print_missing && $found_link == 0);
486 4         27 return $found_link;
487             }
488              
489             =begin private
490              
491             =head2 add_link
492              
493             add_link($synopsis, $section, $pattern, $infile, $from, $to);
494              
495             =end private
496              
497             =cut
498              
499             # TODO add tests
500             sub add_link {
501 15     15 1 32 my ($self, $synopsis, $section, $pattern, $t_file, $from, $to) = @_;
502            
503 15 50       28 if ($from == $to) {
504 0         0 warn "WARNING: empty snippet detected at $t_file (line $from ~ $to).\n";
505             }
506 15   100     75 $self->{linktree}->{$synopsis} ||= {};
507 15   100     78 $self->{linktree}->{$synopsis}->{$section} ||= [];
508 15 50 66     58 if ($pattern and substr($pattern, -1, 1) eq '/') { $pattern = "/$pattern"; }
  0         0  
509 15         17 push @{ $self->{linktree}->{$synopsis}->{$section} },
  15         54  
510             [$pattern => [$t_file, $from, $to]];
511            
512 15         41 return $self->link_count_inc;
513             }
514              
515             =head2 parse_pattern
516              
517             Convert patterns used in 00-smartlinks.to perl 5 regexes
518              
519             =cut
520              
521             sub parse_pattern {
522 6     6 1 5961 my ($self, $pat) = @_;
523              
524 6         9 my @keys;
525 6         9 while (1) {
526 23 100 100     195 if ($pat =~ /\G\s*"([^"]+)"/gc ||
      100        
527             $pat =~ /\G\s*'([^']+)'/gc ||
528             $pat =~ /\G\s*(\S+)/gc) {
529 17         43 push @keys, $1;
530 6         12 } else { last }
531             }
532 17         28 my $str = join('.+?', map {
533 6         33 my $key = quotemeta $_;
534 17         71 $key =~ s/^\w/\\b$&/;
535 17         119 $key =~ s/\w$/$&\\b/;
536 17         53 $key;
537             } @keys);
538              
539 6         28 $str;
540             }
541              
542             =head2 process_paragraph
543              
544             Process paragraphs of the pod file: unwrap lines, strip POD tags, and etc.
545              
546             =cut
547              
548             sub process_paragraph {
549 4     4 1 1944 my ($self, $str) = @_;
550              
551             # unwrap lines:
552 4         44 $str =~ s/\s*\n\s*/ /g;
553              
554             # strip POD tags:
555             # FIXME: obviously we need a better way to do this:
556 4         8 $str =~ s/[LCFIB]<<<\s+(.*?)\s+>>>/$1/g;
557 4         12 $str =~ s/[LCFIB]<<\s+(.*?)\s+>>/$1/g;
558 4         26 $str =~ s/[LCFIB]<(.*?)>/$1/g;
559 4         15 $str;
560             }
561              
562             =head2 gen_code_snippet
563              
564             Gets a triplet of [file, from, to] and generates an HTML
565             snippet from that section of the given file.
566              
567              
568             Note that this function has been optimized for space rather
569             than time.
570              
571             =cut
572              
573             sub gen_code_snippet {
574 0     0 1 0 my ($self, $location) = @_;
575 0         0 my ($file, $from, $to) = @$location;
576             #warn "gen_code_snippet: @$location\n";
577 0 0       0 open my $in, $file or
578             die "Can't open $file for reading: $!\n";
579              
580             # Strip leading realpath so the names start at t/
581 0         0 $file =~ s{.*?/t/}{t/};
582              
583 0         0 my $i = 1;
584 0         0 my $src;
585             my $file_info;
586 0 0       0 $file_info = $self->{test_result}->{$file} if $self->{test_result};
587 0         0 my ($ok_count, $failed_count) = (0, 0);
588 0         0 while (<$in>) {
589 0 0       0 next if $i < $from;
590 0 0       0 last if $i > $to;
591 0         0 s/\&/\&/g;
592 0         0 s/"/\"/g;
593 0         0 s/
594 0         0 s/>/\>/g;
595 0         0 s{^( *)}{"  " x (length($1) / 2)}gem;
  0         0  
596 0         0 s/ /  /g;
597 0         0 s{L\<(http://.*?)\>}{L\<$1\>}g;
598 0         0 s{L\<\"(http://.*?)\"\>}
599             {L\<\"$1\"\>}g;
600 0         0 my $mark = '';
601 0 0       0 if ($file_info) {
602 0         0 chomp;
603 0 0       0 if (!exists $file_info->{$i}) {
    0          
604 0         0 $mark = '';
605             } elsif ($file_info->{$i}) {
606 0         0 $mark = qq{ √ };
607 0         0 $ok_count++;
608             } else {
609 0         0 $mark = qq{ × };
610 0         0 $failed_count++;
611             }
612             }
613 0         0 $src .= qq{
$mark$_
614 0         0 } continue { $i++ }
615              
616 0         0 close $in;
617              
618 0         0 $src =~ s/\n+$//sg;
619              
620 0         0 my $snippet_id = $self->snippet_id_inc;
621              
622             #warn $snippet_id;
623             #warn "$file $to $from";
624 0 0       0 warn "NOT DEFINED!!! @$location $snippet_id" if !defined $src;
625              
626 0         0 my $snippet;
627 0 0       0 if (!$self->{test_result}) {
628             #warn "No test results for $file $from to $to";
629 0         0 $snippet = qq{
$src
};
630             } else {
631 0         0 $snippet = qq{
632            
633             $src
634            
635             };
636             }
637              
638 0         0 my $stat;
639 0 0       0 if ($self->{test_result}) {
640 0 0 0     0 if ($ok_count == 0 && $failed_count == 0) {
641 0         0 $stat = " (no results)";
642             } else {
643 0         0 $stat = " ($ok_count √, $failed_count ×)";
644             }
645             } else {
646 0         0 $stat = '';
647             }
648              
649 0         0 my $nlines = $to - $from + 1;
650 0         0 my $html_file = $file;
651 0         0 $html_file =~ s{t/}{};
652 0         0 my $simple_html = $html_file . ".simple.html";
653 0         0 my $full_html = $html_file . ".html";
654 0         0 my $simple_snippet_id = "simple_$snippet_id";
655              
656 0         0 my $html = <<"_EOC_";
657            

From $file lines $from–$to$stat: (skip)

658            
659             $snippet
660            
661              
662             Highlighted:
663            
664             onclick="return toggle_hilite('$simple_snippet_id','/~azawawi/html/$simple_html')">small|full
665            
666            
667             _EOC_
668 0         0 $self->set_snippet($snippet_id, $html);
669              
670 0         0 return "\n\n_SMART_LINK_$snippet_id\n\n";
671             }
672              
673             =head2 get_javascript
674              
675             Returns the content of the smartlink.js file.
676             Probably we should just copy the .js file to the html directory
677             and not embed it.
678              
679             =cut
680              
681             sub get_javascript {
682              
683             # for the test scripts in t/ and the smartlinks.pl in script/ directory
684 1     1 1 512 my $file = File::Spec->catfile($FindBin::Bin, '..', 'share', 'smartlinks.js');
685            
686 1 50       45 if (not -e $file) {
687             # for smarlinks.pl in utils/ directory of Pugs if Text::SmartLinks is not installed
688 0         0 $file = File::Spec->catfile($FindBin::Bin, 'Text-SmartLinks', 'share', 'smartlinks.js');
689             }
690              
691             # installed version of the file
692 1 50       22 if (not -e $file) {
693 0         0 $file = File::Spec->catfile(File::ShareDir::dist_dir('Text-SmartLinks'), 'smartlinks.js');
694             }
695 1 50       4 if (not $file) {
696 0         0 warn "Could not find 'smartlinks.js'\n";
697 0         0 return '';
698             }
699             #warn $file;
700 1 50       54 if (open my $fh, '<', $file) {
701 1         5 local $/ = undef;
702 1         47 return <$fh>;
703             }
704 0         0 warn "could not open '$file'";
705 0         0 return '';
706             }
707              
708             sub test_files_missing_links {
709 0     0 0 0 return @{ $_[0]->{test_files_missing_links} };
  0         0  
710             }
711              
712              
713             sub emit_pod {
714 0     0 0 0 my ($self, $podtree) = @_;
715              
716 0         0 my $str;
717 0 0       0 $str .= $podtree->{_header} if $podtree->{_header};
718 0         0 for my $elem (@{ $podtree->{_sections} }) {
  0         0  
719 0         0 my ($num, $sec) = @$elem;
720 0         0 $str .= "=head$num $sec\n\n";
721 0         0 for my $para (@{ $podtree->{$sec} }) {
  0         0  
722 0 0       0 if ($para eq '') {
    0          
723 0         0 $str .= "\n";
724             } elsif ($para =~ /^\s+/) {
725 0         0 $str .= $para;
726             } else {
727 0         0 $str .= "$para\n";
728             }
729             }
730             }
731 0 0       0 $str = "=pod\n\n_LINE_ANCHOR_1\n\n$str" if $self->line_anchor;
732              
733 0         0 return $str;
734             }
735              
736             sub parse_pod {
737 0     0 0 0 my ($self, $pod) = @_;
738 0         0 my $podtree = {};
739 0         0 my $section;
740 0         0 foreach (@$pod) {
741 0 0       0 if (/^ =head(\d+) \s* (.*\S) \s* $/x) {
    0          
    0          
    0          
742             #warn "parse_pod: *$1*\n";
743 0         0 my $num = $1;
744 0         0 $section = $2;
745 0   0     0 $podtree->{_sections} ||= [];
746 0         0 push @{ $podtree->{_sections} }, [$num, $section];
  0         0  
747             } elsif (!$section) {
748 0         0 $podtree->{_header} .= $_;
749             } elsif (/^\s*$/) {
750 0   0     0 $podtree->{$section} ||= [];
751             #push @{ $podtree->{$section} }, "\n";
752 0         0 my @new = ('');;
753 0 0 0     0 if ($self->line_anchor and $podtree->{$section}->[-1] !~ /^=over\b|^=item\b/) {
754 0         0 unshift @new, "_LINE_ANCHOR_$.\n";
755             }
756 0         0 push @{ $podtree->{$section} }, @new;
  0         0  
757             } elsif (/^\s+(.+)/) {
758 0   0     0 $podtree->{$section} ||= [''];
759 0         0 $podtree->{$section}->[-1] .= $_;
760 0         0 push @{ $podtree->{$section} }, '';
  0         0  
761             } else {
762 0   0     0 $podtree->{$section} ||= [''];
763 0         0 $podtree->{$section}->[-1] .= $_;
764             }
765             }
766 0         0 $podtree;
767             }
768              
769              
770             sub process_yml_file {
771 0     0 0 0 my ($self, $yml_file) = @_;
772 0 0       0 if ($yml_file) {
773 0         0 eval {
774 0         0 require Test::TAP::Model;
775 0         0 require YAML::Syck;
776             };
777 0 0       0 if ($@) {
778 0         0 die "--smoke-res option requires both Test::TAP::Model and YAML::Syck. ".
779             "At least one of them is not installed.\n";
780             }
781 0         0 my $data = YAML::Syck::LoadFile($yml_file);
782             #warn $data;
783 0         0 my $structure;
784 0 0       0 if ($data->{meat}) {
785 0         0 $structure = delete $data->{meat};
786             }
787 0         0 my $tap = Test::TAP::Model->new_with_struct($structure);
788 0         0 for my $file ($tap->test_files) {
789             #warn " $file...\n";
790 0         0 (my $fname = $file->name) =~ s{.*?/t/}{t/};
791 0         0 my %file_info;
792 0         0 $self->{test_result}->{$fname} = \%file_info;
793 0         0 for my $case ($file->cases) {
794 0 0 0     0 next if $case->skipped or !$case->test_line;
795 0         0 $file_info{$case->test_line} = $case->actual_ok;
796             }
797             }
798             #YAML::Syck::DumpFile('test_result.yml', $self->{test_result});
799 0         0 my $smoke_rev = $data->{revision};
800 0         0 $self->smoke_rev($smoke_rev);
801 0 0       0 $smoke_rev = $smoke_rev ? "r$smoke_rev" : 'unknown';
802 0         0 warn "info: pugs smoke is at $smoke_rev.\n";
803             }
804             }
805              
806              
807             sub gen_html {
808 0     0 0 0 my ($self, $pod, $title) = @_;
809              
810 0         0 $Pod::Simple::HTML::Perldoc_URL_Prefix = 'http://perlcabal.org/syn/';
811 0         0 $Pod::Simple::HTML::Perldoc_URL_Postfix = '.html';
812              
813 0         0 $Pod::Simple::HTML::Content_decl =
814             q{};
815              
816 0         0 $Pod::Simple::HTML::Doctype_decl =
817             qq{
818             "http://www.w3.org/TR/html4/loose.dtd">\n};
819              
820 0         0 my $pod2html = new Pod::Simple::HTML;
821 0         0 $pod2html->index(1);
822 0         0 $pod2html->html_css($self->cssfile);
823 0         0 my $javascript = $self->get_javascript();
824 0         0 $pod2html->html_javascript(qq{});
825 0         0 $pod2html->force_title($title);
826              
827 0         0 my $html;
828 0         0 open my $in, '<', \$pod;
829 0         0 open my $out, '>', \$html;
830 0         0 $pod2html->parse_from_file($in, $out);
831              
832             # substitutes the placeholders introduced by `gen_code_snippet`
833             # with real code snippets:
834 0         0 $html =~ s,(?:

\s*)?\b_SMART_LINK_(\d+)\b(?:\s*

)?,$self->get_snippet($1),sge;
  0         0  
835 0 0       0 $self->fix_line_anchors(\$html) if $self->line_anchor;
836 0         0 $self->add_footer(\$html);
837 0         0 $self->add_user_css(\$html);
838            
839 0         0 return $html
840             }
841              
842              
843              
844             sub _gen_line_anchors {
845 0     0   0 my $list = shift;
846 0         0 my $curr = shift @$list;
847 0         0 my $html = '';
848 0         0 for ($curr .. $list->[0] - 1) {
849 0         0 $html .= qq{\n};
850             }
851 0         0 $html;
852             }
853              
854             sub fix_line_anchors {
855 0     0 0 0 my ($self, $html) = @_;
856 0         0 my @lineno; # line numbers for each paragraph
857 0         0 while ($$html =~ /\b_LINE_ANCHOR_(\d+)\b/gsm) {
858 0         0 push @lineno, $1;
859             }
860 0         0 $$html =~ s{(?:

\s*)?\b_LINE_ANCHOR_(\d+)\b(?:\s*

)?}{ _gen_line_anchors(\@lineno) }sge;
  0         0  
861             }
862              
863              
864             sub add_footer {
865 0     0 0 0 my ($self, $html) = @_;
866 0         0 $$html =~ s{}{
867             [ Top ]  
868             [ Index of Synopses ]
869             };
870             }
871              
872             # isn't there a prettier way to do this?
873             sub add_user_css {
874 0     0 0 0 my ($self, $html) = @_;
875 0         0 my $user_css = << '.';
876            
895             .
896 0         0 $$html =~ s{()}{$user_css\n$1};
897             }
898              
899             sub gen_preamble {
900 0     0 0 0 my ($self) = @_;
901              
902 0         0 my ($sec, $min, $hour, $mday, $mon, $year) = gmtime;
903 0         0 $year += 1900; $mon += 1;
  0         0  
904 0         0 my $time = sprintf "%04d-%02d-%02d %02d:%02d:%02d GMT",
905             $year, $mon, $mday, $hour, $min, $sec;
906 0         0 my $smoke_rev = $self->smoke_rev;
907 0 0       0 my $smoke_info = $smoke_rev ?
908             qq(, pugs-smoke $smoke_rev)
909             :
910             '';
911 0         0 my $pugs_rev = $self->version;
912 0 0       0 $pugs_rev = $pugs_rev ? "r$pugs_rev" : 'unknown';
913 0   0     0 $pugs_rev ||= $smoke_rev;
914              
915 0         0 return qq{
916             This page was generated at $time.
917             (syn $pugs_rev$smoke_info)
918               [ Index of Synopses ]
919            
920             };
921             }
922              
923             sub create_stats_page {
924 0     0 0 0 my ($self) = @_;
925 0         0 my $file = File::Spec->catfile($self->out_dir, 'stats.html');
926 0         0 my $html = "Stats";
927 0         0 $html .= $self->gen_preamble;
928              
929 0         0 my $test_file_count = scalar @{ $self->test_files };
  0         0  
930 0         0 my $test_files_missing_links = scalar $self->test_files_missing_links;
931 0         0 $html .= sprintf("info: %s smartlinks found and %s broken in $test_file_count test files ($test_files_missing_links test files had no links).\n",
932             $self->link_count ,$self->broken_link_count);
933             #if (!$self->check and $self->broken_link_count > 0) {
934             # warn "hint: use the --check option for details on broken smartlinks.\n";
935             #}
936            
937 0 0       0 if ($self->test_files_missing_links) {
938 0         0 $html .= "

Test files without links

\n
    ";
939 0         0 foreach my $file ($self->test_files_missing_links) {
940 0         0 $html .= "
  • $file
  • \n";
    941             }
    942 0         0 $html .= "\n";
    943             }
    944 0 0       0 if (@{ $self->{errors} }) {
      0         0  
    945 0         0 $html .= "

    Errors

    \n
      ";
    946 0         0 foreach my $e (@{ $self->{errors} }) {
      0         0  
    947 0         0 $html .= "
  • " . CGI::escapeHTML(join "", @$e) . "
  • \n";
    948             }
    949 0         0 $html .= "\n";
    950             }
    951            
    952            
    953 0         0 $html .= "";
    954 0         0 write_file($file, $html);
    955              
    956 0         0 return;
    957             }
    958              
    959             sub outfile_name {
    960 0     0 0 0 my ($self, $infile) = @_;
    961              
    962 0         0 (my $syn_id = $infile) =~ s/\.(pod|pm)$//;
    963 0         0 $syn_id =~ s{[/\\]}{::}g;
    964              
    965             # special case for Perl 6 Synopsis
    966 0 0       0 if ($ENV{PUGS_SMARTLINKS}) {
    967 0         0 $syn_id =~ s{(S\d+)-[^:]+}{$1};
    968             }
    969 0         0 (my $outfile = $syn_id) =~ s{::}{/}g;
    970 0         0 $outfile .= ".html";
    971 0         0 return ($outfile, $syn_id);
    972             }
    973              
    974             =begin private
    975              
    976             =head2 process_pod_file
    977              
    978             process_pod_file($syn);
    979              
    980             Process synopses one by one.
    981              
    982             =end private
    983              
    984             =cut
    985              
    986             sub process_pod_file {
    987 0     0 1 0 my ($self, $root, $infile) = @_;
    988              
    989 0         0 my ($outfile, $syn_id) = $self->outfile_name($infile);
    990 0         0 my $out_dir = $self->out_dir;
    991              
    992 0         0 my @pod = read_file(File::Spec->catfile($root, $infile));
    993 0 0       0 if (grep /^=begin pod/, @pod) {
    994 0         0 $self->process_perl6_file(
    995             \@pod,
    996             File::Spec->catfile($out_dir, $outfile));
    997             } else {
    998 0         0 $self->process_perl5_file(
    999             \@pod,
    1000             File::Spec->catfile($out_dir, $outfile),
    1001             $syn_id);
    1002             }
    1003             }
    1004              
    1005             sub process_perl5_file {
    1006 0     0 0 0 my ($self, $pod, $outfile, $syn_id) = @_;
    1007              
    1008 0         0 my $podtree = $self->parse_pod($pod);
    1009 0         0 my $linktree_sections = $self->{linktree}->{$syn_id};
    1010              
    1011 0         0 foreach my $section_name (sort keys %$linktree_sections) {
    1012 0         0 my $links = $linktree_sections->{$section_name};
    1013 0         0 my @links = @$links;
    1014 0         0 my $paras = $podtree->{$section_name};
    1015 0 0       0 if (!$paras) {
    1016 0         0 foreach my $link (@$links) {
    1017 0         0 my ($t_file, $from) = @{ $link->[1] };
      0         0  
    1018 0         0 $from--;
    1019 0         0 $self->error("$t_file: line $from: section '$section_name' not found in $syn_id.");
    1020 0         0 $self->broken_link_count_inc;
    1021             }
    1022 0         0 next;
    1023             }
    1024 0         0 for my $link (reverse @links) {
    1025 0         0 my ($pattern, $location) = @$link;
    1026 0         0 my $i = 0;
    1027 0 0       0 if (!$pattern) { # match the whole section
    1028 0 0       0 if (!$self->check) {
    1029 0         0 unshift @$paras, $self->gen_code_snippet($location);
    1030 0         0 $i = 1;
    1031             }
    1032 0         0 next;
    1033             }
    1034 0         0 my $regex = $self->parse_pattern($pattern);
    1035 0         0 my $matched;
    1036 0         0 while ($i < @$paras) {
    1037 0         0 my $para = $paras->[$i];
    1038 0 0 0     0 next if !$para or $para =~ /\?hide_quotes=no/;
    1039 0 0       0 if ($self->process_paragraph($para) =~ /$regex/) {
    1040 0 0       0 if (!$self->check) {
    1041 0         0 splice @$paras, $i+1, 0, $self->gen_code_snippet($location);
    1042 0         0 $i++;
    1043             }
    1044 0         0 $matched = 1;
    1045 0         0 last;
    1046             }
    1047 0         0 } continue { $i++ }
    1048 0 0       0 if (!$matched) {
    1049 0         0 my ($file, $lineno) = @$location;
    1050 0         0 $self->error("$file: line $lineno: pattern '$pattern' failed to match any paragraph in L<${syn_id}/${section_name}>.");
    1051 0         0 $self->broken_link_count_inc;
    1052             }
    1053             }
    1054             }
    1055              
    1056             # We need this to check invalid smartlinks pointed to non-existent docs:
    1057 0         0 delete $self->{linktree}->{$syn_id};
    1058              
    1059 0 0       0 if (!$self->check) {
    1060 0         0 my $pod = $self->emit_pod($podtree);
    1061 0         0 my $html = $self->gen_html($pod, $syn_id);
    1062 0         0 my $preamble = $self->gen_preamble();
    1063 0         0 $html =~ s{}{$&$preamble};
    1064 0         0 warn "info: generating $outfile...\n";
    1065 0         0 mkpath dirname($outfile);
    1066 0         0 write_file($outfile, $html);
    1067             }
    1068             }
    1069              
    1070             sub process_perl6_file {
    1071 0     0 0 0 my ($self, $pod, $outfile) = @_;
    1072              
    1073 0 0       0 return if $self->check;
    1074 0         0 eval "use Perl6::Perldoc 0.000005; use Perl6::Perldoc::Parser; use Perl6::Perldoc::To::Xhtml;";
    1075 0 0       0 if ($@) {
    1076 0         0 warn "Please install Perl6::Perldoc v0.0.5 from the CPAN to generate $outfile";
    1077 0         0 return;
    1078             }
    1079              
    1080 0         0 my $toc = "=TOC\nP\n\n";
    1081 0         0 my $pod6 = $toc . join "", @$pod;
    1082              
    1083 0         0 my $perldochtml = Perl6::Perldoc::Parser->parse(
    1084             \$pod6, {all_pod => 1}
    1085             )->report_errors()->to_xhtml(
    1086             {full_doc => {title => basename($outfile)}}
    1087             );
    1088 0         0 my $css = $self->cssfile;
    1089 0         0 $perldochtml =~ s{}{\n$&};
    1090 0         0 my $preamble = $self->gen_preamble();
    1091 0         0 $perldochtml =~ s{}{$&$preamble};
    1092 0         0 $self->add_footer(\$perldochtml);
    1093              
    1094 0         0 warn "info: generating $outfile...\n";
    1095 0         0 write_file($outfile, $perldochtml);
    1096 0         0 return;
    1097             }
    1098              
    1099             sub report_stats {
    1100 0     0 0 0 my ($self) = @_;
    1101              
    1102 0         0 my $test_file_count = scalar @{ $self->{test_files} };
      0         0  
    1103 0         0 my $test_files_missing_links = scalar $self->test_files_missing_links;
    1104 0         0 warn sprintf("info: %s smartlinks found and %s broken in $test_file_count test files ($test_files_missing_links test files had no links).\n",
    1105             $self->link_count ,$self->broken_link_count);
    1106 0 0 0     0 if (!$self->check and $self->broken_link_count > 0) {
    1107 0         0 warn "hint: use the --check option for details on broken smartlinks.\n";
    1108             }
    1109             }
    1110              
    1111             sub report_broken_links {
    1112 0     0 0 0 my ($self) = @_;
    1113              
    1114 0         0 foreach my $syn (sort keys %{ $self->{linktree} }) {
      0         0  
    1115 0         0 my $linktree_sections = $self->{linktree}{$syn};
    1116 0         0 for my $section (sort keys %$linktree_sections) {
    1117 0         0 my $links = $linktree_sections->{$section};
    1118 0         0 for my $link (@$links) {
    1119 0         0 my ($file, $lineno) = @{ $link->[1] };
      0         0  
    1120 0         0 $self->error("$file: line $lineno: smartlink pointing to an unknown synopsis ($syn) section $section"),
    1121             $self->broken_link_count_inc;
    1122             }
    1123             }
    1124             }
    1125             }
    1126              
    1127             sub create_index {
    1128 0     0 0 0 my ($self) = @_;
    1129 0         0 my $out_dir = $self->out_dir;
    1130              
    1131 0         0 my $html = qq(Documentation\n);
    1132 0         0 foreach my $file (sort @{ $self->{docs} }) {
      0         0  
    1133 0         0 my ($outfile, $syn_id) = $self->outfile_name($file, 1); # TODO remove Pugs hardcoding
    1134 0         0 $html .= qq($file
    \n);
    1135             }
    1136 0         0 $html .= qq(
    stats and errors);
    1137 0         0 $html .= qq();
    1138              
    1139 0 0       0 if (open my $fh, '>', "$out_dir/index.html") {
    1140 0         0 print {$fh} $html;
      0         0  
    1141             } else {
    1142 0         0 warn "Could not create index.html: $!";
    1143             }
    1144 0         0 return;
    1145             }
    1146              
    1147              
    1148 0     0 0 0 sub snippet_id_inc { $_[0]->{snippet_id}++ };
    1149 0     0 0 0 sub snippet_id { $_[0]->{snippet_id} };
    1150              
    1151             =head2 link_count
    1152              
    1153             link_count_inc increments the link counter.
    1154              
    1155             link_count returns the current number of links.
    1156              
    1157             =cut
    1158              
    1159 16     16 0 45 sub link_count_inc { $_[0]->{link_count}++ };
    1160 6     6 1 591 sub link_count { $_[0]->{link_count} };
    1161              
    1162 0     0 0 0 sub broken_link_count_inc { $_[0]->{broken_link_count}++ };
    1163 4     4 0 22 sub broken_link_count { $_[0]->{broken_link_count} };
    1164              
    1165             sub error {
    1166 4     4 0 9 my $self = shift;
    1167              
    1168 4         5 push @{ $self->{errors} }, [@_];
      4         13  
    1169 4 50       19 if ($self->check) { warn "ERROR: @_\n"; }
      0            
    1170             }
    1171              
    1172             sub set_snippet {
    1173 0     0 0   my ($self, $id, $str) = @_;
    1174 0           $self->{snippets}[$id] = $str;
    1175             }
    1176             sub get_snippet {
    1177 0     0 0   my ($self, $id) = @_;
    1178 0           return $self->{snippets}[$id];
    1179             }
    1180              
    1181             =head1 AUTHOR
    1182              
    1183             Agent Zhang (Eagentzh@gmail.comE) wrote the initial
    1184             implementation, getting help from many others in the Pugs team.
    1185              
    1186             Current maintainer: The Pugs team
    1187              
    1188             =head1 COPYRIGHT
    1189              
    1190             Copyright (c) 2006 - 2009 by the Pugs Team.
    1191              
    1192             =head1 LICENSE
    1193              
    1194             Text::SmartLinks is free software; you can redistribute it and/or modify it under the
    1195             terms of the Artistic License 2.0. (Note that, unlike the Artistic License
    1196             1.0, version 2.0 is GPL compatible by itself, hence there is no benefit to
    1197             having an Artistic 2.0 / GPL disjunction.)
    1198              
    1199             =cut
    1200              
    1201              
    1202             1;