File Coverage

lib/Perl/PrereqScanner/NotQuiteLite/Context.pm
Criterion Covered Total %
statement 184 209 88.0
branch 107 138 77.5
condition 6 12 50.0
subroutine 50 57 87.7
pod 12 47 25.5
total 359 463 77.5


line stmt bran cond sub pod time code
1             package Perl::PrereqScanner::NotQuiteLite::Context;
2              
3 89     89   1445 use strict;
  89         172  
  89         2293  
4 89     89   404 use warnings;
  89         174  
  89         1938  
5 89     89   41431 use CPAN::Meta::Requirements;
  89         553406  
  89         2681  
6 89     89   32520 use Regexp::Trie;
  89         43592  
  89         2716  
7 89     89   33199 use Perl::PrereqScanner::NotQuiteLite::Util;
  89         262  
  89         284970  
8              
9             my %defined_keywords = _keywords();
10              
11             my %default_op_keywords = map {$_ => 1} qw(
12             x eq ne and or xor cmp ge gt le lt not
13             );
14              
15             my %default_conditional_keywords = map {$_ => 1} qw(
16             if elsif unless else
17             );
18              
19             my %default_expects_expr_block = map {$_ => 1} qw(
20             if elsif unless given when
21             for foreach while until
22             );
23              
24             my %default_expects_block_list = map {$_ => 1} qw(
25             map grep sort
26             );
27              
28             my %default_expects_fh_list = map {$_ => 1} qw(
29             print printf say
30             );
31              
32             my %default_expects_fh_or_block_list = (
33             %default_expects_block_list,
34             %default_expects_fh_list,
35             );
36              
37             my %default_expects_block = map {$_ => 1} qw(
38             else default
39             eval sub do while until continue
40             BEGIN END INIT CHECK
41             if elsif unless given when
42             for foreach while until
43             map grep sort
44             );
45              
46             my %default_expects_word = map {$_ => 1} qw(
47             use require no sub
48             );
49              
50             my %enables_utf8 = map {$_ => 1} qw(
51             utf8
52             Mojo::Base
53             Mojo::Base::Che
54             );
55              
56             my %new_keyword_since = (
57             say => '5.010',
58             state => '5.010',
59             given => '5.010',
60             when => '5.010',
61             default => '5.010',
62             );
63              
64             my $default_g_re_prototype = qr{\G(\([^\)]*?\))};
65              
66             sub new {
67 739     739 1 2877 my ($class, %args) = @_;
68              
69             my %context = (
70             requires => CPAN::Meta::Requirements->new,
71             noes => CPAN::Meta::Requirements->new,
72             file => $args{file},
73             verbose => $args{verbose},
74             optional => $args{optional},
75 739         3724 stash => {},
76             );
77              
78 739 100 66     23233 if ($args{suggests} or $args{recommends}) {
79 148         429 $context{recommends} = CPAN::Meta::Requirements->new;
80             }
81 739 100       3572 if ($args{suggests}) {
82 148         407 $context{suggests} = CPAN::Meta::Requirements->new;
83             }
84 739 100       3492 if ($args{perl_minimum_version}) {
85 83         197 $context{perl} = CPAN::Meta::Requirements->new;
86             }
87 739         2626 for my $type (qw/use no method keyword sub/) {
88 3695 100       9070 if (exists $args{_}{$type}) {
89 2950         4430 for my $key (keys %{$args{_}{$type}}) {
  2950         27640  
90 134147         186881 $context{$type}{$key} = [@{$args{_}{$type}{$key}}];
  134147         333508  
91             }
92             }
93             }
94              
95 739         3721 bless \%context, $class;
96             }
97              
98 38     38 0 174 sub stash { shift->{stash} }
99              
100             sub register_keyword_parser {
101 423     423 1 891 my ($self, $keyword, $parser_info) = @_;
102 423         923 $self->{keyword}{$keyword} = $parser_info;
103 423         1205 $self->{defined_keywords}{$keyword} = 0;
104             }
105              
106             sub remove_keyword_parser {
107 2     2 1 3 my ($self, $keyword) = @_;
108 2         6 delete $self->{keyword}{$keyword};
109 2 50       4 delete $self->{keyword} if !%{$self->{keyword}};
  2         4  
110 2         6 delete $self->{defined_keywords}{$keyword};
111             }
112              
113             sub register_method_parser {
114 2     2 1 8 my ($self, $method, $parser_info) = @_;
115 2         11 $self->{method}{$method} = $parser_info;
116             }
117              
118             *register_keyword = \®ister_keyword_parser;
119             *remove_keyword = \&remove_keyword_parser;
120             *register_method = \®ister_method_parser;
121              
122             sub register_sub_parser {
123 195     195 1 392 my ($self, $keyword, $parser_info) = @_;
124 195         483 $self->{sub}{$keyword} = $parser_info;
125 195         505 $self->{defined_keywords}{$keyword} = 0;
126             }
127              
128 586     586 1 5173 sub requires { shift->{requires} }
129 116     116 0 53231 sub recommends { shift->_optional('recommends') }
130 146     146 1 174257 sub suggests { shift->_optional('suggests') }
131 10     10 0 36 sub noes { shift->{noes} }
132              
133             sub _optional {
134 262     262   674 my ($self, $key) = @_;
135 262 50       922 my $optional = $self->{$key} or return;
136              
137             # no need to recommend/suggest what are listed as requires
138 262 50       848 if (my $requires = $self->{requires}) {
139 262         809 my $hash = $optional->as_string_hash;
140 262         7561 for my $module (keys %$hash) {
141 102 50 33     597 if (defined $requires->requirements_for_module($module) and
142             $requires->accepts_module($module, $hash->{$module})
143             ) {
144 0         0 $optional->clear_requirement($module);
145             }
146             }
147             }
148 262         1690 $optional;
149             }
150              
151             sub add {
152 1150     1150 1 5691 my $self = shift;
153 1150 100       2822 if ($self->{optional}) {
154 9         24 $self->_add('suggests', @_);
155             } else {
156 1141         3106 $self->_add('requires', @_);
157             }
158             }
159              
160             sub add_recommendation {
161 29     29 0 87 shift->_add('recommends', @_);
162             }
163              
164             sub add_suggestion {
165 8     8 0 22 shift->_add('suggests', @_);
166             }
167              
168             sub add_conditional {
169 89     89 0 875 shift->_add('conditional', @_);
170             }
171              
172             sub add_no {
173 31     31 0 121 shift->_add('noes', @_);
174             }
175              
176             sub add_perl {
177 198     198 0 481 my ($self, $perl, $reason) = @_;
178 198 100       613 return unless $self->{perl};
179 89         272 $self->_add('perl', 'perl', $perl);
180 89         8885 $self->{perl_minimum_version}{$reason} = $perl;
181             }
182              
183             sub _add {
184 1396     1396   3584 my ($self, $type, $module, $version) = @_;
185 1396 100       3465 return unless is_module_name($module);
186              
187 1395 100       4300 my $CMR = $self->_object($type) or return;
188 1378 100       3315 $version = 0 unless defined $version;
189 1378 50       3225 if ($self->{verbose}) {
190 0 0       0 if (!defined $CMR->requirements_for_module($module)) {
191 0         0 print STDERR " found $module $version ($type)\n";
192             }
193             }
194 1378         5368 $CMR->add_minimum($module, "$version");
195             }
196              
197             sub has_added {
198 0     0 1 0 shift->_has_added('requires', @_);
199             }
200              
201             sub has_added_recommendation {
202 0     0 0 0 shift->_has_added('recommends', @_);
203             }
204              
205             sub has_added_suggestion {
206 0     0 0 0 shift->_has_added('suggests', @_);
207             }
208              
209             sub has_added_conditional {
210 12     12 0 37 shift->_has_added('conditional', @_);
211             }
212              
213             sub has_added_no {
214 0     0 0 0 shift->_has_added('no', @_);
215             }
216              
217             sub _has_added {
218 12     12   36 my ($self, $type, $module) = @_;
219 12 50       32 return unless is_module_name($module);
220              
221 12 100       44 my $CMR = $self->_object($type) or return;
222 11 100       40 defined $CMR->requirements_for_module($module) ? 1 : 0;
223             }
224              
225             sub _object {
226 2066     2066   4149 my ($self, $key) = @_;
227 2066 100 100     10162 if ($self->{eval}) {
    100          
    100          
    100          
228 42         90 $key = 'suggests';
229             } elsif ($self->{force_cond}) {
230 7         14 $key = 'recommends';
231             } elsif ($key && $key eq 'conditional') {
232 87 100       226 if ($self->{cond}) {
    100          
233 16         47 $key = 'recommends';
234 25 50       161 } elsif (grep {$_->[0] eq '{' and $_->[2] ne 'BEGIN'} @{$self->{stack} || []}) {
  71 50       303  
235 17         48 $key = 'recommends';
236             } else {
237 54         127 $key = 'requires';
238             }
239             } elsif (!$key) {
240 655         1186 $key = 'requires';
241             }
242 2066 100       7813 $self->{$key} or return;
243             }
244              
245             sub has_callbacks {
246 0     0 1 0 my ($self, $type) = @_;
247 0         0 exists $self->{$type};
248             }
249              
250             sub has_callback_for {
251 836     836 1 2186 my ($self, $type, $name) = @_;
252 836         4027 exists $self->{$type}{$name};
253             }
254              
255             sub run_callback_for {
256 659     659 1 1930 my ($self, $type, $name, @args) = @_;
257 659 100       6824 return unless $self->_object;
258 657         1234 my ($parser, $method, @cb_args) = @{$self->{$type}{$name}};
  657         2146  
259 657         3510 $parser->$method($self, @cb_args, @args);
260             }
261              
262             sub prototype_re {
263 1602     1602 0 2826 my $self = shift;
264 1602 100       3474 if (@_) {
265 102         221 $self->{prototype_re} = shift;
266             }
267 1602 100       4333 return $default_g_re_prototype unless exists $self->{prototype_re};
268 177         484 $self->{prototype_re};
269             }
270              
271             sub quotelike_re {
272 206     206 0 497 my $self = shift;
273 206 100       1351 return qr/qq?/ unless exists $self->{quotelike_re};
274 1         4 $self->{quotelike_re};
275             }
276              
277             sub register_quotelike_keywords {
278 1     1 0 4 my ($self, @keywords) = @_;
279 1         2 push @{$self->{quotelike}}, @keywords;
  1         35  
280 1         7 $self->{defined_keywords}{$_} = 0 for @keywords;
281              
282 1         7 my $trie = Regexp::Trie->new;
283 1 50       6 $trie->add($_) for 'q', 'qq', @{$self->{quotelike} || []};
  1         5  
284 1         54 $self->{quotelike_re} = $trie->regexp;
285             }
286              
287             sub token_expects_block_list {
288 665     665 0 1431 my ($self, $token) = @_;
289 665 100       1711 return 1 if exists $default_expects_block_list{$token};
290 639 50       2577 return 0 if !exists $self->{expects_block_list};
291 0 0       0 return 1 if exists $self->{expects_block_list}{$token};
292 0         0 return 0;
293             }
294              
295             sub token_expects_fh_list {
296 0     0 0 0 my ($self, $token) = @_;
297 0 0       0 return 1 if exists $default_expects_fh_list{$token};
298 0 0       0 return 0 if !exists $self->{expects_fh_list};
299 0 0       0 return 1 if exists $self->{expects_fh_list}{$token};
300 0         0 return 0;
301             }
302              
303             sub token_expects_fh_or_block_list {
304 18     18 0 47 my ($self, $token) = @_;
305 18 100       86 return 1 if exists $default_expects_fh_or_block_list{$token};
306 3 50       24 return 0 if !exists $self->{expects_fh_or_block_list};
307 0 0       0 return 1 if exists $self->{expects_fh_or_block_list}{$token};
308 0         0 return 0;
309             }
310              
311             sub token_expects_expr_block {
312 568     568 0 1298 my ($self, $token) = @_;
313 568 100       1912 return 1 if exists $default_expects_expr_block{$token};
314 356 50       1464 return 0 if !exists $self->{expects_expr_block};
315 0 0       0 return 1 if exists $self->{expects_expr_block}{$token};
316 0         0 return 0;
317             }
318              
319             sub token_expects_block {
320 29547     29547 0 52280 my ($self, $token) = @_;
321 29547 100       61349 return 1 if exists $default_expects_block{$token};
322 27148 100       75655 return 0 if !exists $self->{expects_block};
323 2399 100       5236 return 1 if exists $self->{expects_block}{$token};
324 1995         4660 return 0;
325             }
326              
327             sub token_expects_word {
328 2654     2654 0 5869 my ($self, $token) = @_;
329 2654 100       9869 return 1 if exists $default_expects_word{$token};
330 1636 100       6775 return 0 if !exists $self->{expects_word};
331 333 100       1185 return 1 if exists $self->{expects_word}{$token};
332 161         517 return 0;
333             }
334              
335             sub token_is_conditional {
336 16     16 0 36 my ($self, $token) = @_;
337 16 100       48 return 1 if exists $default_conditional_keywords{$token};
338 14 50       57 return 0 if !exists $self->{is_conditional_keyword};
339 0 0       0 return 1 if exists $self->{is_conditional_keyword}{$token};
340 0         0 return 0;
341             }
342              
343             sub token_is_keyword {
344 5728     5728 0 12068 my ($self, $token) = @_;
345 5728 100       23687 return 1 if exists $defined_keywords{$token};
346 2410 100       7984 return 0 if !exists $self->{defined_keywords};
347 848 100       2730 return 1 if exists $self->{defined_keywords}{$token};
348 534         1594 return 0;
349             }
350              
351             sub token_is_op_keyword {
352 3612     3612 0 6868 my ($self, $token) = @_;
353 3612 100       8012 return 1 if exists $default_op_keywords{$token};
354 3449 100       10183 return 0 if !exists $self->{defined_op_keywords};
355 28 100       61 return 1 if exists $self->{defined_op_keywords}{$token};
356 27         53 return 0;
357             }
358              
359             sub check_new_keyword {
360 3448     3448 0 6131 my ($self, $token) = @_;
361 3448 100       9499 if (exists $new_keyword_since{$token}) {
362 27         81 $self->add_perl($new_keyword_since{$token}, $token);
363             }
364             }
365              
366             sub register_keywords {
367 4     4 0 9 my ($self, @keywords) = @_;
368 4         9 for my $keyword (@keywords) {
369 6         19 $self->{defined_keywords}{$keyword} = 0;
370             }
371             }
372              
373             sub register_op_keywords {
374 1     1 0 3 my ($self, @keywords) = @_;
375 1         2 for my $keyword (@keywords) {
376 1         3 $self->{defined_op_keywords}{$keyword} = 0;
377             }
378             }
379              
380             sub remove_keywords {
381 0     0 0 0 my ($self, @keywords) = @_;
382 0         0 for my $keyword (@keywords) {
383 0 0 0     0 delete $self->{defined_keywords}{$keyword} if exists $self->{defined_keywords}{$keyword} and !$self->{defined_keywords}{$keyword};
384             }
385             }
386              
387             sub register_sub_keywords {
388 103     103 0 277 my ($self, @keywords) = @_;
389 103         222 for my $keyword (@keywords) {
390 367         733 $self->{defines_sub}{$keyword} = 1;
391 367         605 $self->{expects_block}{$keyword} = 1;
392 367         612 $self->{expects_word}{$keyword} = 1;
393 367         797 $self->{defined_keywords}{$keyword} = 0;
394             }
395             }
396              
397             sub token_defines_sub {
398 637     637 0 1487 my ($self, $token) = @_;
399 637 100       2247 return 1 if $token eq 'sub';
400 489 100       3930 return 0 if !exists $self->{defines_sub};
401 173 100       1245 return 1 if exists $self->{defines_sub}{$token};
402 5         44 return 0;
403             }
404              
405             sub enables_utf8 {
406 682     682 0 1696 my ($self, $module) = @_;
407 682 100       2712 exists $enables_utf8{$module} ? 1 : 0;
408             }
409              
410             sub add_package {
411 127     127 0 342 my ($self, $package) = @_;
412 127         578 $self->{packages}{$package} = 1;
413             }
414              
415             sub packages {
416 739     739 0 1469 my $self = shift;
417 739 100       1306 keys %{$self->{packages} || {}};
  739         5218  
418             }
419              
420             sub remove_inner_packages_from_requirements {
421 739     739 0 1640 my $self = shift;
422 739         2199 for my $package ($self->packages) {
423 123         360 for my $rel (qw/requires recommends suggests noes/) {
424 492 100       2112 next unless $self->{$rel};
425 248         700 $self->{$rel}->clear_requirement($package);
426             }
427             }
428             }
429              
430             sub merge_perl {
431 739     739 0 1479 my $self = shift;
432 739 100       2337 return unless $self->{perl};
433              
434 83         307 my $perl = $self->{requires}->requirements_for_module('perl');
435 83 100       924 if ($self->{perl}->accepts_module('perl', $perl)) {
436 11         198 delete $self->{perl_minimum_version};
437             } else {
438 72         1881 $self->add(perl => $self->{perl}->requirements_for_module('perl'));
439             }
440             }
441              
442             sub _keywords {(
443 89     89   15372 '__FILE__' => 1,
444             '__LINE__' => 2,
445             '__PACKAGE__' => 3,
446             '__DATA__' => 4,
447             '__END__' => 5,
448             '__SUB__' => 6,
449             AUTOLOAD => 7,
450             BEGIN => 8,
451             UNITCHECK => 9,
452             DESTROY => 10,
453             END => 11,
454             INIT => 12,
455             CHECK => 13,
456             abs => 14,
457             accept => 15,
458             alarm => 16,
459             and => 17,
460             atan2 => 18,
461             bind => 19,
462             binmode => 20,
463             bless => 21,
464             break => 22,
465             caller => 23,
466             chdir => 24,
467             chmod => 25,
468             chomp => 26,
469             chop => 27,
470             chown => 28,
471             chr => 29,
472             chroot => 30,
473             close => 31,
474             closedir => 32,
475             cmp => 33,
476             connect => 34,
477             continue => 35,
478             cos => 36,
479             crypt => 37,
480             dbmclose => 38,
481             dbmopen => 39,
482             default => 40,
483             defined => 41,
484             delete => 42,
485             die => 43,
486             do => 44,
487             dump => 45,
488             each => 46,
489             else => 47,
490             elsif => 48,
491             endgrent => 49,
492             endhostent => 50,
493             endnetent => 51,
494             endprotoent => 52,
495             endpwent => 53,
496             endservent => 54,
497             eof => 55,
498             eq => 56,
499             eval => 57,
500             evalbytes => 58,
501             exec => 59,
502             exists => 60,
503             exit => 61,
504             exp => 62,
505             fc => 63,
506             fcntl => 64,
507             fileno => 65,
508             flock => 66,
509             for => 67,
510             foreach => 68,
511             fork => 69,
512             format => 70,
513             formline => 71,
514             ge => 72,
515             getc => 73,
516             getgrent => 74,
517             getgrgid => 75,
518             getgrnam => 76,
519             gethostbyaddr => 77,
520             gethostbyname => 78,
521             gethostent => 79,
522             getlogin => 80,
523             getnetbyaddr => 81,
524             getnetbyname => 82,
525             getnetent => 83,
526             getpeername => 84,
527             getpgrp => 85,
528             getppid => 86,
529             getpriority => 87,
530             getprotobyname => 88,
531             getprotobynumber => 89,
532             getprotoent => 90,
533             getpwent => 91,
534             getpwnam => 92,
535             getpwuid => 93,
536             getservbyname => 94,
537             getservbyport => 95,
538             getservent => 96,
539             getsockname => 97,
540             getsockopt => 98,
541             given => 99,
542             glob => 100,
543             gmtime => 101,
544             goto => 102,
545             grep => 103,
546             gt => 104,
547             hex => 105,
548             if => 106,
549             index => 107,
550             int => 108,
551             ioctl => 109,
552             join => 110,
553             keys => 111,
554             kill => 112,
555             last => 113,
556             lc => 114,
557             lcfirst => 115,
558             le => 116,
559             length => 117,
560             link => 118,
561             listen => 119,
562             local => 120,
563             localtime => 121,
564             lock => 122,
565             log => 123,
566             lstat => 124,
567             lt => 125,
568             m => 126,
569             map => 127,
570             mkdir => 128,
571             msgctl => 129,
572             msgget => 130,
573             msgrcv => 131,
574             msgsnd => 132,
575             my => 133,
576             ne => 134,
577             next => 135,
578             no => 136,
579             not => 137,
580             oct => 138,
581             open => 139,
582             opendir => 140,
583             or => 141,
584             ord => 142,
585             our => 143,
586             pack => 144,
587             package => 145,
588             pipe => 146,
589             pop => 147,
590             pos => 148,
591             print => 149,
592             printf => 150,
593             prototype => 151,
594             push => 152,
595             q => 153,
596             qq => 154,
597             qr => 155,
598             quotemeta => 156,
599             qw => 157,
600             qx => 158,
601             rand => 159,
602             read => 160,
603             readdir => 161,
604             readline => 162,
605             readlink => 163,
606             readpipe => 164,
607             recv => 165,
608             redo => 166,
609             ref => 167,
610             rename => 168,
611             require => 169,
612             reset => 170,
613             return => 171,
614             reverse => 172,
615             rewinddir => 173,
616             rindex => 174,
617             rmdir => 175,
618             s => 176,
619             say => 177,
620             scalar => 178,
621             seek => 179,
622             seekdir => 180,
623             select => 181,
624             semctl => 182,
625             semget => 183,
626             semop => 184,
627             send => 185,
628             setgrent => 186,
629             sethostent => 187,
630             setnetent => 188,
631             setpgrp => 189,
632             setpriority => 190,
633             setprotoent => 191,
634             setpwent => 192,
635             setservent => 193,
636             setsockopt => 194,
637             shift => 195,
638             shmctl => 196,
639             shmget => 197,
640             shmread => 198,
641             shmwrite => 199,
642             shutdown => 200,
643             sin => 201,
644             sleep => 202,
645             socket => 203,
646             socketpair => 204,
647             sort => 205,
648             splice => 206,
649             split => 207,
650             sprintf => 208,
651             sqrt => 209,
652             srand => 210,
653             stat => 211,
654             state => 212,
655             study => 213,
656             sub => 214,
657             substr => 215,
658             symlink => 216,
659             syscall => 217,
660             sysopen => 218,
661             sysread => 219,
662             sysseek => 220,
663             system => 221,
664             syswrite => 222,
665             tell => 223,
666             telldir => 224,
667             tie => 225,
668             tied => 226,
669             time => 227,
670             times => 228,
671             tr => 229,
672             truncate => 230,
673             uc => 231,
674             ucfirst => 232,
675             umask => 233,
676             undef => 234,
677             unless => 235,
678             unlink => 236,
679             unpack => 237,
680             unshift => 238,
681             untie => 239,
682             until => 240,
683             use => 241,
684             utime => 242,
685             values => 243,
686             vec => 244,
687             wait => 245,
688             waitpid => 246,
689             wantarray => 247,
690             warn => 248,
691             when => 249,
692             while => 250,
693             write => 251,
694             x => 252,
695             xor => 253,
696             y => 254 || 255,
697             )}
698              
699             1;
700              
701             __END__