1package Perl::PrereqScanner::NotQuiteLite::Context; 2 3use strict; 4use warnings; 5use CPAN::Meta::Requirements; 6use Regexp::Trie; 7use Perl::PrereqScanner::NotQuiteLite::Util; 8 9my %defined_keywords = _keywords(); 10 11my %default_op_keywords = map {$_ => 1} qw( 12 x eq ne and or xor cmp ge gt le lt not 13); 14 15my %default_conditional_keywords = map {$_ => 1} qw( 16 if elsif unless else 17); 18 19my %default_expects_expr_block = map {$_ => 1} qw( 20 if elsif unless given when 21 for foreach while until 22); 23 24my %default_expects_block_list = map {$_ => 1} qw( 25 map grep sort 26); 27 28my %default_expects_fh_list = map {$_ => 1} qw( 29 print printf say 30); 31 32my %default_expects_fh_or_block_list = ( 33 %default_expects_block_list, 34 %default_expects_fh_list, 35); 36 37my %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 46my %default_expects_word = map {$_ => 1} qw( 47 use require no sub 48); 49 50my %enables_utf8 = map {$_ => 1} qw( 51 utf8 52 Mojo::Base 53 Mojo::Base::Che 54); 55 56my %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 64my $default_g_re_prototype = qr{\G(\([^\)]*?\))}; 65 66sub new { 67 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 stash => {}, 75 ); 76 77 if ($args{suggests} or $args{recommends}) { 78 $context{recommends} = CPAN::Meta::Requirements->new; 79 } 80 if ($args{suggests}) { 81 $context{suggests} = CPAN::Meta::Requirements->new; 82 } 83 if ($args{perl_minimum_version}) { 84 $context{perl} = CPAN::Meta::Requirements->new; 85 } 86 for my $type (qw/use no method keyword sub/) { 87 if (exists $args{_}{$type}) { 88 for my $key (keys %{$args{_}{$type}}) { 89 $context{$type}{$key} = [@{$args{_}{$type}{$key}}]; 90 } 91 } 92 } 93 94 bless \%context, $class; 95} 96 97sub stash { shift->{stash} } 98 99sub register_keyword_parser { 100 my ($self, $keyword, $parser_info) = @_; 101 $self->{keyword}{$keyword} = $parser_info; 102 $self->{defined_keywords}{$keyword} = 0; 103} 104 105sub remove_keyword_parser { 106 my ($self, $keyword) = @_; 107 delete $self->{keyword}{$keyword}; 108 delete $self->{keyword} if !%{$self->{keyword}}; 109 delete $self->{defined_keywords}{$keyword}; 110} 111 112sub register_method_parser { 113 my ($self, $method, $parser_info) = @_; 114 $self->{method}{$method} = $parser_info; 115} 116 117*register_keyword = \®ister_keyword_parser; 118*remove_keyword = \&remove_keyword_parser; 119*register_method = \®ister_method_parser; 120 121sub register_sub_parser { 122 my ($self, $keyword, $parser_info) = @_; 123 $self->{sub}{$keyword} = $parser_info; 124 $self->{defined_keywords}{$keyword} = 0; 125} 126 127sub requires { shift->{requires} } 128sub recommends { shift->_optional('recommends') } 129sub suggests { shift->_optional('suggests') } 130sub noes { shift->{noes} } 131 132sub _optional { 133 my ($self, $key) = @_; 134 my $optional = $self->{$key} or return; 135 136 # no need to recommend/suggest what are listed as requires 137 if (my $requires = $self->{requires}) { 138 my $hash = $optional->as_string_hash; 139 for my $module (keys %$hash) { 140 if (defined $requires->requirements_for_module($module) and 141 $requires->accepts_module($module, $hash->{$module}) 142 ) { 143 $optional->clear_requirement($module); 144 } 145 } 146 } 147 $optional; 148} 149 150sub add { 151 shift->_add('requires', @_); 152} 153 154sub add_recommendation { 155 shift->_add('recommends', @_); 156} 157 158sub add_suggestion { 159 shift->_add('suggests', @_); 160} 161 162sub add_conditional { 163 shift->_add('conditional', @_); 164} 165 166sub add_no { 167 shift->_add('noes', @_); 168} 169 170sub add_perl { 171 my ($self, $perl, $reason) = @_; 172 return unless $self->{perl}; 173 $self->_add('perl', 'perl', $perl); 174 $self->{perl_minimum_version}{$reason} = $perl; 175} 176 177sub _add { 178 my ($self, $type, $module, $version) = @_; 179 return unless is_module_name($module); 180 181 my $CMR = $self->_object($type) or return; 182 $version = 0 unless defined $version; 183 if ($self->{verbose}) { 184 if (!defined $CMR->requirements_for_module($module)) { 185 print STDERR " found $module $version ($type)\n"; 186 } 187 } 188 $CMR->add_minimum($module, "$version"); 189} 190 191sub has_added { 192 shift->_has_added('requires', @_); 193} 194 195sub has_added_recommendation { 196 shift->_has_added('recommends', @_); 197} 198 199sub has_added_suggestion { 200 shift->_has_added('suggests', @_); 201} 202 203sub has_added_conditional { 204 shift->_has_added('conditional', @_); 205} 206 207sub has_added_no { 208 shift->_has_added('no', @_); 209} 210 211sub _has_added { 212 my ($self, $type, $module) = @_; 213 return unless is_module_name($module); 214 215 my $CMR = $self->_object($type) or return; 216 defined $CMR->requirements_for_module($module) ? 1 : 0; 217} 218 219sub _object { 220 my ($self, $key) = @_; 221 if ($self->{eval}) { 222 $key = 'suggests'; 223 } elsif ($self->{force_cond}) { 224 $key = 'recommends'; 225 } elsif ($key && $key eq 'conditional') { 226 if ($self->{cond}) { 227 $key = 'recommends'; 228 } elsif (grep {$_->[0] eq '{' and $_->[2] ne 'BEGIN'} @{$self->{stack} || []}) { 229 $key = 'recommends'; 230 } else { 231 $key = 'requires'; 232 } 233 } elsif (!$key) { 234 $key = 'requires'; 235 } 236 $self->{$key} or return; 237} 238 239sub has_callbacks { 240 my ($self, $type) = @_; 241 exists $self->{$type}; 242} 243 244sub has_callback_for { 245 my ($self, $type, $name) = @_; 246 exists $self->{$type}{$name}; 247} 248 249sub run_callback_for { 250 my ($self, $type, $name, @args) = @_; 251 return unless $self->_object; 252 my ($parser, $method, @cb_args) = @{$self->{$type}{$name}}; 253 $parser->$method($self, @cb_args, @args); 254} 255 256sub prototype_re { 257 my $self = shift; 258 if (@_) { 259 $self->{prototype_re} = shift; 260 } 261 return $default_g_re_prototype unless exists $self->{prototype_re}; 262 $self->{prototype_re}; 263} 264 265sub quotelike_re { 266 my $self = shift; 267 return qr/qq?/ unless exists $self->{quotelike_re}; 268 $self->{quotelike_re}; 269} 270 271sub register_quotelike_keywords { 272 my ($self, @keywords) = @_; 273 push @{$self->{quotelike}}, @keywords; 274 $self->{defined_keywords}{$_} = 0 for @keywords; 275 276 my $trie = Regexp::Trie->new; 277 $trie->add($_) for 'q', 'qq', @{$self->{quotelike} || []}; 278 $self->{quotelike_re} = $trie->regexp; 279} 280 281sub token_expects_block_list { 282 my ($self, $token) = @_; 283 return 1 if exists $default_expects_block_list{$token}; 284 return 0 if !exists $self->{expects_block_list}; 285 return 1 if exists $self->{expects_block_list}{$token}; 286 return 0; 287} 288 289sub token_expects_fh_list { 290 my ($self, $token) = @_; 291 return 1 if exists $default_expects_fh_list{$token}; 292 return 0 if !exists $self->{expects_fh_list}; 293 return 1 if exists $self->{expects_fh_list}{$token}; 294 return 0; 295} 296 297sub token_expects_fh_or_block_list { 298 my ($self, $token) = @_; 299 return 1 if exists $default_expects_fh_or_block_list{$token}; 300 return 0 if !exists $self->{expects_fh_or_block_list}; 301 return 1 if exists $self->{expects_fh_or_block_list}{$token}; 302 return 0; 303} 304 305sub token_expects_expr_block { 306 my ($self, $token) = @_; 307 return 1 if exists $default_expects_expr_block{$token}; 308 return 0 if !exists $self->{expects_expr_block}; 309 return 1 if exists $self->{expects_expr_block}{$token}; 310 return 0; 311} 312 313sub token_expects_block { 314 my ($self, $token) = @_; 315 return 1 if exists $default_expects_block{$token}; 316 return 0 if !exists $self->{expects_block}; 317 return 1 if exists $self->{expects_block}{$token}; 318 return 0; 319} 320 321sub token_expects_word { 322 my ($self, $token) = @_; 323 return 1 if exists $default_expects_word{$token}; 324 return 0 if !exists $self->{expects_word}; 325 return 1 if exists $self->{expects_word}{$token}; 326 return 0; 327} 328 329sub token_is_conditional { 330 my ($self, $token) = @_; 331 return 1 if exists $default_conditional_keywords{$token}; 332 return 0 if !exists $self->{is_conditional_keyword}; 333 return 1 if exists $self->{is_conditional_keyword}{$token}; 334 return 0; 335} 336 337sub token_is_keyword { 338 my ($self, $token) = @_; 339 return 1 if exists $defined_keywords{$token}; 340 return 0 if !exists $self->{defined_keywords}; 341 return 1 if exists $self->{defined_keywords}{$token}; 342 return 0; 343} 344 345sub token_is_op_keyword { 346 my ($self, $token) = @_; 347 return 1 if exists $default_op_keywords{$token}; 348 return 0 if !exists $self->{defined_op_keywords}; 349 return 1 if exists $self->{defined_op_keywords}{$token}; 350 return 0; 351} 352 353sub check_new_keyword { 354 my ($self, $token) = @_; 355 if (exists $new_keyword_since{$token}) { 356 $self->add_perl($new_keyword_since{$token}, $token); 357 } 358} 359 360sub register_keywords { 361 my ($self, @keywords) = @_; 362 for my $keyword (@keywords) { 363 $self->{defined_keywords}{$keyword} = 0; 364 } 365} 366 367sub register_op_keywords { 368 my ($self, @keywords) = @_; 369 for my $keyword (@keywords) { 370 $self->{defined_op_keywords}{$keyword} = 0; 371 } 372} 373 374sub remove_keywords { 375 my ($self, @keywords) = @_; 376 for my $keyword (@keywords) { 377 delete $self->{defined_keywords}{$keyword} if exists $self->{defined_keywords}{$keyword} and !$self->{defined_keywords}{$keyword}; 378 } 379} 380 381sub register_sub_keywords { 382 my ($self, @keywords) = @_; 383 for my $keyword (@keywords) { 384 $self->{defines_sub}{$keyword} = 1; 385 $self->{expects_block}{$keyword} = 1; 386 $self->{expects_word}{$keyword} = 1; 387 $self->{defined_keywords}{$keyword} = 0; 388 } 389} 390 391sub token_defines_sub { 392 my ($self, $token) = @_; 393 return 1 if $token eq 'sub'; 394 return 0 if !exists $self->{defines_sub}; 395 return 1 if exists $self->{defines_sub}{$token}; 396 return 0; 397} 398 399sub enables_utf8 { 400 my ($self, $module) = @_; 401 exists $enables_utf8{$module} ? 1 : 0; 402} 403 404sub add_package { 405 my ($self, $package) = @_; 406 $self->{packages}{$package} = 1; 407} 408 409sub packages { 410 my $self = shift; 411 keys %{$self->{packages} || {}}; 412} 413 414sub remove_inner_packages_from_requirements { 415 my $self = shift; 416 for my $package ($self->packages) { 417 for my $rel (qw/requires recommends suggests noes/) { 418 next unless $self->{$rel}; 419 $self->{$rel}->clear_requirement($package); 420 } 421 } 422} 423 424sub merge_perl { 425 my $self = shift; 426 return unless $self->{perl}; 427 428 my $perl = $self->{requires}->requirements_for_module('perl'); 429 if ($self->{perl}->accepts_module('perl', $perl)) { 430 delete $self->{perl_minimum_version}; 431 } else { 432 $self->add(perl => $self->{perl}->requirements_for_module('perl')); 433 } 434} 435 436sub _keywords {( 437 '__FILE__' => 1, 438 '__LINE__' => 2, 439 '__PACKAGE__' => 3, 440 '__DATA__' => 4, 441 '__END__' => 5, 442 '__SUB__' => 6, 443 AUTOLOAD => 7, 444 BEGIN => 8, 445 UNITCHECK => 9, 446 DESTROY => 10, 447 END => 11, 448 INIT => 12, 449 CHECK => 13, 450 abs => 14, 451 accept => 15, 452 alarm => 16, 453 and => 17, 454 atan2 => 18, 455 bind => 19, 456 binmode => 20, 457 bless => 21, 458 break => 22, 459 caller => 23, 460 chdir => 24, 461 chmod => 25, 462 chomp => 26, 463 chop => 27, 464 chown => 28, 465 chr => 29, 466 chroot => 30, 467 close => 31, 468 closedir => 32, 469 cmp => 33, 470 connect => 34, 471 continue => 35, 472 cos => 36, 473 crypt => 37, 474 dbmclose => 38, 475 dbmopen => 39, 476 default => 40, 477 defined => 41, 478 delete => 42, 479 die => 43, 480 do => 44, 481 dump => 45, 482 each => 46, 483 else => 47, 484 elsif => 48, 485 endgrent => 49, 486 endhostent => 50, 487 endnetent => 51, 488 endprotoent => 52, 489 endpwent => 53, 490 endservent => 54, 491 eof => 55, 492 eq => 56, 493 eval => 57, 494 evalbytes => 58, 495 exec => 59, 496 exists => 60, 497 exit => 61, 498 exp => 62, 499 fc => 63, 500 fcntl => 64, 501 fileno => 65, 502 flock => 66, 503 for => 67, 504 foreach => 68, 505 fork => 69, 506 format => 70, 507 formline => 71, 508 ge => 72, 509 getc => 73, 510 getgrent => 74, 511 getgrgid => 75, 512 getgrnam => 76, 513 gethostbyaddr => 77, 514 gethostbyname => 78, 515 gethostent => 79, 516 getlogin => 80, 517 getnetbyaddr => 81, 518 getnetbyname => 82, 519 getnetent => 83, 520 getpeername => 84, 521 getpgrp => 85, 522 getppid => 86, 523 getpriority => 87, 524 getprotobyname => 88, 525 getprotobynumber => 89, 526 getprotoent => 90, 527 getpwent => 91, 528 getpwnam => 92, 529 getpwuid => 93, 530 getservbyname => 94, 531 getservbyport => 95, 532 getservent => 96, 533 getsockname => 97, 534 getsockopt => 98, 535 given => 99, 536 glob => 100, 537 gmtime => 101, 538 goto => 102, 539 grep => 103, 540 gt => 104, 541 hex => 105, 542 if => 106, 543 index => 107, 544 int => 108, 545 ioctl => 109, 546 join => 110, 547 keys => 111, 548 kill => 112, 549 last => 113, 550 lc => 114, 551 lcfirst => 115, 552 le => 116, 553 length => 117, 554 link => 118, 555 listen => 119, 556 local => 120, 557 localtime => 121, 558 lock => 122, 559 log => 123, 560 lstat => 124, 561 lt => 125, 562 m => 126, 563 map => 127, 564 mkdir => 128, 565 msgctl => 129, 566 msgget => 130, 567 msgrcv => 131, 568 msgsnd => 132, 569 my => 133, 570 ne => 134, 571 next => 135, 572 no => 136, 573 not => 137, 574 oct => 138, 575 open => 139, 576 opendir => 140, 577 or => 141, 578 ord => 142, 579 our => 143, 580 pack => 144, 581 package => 145, 582 pipe => 146, 583 pop => 147, 584 pos => 148, 585 print => 149, 586 printf => 150, 587 prototype => 151, 588 push => 152, 589 q => 153, 590 qq => 154, 591 qr => 155, 592 quotemeta => 156, 593 qw => 157, 594 qx => 158, 595 rand => 159, 596 read => 160, 597 readdir => 161, 598 readline => 162, 599 readlink => 163, 600 readpipe => 164, 601 recv => 165, 602 redo => 166, 603 ref => 167, 604 rename => 168, 605 require => 169, 606 reset => 170, 607 return => 171, 608 reverse => 172, 609 rewinddir => 173, 610 rindex => 174, 611 rmdir => 175, 612 s => 176, 613 say => 177, 614 scalar => 178, 615 seek => 179, 616 seekdir => 180, 617 select => 181, 618 semctl => 182, 619 semget => 183, 620 semop => 184, 621 send => 185, 622 setgrent => 186, 623 sethostent => 187, 624 setnetent => 188, 625 setpgrp => 189, 626 setpriority => 190, 627 setprotoent => 191, 628 setpwent => 192, 629 setservent => 193, 630 setsockopt => 194, 631 shift => 195, 632 shmctl => 196, 633 shmget => 197, 634 shmread => 198, 635 shmwrite => 199, 636 shutdown => 200, 637 sin => 201, 638 sleep => 202, 639 socket => 203, 640 socketpair => 204, 641 sort => 205, 642 splice => 206, 643 split => 207, 644 sprintf => 208, 645 sqrt => 209, 646 srand => 210, 647 stat => 211, 648 state => 212, 649 study => 213, 650 sub => 214, 651 substr => 215, 652 symlink => 216, 653 syscall => 217, 654 sysopen => 218, 655 sysread => 219, 656 sysseek => 220, 657 system => 221, 658 syswrite => 222, 659 tell => 223, 660 telldir => 224, 661 tie => 225, 662 tied => 226, 663 time => 227, 664 times => 228, 665 tr => 229, 666 truncate => 230, 667 uc => 231, 668 ucfirst => 232, 669 umask => 233, 670 undef => 234, 671 unless => 235, 672 unlink => 236, 673 unpack => 237, 674 unshift => 238, 675 untie => 239, 676 until => 240, 677 use => 241, 678 utime => 242, 679 values => 243, 680 vec => 244, 681 wait => 245, 682 waitpid => 246, 683 wantarray => 247, 684 warn => 248, 685 when => 249, 686 while => 250, 687 write => 251, 688 x => 252, 689 xor => 253, 690 y => 254 || 255, 691)} 692 6931; 694 695__END__ 696 697=encoding utf-8 698 699=head1 NAME 700 701Perl::PrereqScanner::NotQuiteLite::Context 702 703=head1 DESCRIPTION 704 705This is typically used to keep callbacks, an eval state, and 706found prerequisites for a processing file. 707 708=head1 METHODS 709 710=head2 add 711 712 $c->add($module); 713 $c->add($module => $minimum_version); 714 715adds a module with/without a minimum version as a requirement 716or a suggestion, depending on the eval state. You can add a module 717with different versions as many times as you wish. The actual 718minimum version for the module is calculated inside 719(by L<CPAN::Meta::Requirements>). 720 721=head2 register_keyword_parser, remove_keyword_parser, register_method_parser, register_sub_parser 722 723 $c->register_keyword_parser( 724 'func_name', 725 [$parser_class, 'parser_for_the_func', $used_module], 726 ); 727 $c->remove_keyword_parser('func_name'); 728 729 $c->register_method_parser( 730 'method_name', 731 [$parser_class, 'parser_for_the_method', $used_module], 732 ); 733 734If you find a module that can export a loader function is actually 735C<use>d (such as L<Moose> that can export an C<extends> function 736that will load a module internally), you might also register the 737loader function as a custom keyword dynamically so that the scanner 738can also run a callback for the function to parse its argument 739tokens. 740 741You can also remove the keyword when you find the module is C<no>ed 742(and when the module supports C<unimport>). 743 744You can also register a method callback on the fly (but you can't 745remove it). 746 747If you always want to check some functions/methods when you load a 748plugin, just register them using a C<register> method in the plugin. 749 750=head2 requires 751 752returns a CPAN::Meta::Requirements object for requirements. 753 754=head2 suggests 755 756returns a CPAN::Meta::Requirements object for suggestions 757(requirements in C<eval>s), or undef when it is not expected to 758parse tokens in C<eval>. 759 760=head1 METHODS MOSTLY FOR INTERNAL USE 761 762=head2 new 763 764creates an instance. You usually don't need to call this because 765it's automatically created in the scanner. 766 767=head2 has_callbacks, has_callback_for, run_callback_for 768 769 next unless $c->has_callbacks('use'); 770 next unless $c->has_callbacks_for('use', 'base'); 771 $c->run_callbacks_for('use', 'base', $tokens); 772 773C<has_callbacks> returns true if a callback for C<use>, C<no>, 774C<keyword>, or C<method> is registered. C<has_callbacks_for> 775returns true if a callback for the module/keyword/method is 776registered. C<run_callbacks_for> is to run the callback. 777 778=head2 has_added 779 780returns true if a module has already been added as a requirement 781or a suggestion. Only useful for the ::UniversalVersion plugin. 782 783=head1 AUTHOR 784 785Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt> 786 787=head1 COPYRIGHT AND LICENSE 788 789This software is copyright (c) 2015 by Kenichi Ishigaki. 790 791This is free software; you can redistribute it and/or modify it under 792the same terms as the Perl 5 programming language system itself. 793 794=cut 795