File Coverage

blib/lib/Regexp/Common/comment.pm
Criterion Covered Total %
statement 33 52 63.4
branch 2 8 25.0
condition n/a
subroutine 11 12 91.6
pod 0 5 0.0
total 46 77 59.7


line stmt bran cond sub pod time code
1             package Regexp::Common::comment;
2              
3 71     71   593 use 5.10.0;
  71         145  
4              
5 71     71   231 use strict;
  71         230  
  71         1302  
6 71     71   224 use warnings;
  71         66  
  71         1501  
7 71     71   190 no warnings 'syntax';
  71         90  
  71         1873  
8              
9 71     71   825 use Regexp::Common qw /pattern clean no_defaults/;
  71         86  
  71         328  
10              
11             our $VERSION = '2016060801';
12              
13             my @generic = (
14             {languages => [qw /ABC Forth/],
15             to_eol => ['\\\\']}, # This is for just a *single* backslash.
16              
17             {languages => [qw /Ada Alan Eiffel lua/],
18             to_eol => ['--']},
19              
20             {languages => [qw /Advisor/],
21             to_eol => ['#|//']},
22              
23             {languages => [qw /Advsys CQL Lisp LOGO M MUMPS REBOL Scheme
24             SMITH zonefile/],
25             to_eol => [';']},
26              
27             {languages => ['Algol 60'],
28             from_to => [[qw /comment ;/]]},
29              
30             {languages => [qw {ALPACA B C C-- LPC PL/I}],
31             from_to => [[qw {/* */}]]},
32              
33             {languages => [qw /awk fvwm2 Icon m4 mutt Perl Python QML
34             R Ruby shell Tcl/],
35             to_eol => ['#']},
36              
37             {languages => [[BASIC => 'mvEnterprise']],
38             to_eol => ['[*!]|REM']},
39              
40             {languages => [qw /Befunge-98 Funge-98 Shelta/],
41             id => [';']},
42              
43             {languages => ['beta-Juliet', 'Crystal Report', 'Portia', 'Ubercode'],
44             to_eol => ['//']},
45              
46             {languages => ['BML'],
47             from_to => [['']],
48             },
49              
50             {languages => [qw /C++/, 'C#', qw /Cg ECMAScript FPL Java JavaScript/],
51             to_eol => ['//'],
52             from_to => [[qw {/* */}]]},
53              
54             {languages => [qw /CLU LaTeX slrn TeX/],
55             to_eol => ['%']},
56              
57             {languages => [qw /False/],
58             from_to => [[qw !{ }!]]},
59              
60             {languages => [qw /Fortran/],
61             to_eol => ['!']},
62              
63             {languages => [qw /Haifu/],
64             id => [',']},
65              
66             {languages => [qw /ILLGOL/],
67             to_eol => ['NB']},
68              
69             {languages => [qw /INTERCAL/],
70             to_eol => [q{(?:(?:PLEASE(?:\s+DO)?|DO)\s+)?(?:NOT|N'T)}]},
71              
72             {languages => [qw /J/],
73             to_eol => ['NB[.]']},
74              
75             {languages => [qw /JavaDoc/],
76             from_to => [[qw {/** */}]]},
77              
78             {languages => [qw /Nickle/],
79             to_eol => ['#'],
80             from_to => [[qw {/* */}]]},
81              
82             {languages => [qw /Oberon/],
83             from_to => [[qw /(* *)/]]},
84            
85             {languages => [[qw /Pascal Delphi/], [qw /Pascal Free/], [qw /Pascal GPC/]],
86             to_eol => ['//'],
87             from_to => [[qw !{ }!], [qw !(* *)!]]},
88              
89             {languages => [[qw /Pascal Workshop/]],
90             id => [qw /"/],
91             from_to => [[qw !{ }!], [qw !(* *)!], [qw !/* */!]]},
92              
93             {languages => [qw /PEARL/],
94             to_eol => ['!'],
95             from_to => [[qw {/* */}]]},
96              
97             {languages => [qw /PHP/],
98             to_eol => ['#', '//'],
99             from_to => [[qw {/* */}]]},
100              
101             {languages => [qw !PL/B!],
102             to_eol => ['[.;]']},
103              
104             {languages => [qw !PL/SQL!],
105             to_eol => ['--'],
106             from_to => [[qw {/* */}]]},
107              
108             {languages => [qw /Q-BAL/],
109             to_eol => ['`']},
110              
111             {languages => [qw /Smalltalk/],
112             id => ['"']},
113              
114             {languages => [qw /SQL/],
115             to_eol => ['-{2,}']},
116              
117             {languages => [qw /troff/],
118             to_eol => ['\\\"']},
119              
120             {languages => [qw /vi/],
121             to_eol => ['"']},
122              
123             {languages => [qw /*W/],
124             from_to => [[qw {|| !!}]]},
125              
126             {languages => [qw /ZZT-OOP/],
127             to_eol => ["'"]},
128             );
129              
130             my @plain_or_nested = (
131             [Caml => undef, "(*" => "*)"],
132             [Dylan => "//", "/*" => "*/"],
133             [Haskell => "-{2,}", "{-" => "-}"],
134             [Hugo => "!(?!\\\\)", "!\\" => "\\!"],
135             [SLIDE => "#", "(*" => "*)"],
136             ['Modula-2' => undef, "(*" => "*)"],
137             ['Modula-3' => undef, "(*" => "*)"],
138             );
139              
140             #
141             # Helper subs.
142             #
143              
144             sub combine {
145 2485     2485 0 3524 local $_ = join "|", @_;
146 2485 100       3630 if (@_ > 1) {
147 497         2199 s/\(\?k:/(?:/g;
148 497         831 $_ = "(?k:$_)";
149             }
150             $_
151 2485         2715 }
152              
153 1775     1775 0 3101 sub to_eol ($) {"(?k:(?k:$_[0])(?k:[^\\n]*)(?k:\\n))"}
154 284     284 0 687 sub id ($) {"(?k:(?k:$_[0])(?k:[^$_[0]]*)(?k:$_[0]))"} # One char only!
155             sub from_to {
156 1207     1207 0 1699 my ($begin, $end) = @_;
157              
158 1207         1071 my $qb = quotemeta $begin;
159 1207         833 my $qe = quotemeta $end;
160 1207         1230 my $fe = quotemeta substr $end => 0, 1;
161 1207         1155 my $te = quotemeta substr $end => 1;
162              
163 1207         2641 "(?k:(?k:$qb)(?k:(?:[^$fe]+|$fe(?!$te))*)(?k:$qe))";
164             }
165              
166              
167             my $count = 0;
168             sub nested {
169 0     0 0   my ($begin, $end) = @_;
170              
171 0           $count ++;
172 0           my $r = '(??{$Regexp::Common::comment ['. $count . ']})';
173              
174 0           my $qb = quotemeta $begin;
175 0           my $qe = quotemeta $end;
176 0           my $fb = quotemeta substr $begin => 0, 1;
177 0           my $fe = quotemeta substr $end => 0, 1;
178              
179 0           my $tb = quotemeta substr $begin => 1;
180 0           my $te = quotemeta substr $end => 1;
181              
182 71     71   322 use re 'eval';
  71         828  
  71         28899  
183              
184 0           my $re;
185 0 0         if ($fb eq $fe) {
186 0           $re = qr /(?:$qb(?:(?>[^$fb]+)|$fb(?!$tb)(?!$te)|$r)*$qe)/;
187             }
188             else {
189 0           local $" = "|";
190 0           my @clauses = "(?>[^$fb$fe]+)";
191 0 0         push @clauses => "$fb(?!$tb)" if length $tb;
192 0 0         push @clauses => "$fe(?!$te)" if length $te;
193 0           push @clauses => $r;
194 0           $re = qr /(?:$qb(?:@clauses)*$qe)/;
195             }
196              
197 0           $Regexp::Common::comment [$count] = qr/$re/;
198             }
199              
200             #
201             # Process data.
202             #
203              
204             foreach my $info (@plain_or_nested) {
205             my ($language, $mark, $begin, $end) = @$info;
206             pattern name => [comment => $language],
207             create =>
208             sub {my $re = nested $begin => $end;
209             my $prefix = defined $mark ? $mark . "[^\n]*\n|" : "";
210             exists $_ [1] -> {-keep} ? qr /($prefix$re)/
211             : qr /$prefix$re/
212             },
213             ;
214             }
215              
216              
217             foreach my $group (@generic) {
218             my $pattern = combine +(map {to_eol $_} @{$group -> {to_eol}}),
219             (map {from_to @$_} @{$group -> {from_to}}),
220             (map {id $_} @{$group -> {id}}),
221             ;
222             foreach my $language (@{$group -> {languages}}) {
223             pattern name => [comment => ref $language ? @$language : $language],
224             create => $pattern,
225             ;
226             }
227             }
228            
229              
230            
231             #
232             # Other languages.
233             #
234              
235             # http://www.pascal-central.com/docs/iso10206.txt
236             pattern name => [qw /comment Pascal/],
237             create => '(?k:' . '(?k:[{]|[(][*])'
238             . '(?k:[^}*]*(?:[*](?![)])[^}*]*)*)'
239             . '(?k:[}]|[*][)])'
240             . ')'
241             ;
242              
243             # http://www.templetons.com/brad/alice/language/
244             pattern name => [qw /comment Pascal Alice/],
245             create => '(?k:(?k:[{])(?k:[^}\n]*)(?k:[}]))'
246             ;
247              
248              
249             # http://westein.arb-phys.uni-dortmund.de/~wb/a68s.txt
250             pattern name => [qw (comment), 'Algol 68'],
251             create => q {(?k:(?:#[^#]*#)|} .
252             q {(?:\bco\b(?:[^c]+|\Bc|\bc(?!o\b))*\bco\b)|} .
253             q {(?:\bcomment\b(?:[^c]+|\Bc|\bc(?!omment\b))*\bcomment\b))}
254             ;
255              
256              
257             # See rules 91 and 92 of ISO 8879 (SGML).
258             # Charles F. Goldfarb: "The SGML Handbook".
259             # Oxford: Oxford University Press. 1990. ISBN 0-19-853737-9.
260             # Ch. 10.3, pp 390.
261             pattern name => [qw (comment HTML)],
262             create => q {(?k:(?k:))},
263             ;
264              
265              
266             pattern name => [qw /comment SQL MySQL/],
267             create => q {(?k:(?:#|-- )[^\n]*\n|} .
268             q {/\*(?:(?>[^*;"']+)|"[^"]*"|'[^']*'|\*(?!/))*(?:;|\*/))},
269             ;
270              
271             # Anything that isn't <>[]+-.,
272             # http://home.wxs.nl/~faase009/Ha_BF.html
273             pattern name => [qw /comment Brainfuck/],
274             create => '(?k:[^<>\[\]+\-.,]+)'
275             ;
276              
277             # Squeak is a variant of Smalltalk-80.
278             # http://www.squeak.
279             # http://mucow.com/squeak-qref.html
280             pattern name => [qw /comment Squeak/],
281             create => '(?k:(?k:")(?k:[^"]*(?:""[^"]*)*)(?k:"))'
282             ;
283              
284             #
285             # Scores of less than 5 or above 17....
286             # http://www.cliff.biffle.org/esoterica/beatnik.html
287             @Regexp::Common::comment::scores = (1, 3, 3, 2, 1, 4, 2, 4, 1, 8,
288             5, 1, 3, 1, 1, 3, 10, 1, 1, 1,
289             1, 4, 4, 8, 4, 10);
290             {
291             my ($s, $x);
292             pattern name => [qw /comment Beatnik/],
293             create => sub {
294 71     71   321 use re 'eval';
  71         77  
  71         14371  
295             my $re = qr {\b([A-Za-z]+)\b
296             (?(?{($s, $x) = (0, lc $^N);
297             $s += $Regexp::Common::comment::scores
298             [ord (chop $x) - ord ('a')] while length $x;
299             $s >= 5 && $s < 18})XXX|)}x;
300             $re;
301             },
302             ;
303             }
304              
305              
306             # http://www.cray.com/craydoc/manuals/007-3692-005/html-007-3692-005/
307             # (Goto table of contents/3.3 Source Form)
308             # Fortran, in fixed format. Comments start with a C, c or * in the first
309             # column, or a ! anywhere, but the sixth column. Then end with a newline.
310             pattern name => [qw /comment Fortran fixed/],
311             create => '(?k:(?k:(?:^[Cc*]|(?
312             ;
313              
314              
315             # http://www.csis.ul.ie/cobol/Course/COBOLIntro.htm
316             # Traditionally, comments in COBOL were indicated with an asteriks in
317             # the seventh column. Modern compilers may be more lenient.
318             pattern name => [qw /comment COBOL/],
319             create => '(?<=^......)(?k:(?k:[*])(?k:[^\n]*)(?k:\n))',
320             ;
321              
322             1;
323              
324              
325             __END__