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 |
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 |
||||||||||||||||||||||
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 |
||||||||||||||||||||||
113 | L |
||||||||||||||||||||||
114 | # but is NOT required. | ||||||||||||||||||||||
115 | L |
||||||||||||||||||||||
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 |
||||||||||||||||||||||
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 |
||||||||||||||||||||||
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 |
||||||||||||||||||||||
291 | and C |
||||||||||||||||||||||
292 | |||||||||||||||||||||||
293 | =item * | ||||||||||||||||||||||
294 | |||||||||||||||||||||||
295 | Now we emit Pod source back from the modified $C |
||||||||||||||||||||||
296 | |||||||||||||||||||||||
297 | =item * | ||||||||||||||||||||||
298 | |||||||||||||||||||||||
299 | After that, we generate HTML source from the Pod source with snippet placeholders | ||||||||||||||||||||||
300 | using L |
||||||||||||||||||||||
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 |
||||||||||||||||||||||
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 |
||||||||||||||||||||||
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 |
||||||||||||||||||||||
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\" |
|||||||||||||||||||
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 |
||||||||||||||||||||||
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/\</g; | ||||||||||||||||||||
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 |
|
||||||||||||||||||||||
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{ |
}{