Perl-PrereqScanner-NotQuiteLite-0.9917/0000755000175100017510000000000014422514733020030 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/Changes0000644000175100017510000000716314422514712021327 0ustar ishigakiishigakiRevision history for Perl-PrereqScanner-NotQuiteLite 0.9917 2023/04/27 - Update Object::Pad support (:isa/:does) 0.9916 2022/04/08 - Ignore core modules with undef version correctly - Drop URI::cpan dependency and use Parse::Distname to parse cpan URI 0.9915 2022/04/01 - Add optional option 0.9914 2021/09/13 - Support Object::Pad 0.9913 2020/09/06 - Add URI::cpan to cpanfile 0.9912 2020/09/06 - Fix not to dedupe core modules needlessly - Use a main module to represent modules that belong to the same distribution - Dedupe build requires as well 0.9911 2020/05/10 - Remove cached cpanmeta if prereqs are replaced 0.9910 2020/05/10 - changed ::App->run to return processed cpanfile object if cpanfile option is set - changed ::App->run not to print unless print option is set 0.9909 2019/11/30 - allowed full package names for Plack Middleware (Graham TerMarsch++) 0.9908 2019/08/24 - fixed Win32 path separator issues 0.9907 2019/08/22 - changed scan_also and features options to accept glob expressions - added "version" option to show what's going on 0.9906 2019/07/06 - fixed PackageVariant parser not to die when it finds something other than importing 0.9905 2019/05/10 - changed scan-perl-prereqs-nqlite to use only :bundled parsers by default - added perl_minimum_version option - added feature pragma arg parser - added indented heredoc and <<$fh>> support - fixed eval shortcut handling - fixed parsers to treat several keywords as ops - fixed various small parser issues (//, regexp after return, heredoc terminator, package version/block, when modifier etc) - renamed internal flags 0.9904 2019/02/07 - made sure to exclude local/core/private modules from feature prereqs - added scan_also/parser/private options 0.9903 2019/02/03 - added an option to dedupe modules that belong to the same distribution with the help of CPAN::Common::Index 0.9902 2018/12/06 - implemented ignore and ignore_re options to exclude specific paths 0.9901 2018/11/07 - improved Package::Variant parser 0.99 2018/11/05 - Package::Variant support - requires Module::CPANfile 1.1004 0.98 2018/10/31 - added allow-test-pms option that forces to include test dependencies that are used in t/**.pm files that are not directly used .t files; this option is also set if Test::Class family is used (RT-127383) 0.97 2018/09/30 - allow in-file parser package 0.96 2018/09/16 - exclude_core option now respects used perl version - ignore .pm files under t/ unless they are used in .t files - ignore Makefile.PL under t/ - requires Data::Dump 0.95 2018/09/16 - added deep recursion protection - support fully qualified Test::More::plan/done_testing - Keyword::Declare support - ignore internal package inheritance - BEING { ... exit } support 0.94 2018/09/08 - noes are now stored separately 0.93 2018/04/26 - silence a deprecation warning (RT-125191) 0.92 2018/04/26 - fixed to work with Module::CPANfile 1.1003 0.91 2017/11/25 - fixed packaging issue (RT-123735) 0.90 2017/11/25 - refactored and added more parsers - fixed various parsing issues - cpanfile support 0.50 2017/01/28 - production release 0.49_03 2016/08/05 - fixed another utf8 issue where unicode characters appear before use utf8 - fixed various issues regarding "recommends"/"suggests" 0.49_02 2016/08/04 - explicitly use BEGIN for older versions of perl - reset pos after utf8::decode for perl 5.14/5.16 0.49_01 2016/08/03 - refactored, using regexp instead of Compiler::Lexer. BACKWARD INCOMPATIBLE FOR CUSTOM PARSER USERS 0.01 2015/05/30 - initial release Perl-PrereqScanner-NotQuiteLite-0.9917/lib/0000755000175100017510000000000014422514733020576 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/0000755000175100017510000000000014422514733021500 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/0000755000175100017510000000000014422514733024250 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite.pm0000644000175100017510000022670614422514625027211 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite; use strict; use warnings; use Carp; use Perl::PrereqScanner::NotQuiteLite::Context; use Perl::PrereqScanner::NotQuiteLite::Util; our $VERSION = '0.9917'; our @BUNDLED_PARSERS = qw/ Aliased AnyMoose Autouse Catalyst ClassAccessor ClassAutouse ClassLoad Core Inline KeywordDeclare Later Mixin ModuleRuntime MojoBase Moose MooseXDeclare ObjectPad Only PackageVariant Plack POE Prefork Superclass Syntax SyntaxCollector TestClassMost TestMore TestRequires UniversalVersion Unless /; our @DEFAULT_PARSERS = qw/Core Moose/; ### Helpers For Debugging use constant DEBUG => !!$ENV{PERL_PSNQL_DEBUG} || 0; use constant DEBUG_RE => DEBUG > 3 ? 1 : 0; sub _debug {} sub _error {} sub _dump_stack {} if (DEBUG) { require Data::Dump; Data::Dump->import(qw/dump/); no warnings 'redefine'; *_debug = sub { print @_, "\n" }; *_error = sub { print @_, "*" x 50, "\n" }; *_dump_stack = sub { my ($c, $char) = @_; my $stacked = join '', map {($_->[2] ? "($_->[2])" : '').$_->[0]} @{$c->{stack}}; _debug("$char \t\t\t\t stacked: $stacked"); }; } sub _match_error { my $rstr = shift; $@ = shift() . substr($$rstr, pos($$rstr), 100); return; } ### Global Variables To Be Sorted Out Later my %unsupported_packages = map {$_ => 1} qw( ); my %sub_keywords = ( 'Function::Parameters' => [qw/fun method/], 'TryCatch' => [qw/try catch/], ); my %filter_modules = ( tt => sub { ${$_[0]} =~ s|\G.+?no\s*tt\s*;||s; 0; }, 'Text::RewriteRules' => sub { ${$_[0]} =~ s|RULES.+?ENDRULES\n||gs; 1 }, ); my %is_conditional = map {$_ => 1} qw( if elsif unless else given when for foreach while until ); my %ends_expr = map {$_ => 1} qw( and or xor if else elsif unless when default for foreach while until && || !~ =~ = += -= *= /= **= //= %= ^= |= > < >= <= <> <=> cmp ge gt le lt eq ne ? : ); my %has_sideff = map {$_ => 1} qw( and or xor && || // if unless when ); # keywords that allow /regexp/ to follow directly my %regexp_may_follow = map {$_ => 1} qw( and or cmp if elsif unless eq ne gt lt ge le for while until grep map not split when return ); my $re_namespace = qr/(?:::|')?(?:[a-zA-Z0-9_]+(?:(?:::|')[a-zA-Z0-9_]+)*)/; my $re_nonblock_chars = qr/[^\\\(\)\{\}\[\]\<\>\/"'`#q~,\s]*/; my $re_variable = qr/ (?:$re_namespace) | (?:\^[A-Z\]]) | (?:\{\^[A-Z0-9_]+\}) | (?:[_"\(\)<\\\&`'\+\-,.\/\%#:=~\|?!\@\*\[\]\^]) /x; my $re_pod = qr/( =[a-zA-Z]\w*\b .*? (?:(?:\n) =cut\b.*?(?:\n|\z)|\z) )/sx; my $re_comment = qr/(?:\s*#[^\n]*?\n)*(?:\s*#[^\n]*?)(?:\n|$)/s; my $g_re_scalar_variable = qr{\G(\$(?:$re_variable))}; my $g_re_hash_shortcut = qr{\G(\{\s*(?:[\+\-]?\w+|(['"])[\w\s]+\2|(?:$re_nonblock_chars))\s*(?/; my $re_skip = qr{[^\Q$ldel$rdel\E\\]+}; [$rdel, $re_skip]; }}; } my %RegexpShortcut; sub _gen_re_regexp_shortcut { my ($ldel, $rdel) = @_; $RegexpShortcut{$ldel} ||= do { $ldel = quotemeta $ldel; $rdel = $rdel ? quotemeta $rdel : $ldel; qr{(?:[^\\\(\)\{\}\[\]<>$ldel$rdel]*(?:\\.[^\\\(\)\[\]\{\}<>$ldel$rdel]*)*)$rdel}; }; } ############################ my %LOADED; sub new { my ($class, %args) = @_; my %mapping; my @parsers = $class->_get_parsers($args{parsers}); for my $parser (@parsers) { if (!exists $LOADED{$parser}) { eval "require $parser; 1"; if (my $error = $@) { $parser->can('register') or die "Parser Error: $error"; } $LOADED{$parser} = $parser->can('register') ? $parser->register(%args) : undef; } my $parser_mapping = $LOADED{$parser} or next; for my $type (qw/use no keyword method/) { next unless exists $parser_mapping->{$type}; for my $name (keys %{$parser_mapping->{$type}}) { $mapping{$type}{$name} = [ $parser, $parser_mapping->{$type}{$name}, (($type eq 'use' or $type eq 'no') ? ($name) : ()), ]; } } if ($parser->can('register_fqfn')) { my $fqfn_mapping = $parser->register_fqfn; for my $name (keys %$fqfn_mapping) { my ($module) = $name =~ /^(.+)::/; $mapping{keyword}{$name} = [ $parser, $fqfn_mapping->{$name}, $module, ]; } } } $args{_} = \%mapping; bless \%args, $class; } sub _get_parsers { my ($class, $list) = @_; my @parsers; my %should_ignore; for my $parser (@{$list || [qw/:default/]}) { if ($parser eq ':installed') { require Module::Find; push @parsers, Module::Find::findsubmod("$class\::Parser"); } elsif ($parser eq ':bundled') { push @parsers, map {"$class\::Parser::$_"} @BUNDLED_PARSERS; } elsif ($parser eq ':default') { push @parsers, map {"$class\::Parser::$_"} @DEFAULT_PARSERS; } elsif ($parser =~ s/^\+//) { push @parsers, $parser; } elsif ($parser =~ s/^\-//) { $should_ignore{"$class\::Parser\::$parser"} = 1; } elsif ($parser =~ /^$class\::Parser::/) { push @parsers, $parser; } else { push @parsers, "$class\::Parser\::$parser"; } } grep {!$should_ignore{$_}} @parsers; } sub scan_file { my ($self, $file) = @_; _debug("START SCANNING $file") if DEBUG; print STDERR " Scanning $file\n" if $self->{verbose}; open my $fh, '<', $file or croak "Can't open $file: $!"; my $code = do { local $/; <$fh> }; $self->{file} = $file; $self->scan_string($code); } sub scan_string { my ($self, $string) = @_; $string = '' unless defined $string; my $c = Perl::PrereqScanner::NotQuiteLite::Context->new(%$self); if ($self->{quick}) { $c->{file_size} = length $string; $self->_skim_string($c, \$string) if $c->{file_size} > 30_000; } # UTF8 BOM if ($string =~ s/\A(\xef\xbb\xbf)//s) { utf8::decode($string); $c->{decoded} = 1; } # Other BOMs (TODO: also decode?) $string =~ s/\A(\x00\x00\xfe\xff|\xff\xfe\x00\x00|\xfe\xff|\xff\xfe)//s; # normalize if ("\n" eq "\015") { $string =~ s/(?:\015?\012)/\n/gs; } elsif ("\n" eq "\012") { $string =~ s/(?:\015\012?)/\n/gs; } elsif ("\n" eq "\015\012") { $string =~ s/(?:\015(?!\012)|(?{stack} = []; $c->{errors} = []; $c->{callback} = { use => \&_use, require => \&_require, no => \&_no, }; $c->{wants_doc} = 0; pos($string) = 0; { local $@; eval { $self->_scan($c, \$string, 0) }; push @{$c->{errors}}, "Scan Error: $@" if $@; if ($c->{redo}) { delete $c->{redo}; delete $c->{ended}; @{$c->{stack}} = (); redo; } } if (@{$c->{stack}} and !$c->{quick}) { require Data::Dump; push @{$c->{errors}}, Data::Dump::dump($c->{stack}); } $c->remove_inner_packages_from_requirements; $c->merge_perl; $c; } sub _skim_string { my ($self, $c, $rstr) = @_; my $pos = pos($$rstr) || 0; my $last_found = 0; my $saw_moose; my $re = qr/\G.*?\b((?:use|require|no)\s+(?:[A-Za-z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*)/; while(my ($match) = $$rstr =~ /$re/gc) { $last_found = pos($$rstr) + length $match; if (!$saw_moose and $match =~ /^use\s+(?:Mo(?:o|(?:[ou]se))?X?|MooseX::Declare)\b/) { $re = qr/\G.*?\b((?:(?:use|require|no)\s+(?:[A-Za-z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*)|(?:(?:extends|with)\s+(?:["']|q[a-z]*[^a-zA-Z0-9_])(?:[A-Za-z][A-Za-z0-9_]*::)*[A-Za-z][A-Za-z0-9_]*))/; $saw_moose = 1; } } $c->{last_found_by_skimming} = $last_found; pos($$rstr) = $pos; } sub _scan { my ($self, $c, $rstr, $parent_scope) = @_; if (@{$c->{stack}} > 90) { _error("deep recursion found"); $c->{ended} = 1; } _dump_stack($c, "BEGIN SCOPE") if DEBUG; # found __DATA|END__ somewhere? return $c if $c->{ended}; my $wants_doc = $c->{wants_doc}; my $line_top = 1; my $waiting_for_a_block; my $current_scope = 0; my ($token, $token_desc, $token_type) = ('', '', ''); my ($prev_token, $prev_token_type) = ('', ''); my ($stack, $unstack); my (@keywords, @tokens, @scope_tokens); my $caller_package; my $prepend; my ($pos, $c1); my $prev_pos = 0; while(defined($pos = pos($$rstr))) { $token = undef; # cache first letter for better performance $c1 = substr($$rstr, $pos, 1); if ($line_top) { if ($c1 eq '=') { if ($$rstr =~ m/\G($re_pod)/gcsx) { ($token, $token_desc, $token_type) = ($1, 'POD', '') if $wants_doc; next; } } } if ($c1 eq "\n") { pos($$rstr)++; $line_top = 1; next; } $line_top = 0; # ignore whitespaces if ($c1 eq ' ') { pos($$rstr)++; next; } elsif ($c1 eq '_') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '_' and $$rstr =~ m/\G(__(?:DATA|END)__\b)(?!\s*=>)/gc) { if ($wants_doc) { ($token, $token_desc, $token_type) = ($1, 'END_OF_CODE', ''); next; } else { $c->{ended} = 1; last; } } } elsif ($c1 eq '#') { if ($$rstr =~ m{\G($re_comment)}gcs) { ($token, $token_desc, $token_type) = ($1, 'COMMENT', '') if $wants_doc; $line_top = 1; next; } } elsif ($c1 eq ';') { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, ';', ';'); $current_scope |= F_STATEMENT_END|F_EXPR_END; next; } elsif ($c1 eq '$') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '#') { if (substr($$rstr, $pos + 2, 1) eq '{') { if ($$rstr =~ m{\G(\$\#\{[\w\s]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '$#{NAME}', 'EXPR'); next; } else { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('$#{', '$#{', 'EXPR'); $stack = [$token, $pos, 'VARIABLE']; next; } } elsif ($$rstr =~ m{\G(\$\#(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '$#NAME', 'EXPR'); next; } elsif ($prev_token_type eq 'ARROW') { my $c3 = substr($$rstr, $pos + 2, 1); if ($c3 eq '*') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('$#*', 'VARIABLE', 'VARIABLE'); $c->add_perl('5.020', '->$#*'); next; } } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('$#', 'SPECIAL_VARIABLE', 'EXPR'); next; } } elsif ($c2 eq '$') { if ($$rstr =~ m{\G(\$(?:\$)+(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '$$NAME', 'VARIABLE'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('$$', 'SPECIAL_VARIABLE', 'EXPR'); next; } } elsif ($c2 eq '{') { if ($$rstr =~ m{\G(\$\{[\w\s]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '${NAME}', 'VARIABLE'); if ($prev_token_type eq 'KEYWORD' and $c->token_expects_fh_or_block_list($prev_token)) { $token_type = ''; next; } } elsif ($$rstr =~ m{\G(\$\{\^[A-Z_]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '${^NAME}', 'VARIABLE'); if ($token eq '${^CAPTURE}' or $token eq '${^CAPTURE_ALL}') { $c->add_perl('5.026', '${^CAPTURE}'); } if ($token eq '${^SAFE_LOCALES}') { $c->add_perl('5.028', '${^SAFE_LOCALES}'); } } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('${', '${', 'VARIABLE'); $stack = [$token, $pos, 'VARIABLE']; } if ($parent_scope & F_EXPECTS_BRACKET) { $current_scope |= F_SCOPE_END; } next; } elsif ($c2 eq '*' and $prev_token_type eq 'ARROW') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('$*', '$*', 'VARIABLE'); $c->add_perl('5.020', '->$*'); next; } elsif ($c2 eq '+' or $c2 eq '-') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('$'.$c2, 'SPECIAL_VARIABLE', 'VARIABLE'); $c->add_perl('5.010', '$'.$c2); next; } elsif ($$rstr =~ m{$g_re_scalar_variable}gc) { ($token, $token_desc, $token_type) = ($1, '$NAME', 'VARIABLE'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'VARIABLE'); next; } } elsif ($c1 eq '@') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '_' and $$rstr =~ m{\G\@_\b}gc) { ($token, $token_desc, $token_type) = ('@_', 'SPECIAL_VARIABLE', 'VARIABLE'); next; } elsif ($c2 eq '{') { if ($$rstr =~ m{\G(\@\{[\w\s]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '@{NAME}', 'VARIABLE'); if ($token eq '@{^CAPTURE}' or $token eq '@{^CAPTURE_ALL}') { $c->add_perl('5.026', '@{^CAPTURE}'); } } elsif ($$rstr =~ m{\G(\@\{\^[A-Z_]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '@{^NAME}', 'VARIABLE'); if ($token eq '@{^CAPTURE}' or $token eq '@{^CAPTURE_ALL}') { $c->add_perl('5.026', '@{^CAPTURE}'); } } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('@{', '@{', 'VARIABLE'); $stack = [$token, $pos, 'VARIABLE']; } if ($prev_token_type eq 'ARROW') { $c->add_perl('5.020', '->@{}'); } if ($parent_scope & F_EXPECTS_BRACKET) { $current_scope |= F_SCOPE_END; } next; } elsif ($c2 eq '$') { if ($$rstr =~ m{\G(\@\$(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '@$NAME', 'VARIABLE'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('@$', '@$', 'VARIABLE'); next; } } elsif ($prev_token_type eq 'ARROW') { # postderef if ($c2 eq '*') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('@*', '@*', 'VARIABLE'); $c->add_perl('5.020', '->@*'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ('@', '@', 'VARIABLE'); $c->add_perl('5.020', '->@'); next; } } elsif ($c2 eq '[') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('@[', 'SPECIAL_VARIABLE', 'VARIABLE'); next; } elsif ($c2 eq '+' or $c2 eq '-') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('@'.$c2, 'SPECIAL_VARIABLE', 'VARIABLE'); $c->add_perl('5.010', '@'.$c2); next; } elsif ($$rstr =~ m{\G(\@(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '@NAME', 'VARIABLE'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'VARIABLE'); next; } } elsif ($c1 eq '%') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '{') { if ($$rstr =~ m{\G(\%\{[\w\s]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '%{NAME}', 'VARIABLE'); } elsif ($$rstr =~ m{\G(\%\{\^[A-Z_]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '%{^NAME}', 'VARIABLE'); if ($token eq '%{^CAPTURE}' or $token eq '%{^CAPTURE_ALL}') { $c->add_perl('5.026', '%{^CAPTURE}'); } } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('%{', '%{', 'VARIABLE'); $stack = [$token, $pos, 'VARIABLE']; } if ($prev_token_type eq 'ARROW') { $c->add_perl('5.020', '->%{'); } if ($parent_scope & F_EXPECTS_BRACKET) { $current_scope |= F_SCOPE_END; } next; } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('%=', '%=', 'OP'); next; } elsif ($$rstr =~ m{\G(\%\$(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '%$NAME', 'VARIABLE'); next; } elsif ($$rstr =~ m{\G(\%(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '%NAME', 'VARIABLE'); next; } elsif ($prev_token_type eq 'VARIABLE' or $prev_token_type eq 'EXPR') { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } elsif ($prev_token_type eq 'ARROW') { if ($c2 eq '*') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('%*', '%*', 'VARIABLE'); $c->add_perl('5.020', '->%*'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ('%', '%', 'VARIABLE'); $c->add_perl('5.020', '->%'); next; } } elsif ($c2 eq '+' or $c2 eq '-') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('%'.$c2, 'SPECIAL_VARIABLE', 'VARIABLE'); $c->add_perl('5.010', '%'.$c2); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'VARIABLE'); next; } } elsif ($c1 eq '*') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '{') { if ($prev_token_type eq 'ARROW') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('*{', '*{', 'VARIABLE'); $c->add_perl('5.020', '->*{}'); next; } elsif ($$rstr =~ m{\G(\*\{[\w\s]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '*{NAME}', 'VARIABLE'); if ($prev_token eq 'KEYWORD' and $c->token_expects_fh_or_block_list($prev_token)) { $token_type = ''; next; } } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('*{', '*{', 'VARIABLE'); $stack = [$token, $pos, 'VARIABLE']; } if ($parent_scope & F_EXPECTS_BRACKET) { $current_scope |= F_SCOPE_END; } next; } elsif ($c2 eq '*') { if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('**=', '**=', 'OP'); next; } elsif ($prev_token_type eq 'ARROW') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('**', '**', 'VARIABLE'); $c->add_perl('5.020', '->**'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('**', '**', 'OP'); next; } } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('*=', '*=', 'OP'); next; } elsif ($$rstr =~ m{\G(\*(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '*NAME', 'VARIABLE'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '&') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '&') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('&&', '&&', 'OP'); next; } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('&=', '&=', 'OP'); next; } elsif ($c2 eq '{') { if ($$rstr =~ m{\G(\&\{[\w\s]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '&{NAME}', 'EXPR'); } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('&{', '&{', 'EXPR'); $stack = [$token, $pos, 'FUNC']; } if ($parent_scope & F_EXPECTS_BRACKET) { $current_scope |= F_SCOPE_END; } next; } elsif ($c2 eq '.') { if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('&.=', '&.=', 'OP'); } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('&.', '&.', 'OP'); } $c->add_perl('5.022', '&.'); next; } elsif ($$rstr =~ m{\G(\&(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '&NAME', 'EXPR'); next; } elsif ($$rstr =~ m{\G(\&\$(?:$re_namespace))}gc) { ($token, $token_desc, $token_type) = ($1, '&$NAME', 'EXPR'); next; } elsif ($prev_token_type eq 'ARROW') { if ($c2 eq '*') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('&*', '&*', 'VARIABLE'); $c->add_perl('5.020', '->&*'); next; } } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '\\') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '{') { if ($$rstr =~ m{\G(\\\{[\w\s]+\})}gc) { ($token, $token_desc, $token_type) = ($1, '\\{NAME}', 'VARIABLE'); } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('\\{', '\\{', 'VARIABLE'); $stack = [$token, $pos, 'VARIABLE']; } if ($parent_scope & F_EXPECTS_BRACKET) { $current_scope |= F_SCOPE_END; } next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, ''); next; } } elsif ($c1 eq '-') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '>') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('->', 'ARROW', 'ARROW'); if ($prev_token_type eq 'WORD' or $prev_token_type eq 'KEYWORD') { $caller_package = $prev_token; $current_scope |= F_KEEP_TOKENS; } next; } elsif ($c2 eq '-') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('--', '--', $prev_token_type); next; } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('-=', '-=', 'OP'); next; } elsif ($$rstr =~ m{\G(\-[ABCMORSTWXbcdefgkloprstuwxz]\b)}gc) { ($token, $token_desc, $token_type) = ($1, 'FILE_TEST', 'EXPR'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq q{"}) { if ($$rstr =~ m{\G(?:\"($re_str_in_double_quotes)\")}gcs) { ($token, $token_desc, $token_type) = ([$1, q{"}], 'STRING', 'STRING'); next; } } elsif ($c1 eq q{'}) { if ($$rstr =~ m{\G(?:\'($re_str_in_single_quotes)\')}gcs) { ($token, $token_desc, $token_type) = ([$1, q{'}], 'STRING', 'STRING'); next; } } elsif ($c1 eq '`') { if ($$rstr =~ m{\G(?:\`($re_str_in_backticks)\`)}gcs) { ($token, $token_desc, $token_type) = ([$1, q{`}], 'BACKTICK', 'EXPR'); next; } } elsif ($c1 eq '/') { if ($prev_token_type eq '' or $prev_token_type eq 'OP' or ($prev_token_type eq 'KEYWORD' and $regexp_may_follow{$prev_token})) { # undoubtedly regexp if (my $regexp = $self->_match_regexp0($c, $rstr, $pos, 'm')) { ($token, $token_desc, $token_type) = ($regexp, 'REGEXP', 'EXPR'); next; } else { # the above may fail _debug("REGEXP ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } if (($prev_token_type eq '' or (!($current_scope & F_EXPR) and $prev_token_type eq 'WORD')) or ($prev_token_type eq 'KEYWORD' and @keywords and $prev_token eq $keywords[-1] and $regexp_may_follow{$prev_token})) { if (my $regexp = $self->_match_regexp0($c, $rstr, $pos)) { ($token, $token_desc, $token_type) = ($regexp, 'REGEXP', 'EXPR'); next; } else { # the above may fail _debug("REGEXP ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '/') { if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('//=', '//=', 'OP'); $c->add_perl('5.010', '//='); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('//', '//', 'OP'); $c->add_perl('5.010', '//'); next; } } if ($c2 eq '=') { # this may be a part of /=.../ pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('/=', '/=', 'OP'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '{') { if ($$rstr =~ m{$g_re_hash_shortcut}gc) { ($token, $token_desc) = ($1, '{EXPR}'); if ($current_scope & F_EVAL) { $current_scope &= MASK_EVAL; $c->{eval} = ($current_scope | $parent_scope) & F_EVAL ? 1 : 0; } if ($parent_scope & F_EXPECTS_BRACKET) { $current_scope |= F_SCOPE_END; next; } if ($prev_token_type eq 'ARROW' or $prev_token_type eq 'VARIABLE') { $token_type = 'VARIABLE'; next; } elsif ($waiting_for_a_block) { $waiting_for_a_block = 0; if (@keywords and $c->token_expects_block($keywords[0])) { my $first_token = $keywords[0]; $current_scope |= F_EXPR_END; if ($c->token_defines_sub($first_token) and $c->has_callback_for(sub => $first_token)) { $c->run_callback_for(sub => $first_token, \@tokens); $current_scope &= MASK_KEEP_TOKENS; @tokens = (); } } next; } elsif ($prev_token_type eq 'KEYWORD' and $c->token_expects_fh_or_block_list($prev_token)) { $token_type = ''; next; } else { $token_type = 'EXPR'; next; } } pos($$rstr) = $pos + 1; ($token, $token_desc) = ($c1, $c1); my $stack_owner; if (@keywords) { for(my $i = @keywords; $i > 0; $i--) { my $keyword = $keywords[$i - 1]; if ($c->token_expects_block($keyword)) { $stack_owner = $keyword; if (@tokens and $c->token_defines_sub($keyword) and $c->has_callback_for(sub => $keyword)) { $c->run_callback_for(sub => $keyword, \@tokens); $current_scope &= MASK_KEEP_TOKENS; @tokens = (); } last; } } } $stack = [$token, $pos, $stack_owner || '']; if ($parent_scope & F_EXPECTS_BRACKET) { $current_scope |= F_SCOPE_END|F_STATEMENT_END|F_EXPR_END; next; } if ($prev_token_type eq 'ARROW' or $prev_token_type eq 'VARIABLE') { $token_type = 'VARIABLE'; } elsif ($waiting_for_a_block) { $waiting_for_a_block = 0; } else { $token_type = (($current_scope | $parent_scope) & F_KEEP_TOKENS) ? 'EXPR' : ''; } next; } elsif ($c1 eq '[') { if ($$rstr =~ m{\G(\[(?:$re_nonblock_chars)\])}gc) { ($token, $token_desc, $token_type) = ($1, '[EXPR]', 'VARIABLE'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'VARIABLE'); $stack = [$token, $pos, 'VARIABLE']; next; } } elsif ($c1 eq '(') { my $prototype_re = $c->prototype_re; if ($waiting_for_a_block and @keywords and $c->token_defines_sub($keywords[-1]) and $$rstr =~ m{$prototype_re}gc) { my $proto = $1; if ($proto =~ /^\([\\\$\@\%\&\[\]\*;\+]*\)$/) { ($token, $token_desc, $token_type) = ($proto, '(PROTOTYPE)', ''); } else { ($token, $token_desc, $token_type) = ($proto, '(SIGNATURES)', ''); $c->add_perl('5.020', 'signatures'); } next; } elsif ($$rstr =~ m{\G\(((?:$re_nonblock_chars)(?token_expects_expr_block($prev_token)) { if ($prev_token eq 'eval') { $current_scope &= MASK_EVAL; $c->{eval} = ($current_scope | $parent_scope) & F_EVAL ? 1 : 0; } pop @keywords; } next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'EXPR'); my $stack_owner; if (@keywords) { for (my $i = @keywords; $i > 0; $i--) { my $keyword = $keywords[$i - 1]; if ($c->token_expects_block($keyword)) { $stack_owner = $keyword; last; } } } $stack = [$token, $pos, $stack_owner || '']; next; } } elsif ($c1 eq '}') { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, ''); $unstack = $token; $current_scope |= F_STATEMENT_END|F_EXPR_END; next; } elsif ($c1 eq ']') { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, ''); $unstack = $token; next; } elsif ($c1 eq ')') { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, ''); $unstack = $token; next; } elsif ($c1 eq '<') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '<'){ if ($$rstr =~ m{\G(<<(?: \\. | \w+ | [./-] | \[[^\]]*\] | \{[^\}]*\} | \* | \? | \~ | \$ | )*(?>)}gcx) { ($token, $token_desc, $token_type) = ($1, '<>', 'EXPR'); $c->add_perl('5.022', '<>'); next; } elsif ($$rstr =~ m{\G<<~?\s*(?: \\?[A-Za-z_][\w]* | "(?:[^\\"]*(?:\\.[^\\"]*)*)" | '(?:[^\\']*(?:\\.[^\\']*)*)' | `(?:[^\\`]*(?:\\.[^\\`]*)*)` )}sx) { if (my $heredoc = $self->_match_heredoc($c, $rstr)) { ($token, $token_desc, $token_type) = ($heredoc, 'HEREDOC', 'EXPR'); next; } else { # the above may fail pos($$rstr) = $pos; } } if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('<<=', '<<=', 'OP'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('<<', '<<', 'OP'); next; } } elsif ($c2 eq '=') { if (substr($$rstr, $pos + 2, 1) eq '>') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('<=>', '<=>', 'OP'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('<=', '<=', 'OP'); next; } } elsif ($c2 eq '>') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('<>', '<>', 'OP'); next; } elsif ($$rstr =~ m{\G(<(?: \\. | \w+ | [./-] | \[[^\]]*\] | \{[^\}]*\} | \* | \? | \~ | \$ | )*(?)}gcx) { ($token, $token_desc, $token_type) = ($1, '', 'EXPR'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq ':') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq ':') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('::', '::', ''); next; } if ($waiting_for_a_block and @keywords and $c->token_defines_sub($keywords[-1])) { while($$rstr =~ m{\G\s*(:?\s*[\w]+)}gcs) { my $startpos = pos($$rstr); if (substr($$rstr, $startpos, 1) eq '(') { my @nest = '('; pos($$rstr) = $startpos + 1; my ($p, $c1); while(defined($p = pos($$rstr))) { $c1 = substr($$rstr, $p, 1); if ($c1 eq '\\') { pos($$rstr) = $p + 2; next; } if ($c1 eq ')') { pop @nest; pos($$rstr) = $p + 1; last unless @nest; } if ($c1 eq '(') { push @nest, $c1; pos($$rstr) = $p + 1; next; } $$rstr =~ m{\G([^\\()]+)}gc and next; } } } $token = substr($$rstr, $pos, pos($$rstr) - $pos); ($token_desc, $token_type) = ('ATTRIBUTE', ''); if ($token =~ /^:prototype\(/) { $c->add_perl('5.020', ':prototype'); } next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '=') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '>') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('=>', 'COMMA', 'OP'); if (@keywords and $prev_token_type eq 'KEYWORD' and $keywords[-1] eq $prev_token) { pop @keywords; if (!@keywords and ($current_scope & F_KEEP_TOKENS)) { $current_scope &= MASK_KEEP_TOKENS; @tokens = (); } } next; } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('==', '==', 'OP'); next; } elsif ($c2 eq '~') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('=~', '=~', 'OP'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '>') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '>') { if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('>>=', '>>=', 'OP'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('>>', '>>', 'OP'); next; } } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('>=', '>=', 'OP'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '+') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '+') { if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('++=', '++=', 'OP'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('++', '++', $prev_token_type); next; } } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('+=', '+=', 'OP'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '|') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '|') { if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('||=', '||=', 'OP'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('||', '||', 'OP'); next; } } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('|=', '|=', 'OP'); next; } elsif ($c2 eq '.') { if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('|.=', '|.=', 'OP'); } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('|.', '|.', 'OP'); } $c->add_perl('5.022', '|.'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '^') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('^=', '^=', 'OP'); next; } elsif ($c2 eq '.') { if (substr($$rstr, $pos + 2, 1) eq '=') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('^.=', '^.=', 'OP'); } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('^.', '^.', 'OP'); } $c->add_perl('5.022', '^.'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '!') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '~') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('!~', '!~', 'OP'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '~') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '~') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('~~', '~~', 'OP'); $c->add_perl('5.010', '~~'); next; } elsif ($c2 eq '.') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('~.', '~.', 'OP'); $c->add_perl('5.022', '~.'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq ',') { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, 'COMMA', 'OP'); next; } elsif ($c1 eq '?') { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } elsif ($c1 eq '.') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq '.') { if (substr($$rstr, $pos + 2, 1) eq '.') { pos($$rstr) = $pos + 3; ($token, $token_desc, $token_type) = ('...', '...', 'OP'); $c->add_perl('5.012', '...'); next; } else { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('..', '..', 'OP'); next; } } elsif ($c2 eq '=') { pos($$rstr) = $pos + 2; ($token, $token_desc, $token_type) = ('.=', '.=', 'OP'); next; } else { pos($$rstr) = $pos + 1; ($token, $token_desc, $token_type) = ($c1, $c1, 'OP'); next; } } elsif ($c1 eq '0') { my $c2 = substr($$rstr, $pos + 1, 1); if ($c2 eq 'x') { if ($$rstr =~ m{\G(0x[0-9A-Fa-f_]+)}gc) { ($token, $token_desc, $token_type) = ($1, 'HEX NUMBER', 'EXPR'); next; } } elsif ($c2 eq 'b') { if ($$rstr =~ m{\G(0b[01_]+)}gc) { ($token, $token_desc, $token_type) = ($1, 'BINARY NUMBER', 'EXPR'); next; } } } if ($$rstr =~ m{\G((?:0|[1-9][0-9_]*)(?:\.[0-9][0-9_]*)?)}gc) { my $number = $1; my $p = pos($$rstr); my $n1 = substr($$rstr, $p, 1); if ($n1 eq '.') { if ($$rstr =~ m{\G((?:\.[0-9_])+)}gc) { $number .= $1; ($token, $token_desc, $token_type) = ($number, 'VERSION_STRING', 'EXPR'); next; } elsif (substr($$rstr, $p, 2) ne '..') { $number .= '.'; pos($$rstr) = $p + 1; } } elsif ($n1 eq 'E' or $n1 eq 'e') { if ($$rstr =~ m{\G([Ee][+-]?[0-9]+)}gc) { $number .= $1; } } ($token, $token_desc, $token_type) = ($number, 'NUMBER', 'EXPR'); if ($prepend) { $token = "$prepend$token"; pop @tokens if @tokens and $tokens[-1][0] eq $prepend; pop @scope_tokens if @scope_tokens and $scope_tokens[-1][0] eq $prepend; } next; } if ($prev_token_type ne 'ARROW' and ($prev_token_type ne 'KEYWORD' or !$c->token_expects_word($prev_token))) { if ($prev_token_type eq 'EXPR' or $prev_token_type eq 'VARIABLE') { if ($c1 eq 'x') { if ($$rstr =~ m{\G(x\b(?!\s*=>))}gc){ ($token, $token_desc, $token_type) = ($1, $1, ''); next; } } } if ($c1 eq 'q') { my $quotelike_re = $c->quotelike_re; if ($$rstr =~ m{\G((?:$quotelike_re)\b(?!\s*=>))}gc) { if (my $quotelike = $self->_match_quotelike($c, $rstr, $1)) { ($token, $token_desc, $token_type) = ($quotelike, 'STRING', 'STRING'); next; } else { _debug("QUOTELIKE ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } elsif ($$rstr =~ m{\G((?:qw)\b(?!\s*=>))}gc) { if (my $quotelike = $self->_match_quotelike($c, $rstr, $1)) { ($token, $token_desc, $token_type) = ($quotelike, 'QUOTED_WORD_LIST', 'EXPR'); next; } else { _debug("QUOTELIKE ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } elsif ($$rstr =~ m{\G((?:qx)\b(?!\s*=>))}gc) { if (my $quotelike = $self->_match_quotelike($c, $rstr, $1)) { ($token, $token_desc, $token_type) = ($quotelike, 'BACKTICK', 'EXPR'); next; } else { _debug("QUOTELIKE ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } elsif ($$rstr =~ m{\G(qr\b(?!\s*=>))}gc) { if (my $regexp = $self->_match_regexp($c, $rstr)) { ($token, $token_desc, $token_type) = ($regexp, 'qr', 'EXPR'); next; } else { _debug("QUOTELIKE ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } } elsif ($c1 eq 'm') { if ($$rstr =~ m{\G(m\b(?!\s*=>))}gc) { if (my $regexp = $self->_match_regexp($c, $rstr)) { ($token, $token_desc, $token_type) = ($regexp, 'm', 'EXPR'); next; } else { _debug("REGEXP ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } } elsif ($c1 eq 's') { if ($$rstr =~ m{\G(s\b(?!\s*=>))}gc) { if (my $regexp = $self->_match_substitute($c, $rstr)) { ($token, $token_desc, $token_type) = ($regexp, 's', 'EXPR'); next; } else { _debug("SUBSTITUTE ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } } elsif ($c1 eq 't') { if ($$rstr =~ m{\G(tr\b(?!\s*=>))}gc) { if (my $trans = $self->_match_transliterate($c, $rstr)) { ($token, $token_desc, $token_type) = ($trans, 'tr', 'EXPR'); next; } else { _debug("TRANSLITERATE ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } } elsif ($c1 eq 'y') { if ($$rstr =~ m{\G(y\b(?!\s*=>))}gc) { if (my $trans = $self->_match_transliterate($c, $rstr)) { ($token, $token_desc, $token_type) = ($trans, 'y', 'EXPR'); next; } else { _debug("TRANSLITERATE ERROR: $@") if DEBUG; pos($$rstr) = $pos; } } } } if ($$rstr =~ m{\G(\w+)}gc) { $token = $1; if ($prev_token_type eq 'ARROW') { $$rstr =~ m{\G((?:(?:::|')\w+)+)\b}gc and $token .= $1; ($token_desc, $token_type) = ('METHOD', 'METHOD'); } elsif ($token eq 'CORE') { ($token_desc, $token_type) = ('NAMESPACE', 'WORD'); } elsif ($token eq 'format') { if ($$rstr =~ m{\G([^=]*?=[ \t]*\n.*?\n\.\n)}gcs) { $token .= $1; ($token_desc, $token_type) = ('FORMAT', ''); $current_scope |= F_STATEMENT_END|F_EXPR_END; next; } } elsif ($c->token_is_keyword($token) and ($prev_token_type ne 'KEYWORD' or !$c->token_expects_word($prev_token) or ($prev_token eq 'sub' and $token eq 'BEGIN'))) { if ($c->token_is_op_keyword($token)) { ($token_desc, $token_type) = ($token, 'OP'); } else { ($token_desc, $token_type) = ('KEYWORD', 'KEYWORD'); $c->check_new_keyword($token); push @keywords, $token unless $token eq 'undef'; } } else { if ($c1 eq 'v' and $token =~ /^v(?:0|[1-9][0-9]*)$/) { if ($$rstr =~ m{\G((?:\.[0-9][0-9_]*)+)}gc) { $token .= $1; ($token_desc, $token_type) = ('VERSION_STRING', 'EXPR'); next; } } $$rstr =~ m{\G((?:(?:::|')\w+)+)\b}gc and $token .= $1; ($token_desc, $token_type) = ('WORD', 'WORD'); if ($prepend) { $token = "$prepend$token"; pop @tokens if @tokens and $tokens[-1][0] eq $prepend; pop @scope_tokens if @scope_tokens and $scope_tokens[-1][0] eq $prepend; } } next; } # ignore control characters if ($$rstr =~ m{\G([[:cntrl:]]+)}gc) { next; } if ($$rstr =~ m{\G([[:ascii:]]+)}gc) { last if $parent_scope & F_STRING_EVAL; _error("UNKNOWN: $1"); push @{$c->{errors}}, qq{"$1"}; $token = $1; next; } if ($$rstr =~ m{\G([[:^ascii:]](?:[[:^ascii:]]|\w)*)}gc) { if (!$c->{utf8}) { last if $parent_scope & F_STRING_EVAL; _error("UNICODE?: $1"); push @{$c->{errors}}, qq{"$1"}; } else { _debug("UTF8: $1") if DEBUG; } $token = $1; next; } if ($$rstr =~ m{\G(\S+)}gc) { last if $parent_scope & F_STRING_EVAL; _error("UNEXPECTED: $1"); push @{$c->{errors}}, qq{"$1"}; $token = $1; } last; } continue { die "Aborted at $prev_pos" if $prev_pos == pos($$rstr); $prev_pos = pos($$rstr); if (defined $token) { if (!($current_scope & F_EXPR)) { _debug('BEGIN EXPR') if DEBUG; $current_scope |= F_EXPR; } elsif (($current_scope & F_EXPR) and (($current_scope & F_EXPR_END) or ($ends_expr{$token} and $token_type eq 'KEYWORD' and $prev_token ne ',' and $prev_token ne '=>'))) { @keywords = (); _debug('END EXPR') if DEBUG; $current_scope &= MASK_EXPR_END; } $prepend = undef; if (DEBUG) { my $token_str = ref $token ? Data::Dump::dump($token) : $token; _debug("GOT: $token_str ($pos) TYPE: $token_desc ($token_type)".($prev_token_type ? " PREV: $prev_token_type" : '').(@keywords ? " KEYWORD: @keywords" : '').(($current_scope | $parent_scope) & F_EVAL ? ' EVAL' : '').(($current_scope | $parent_scope) & F_KEEP_TOKENS ? ' KEEP' : '')); } if ($parent_scope & F_KEEP_TOKENS) { push @scope_tokens, [$token, $token_desc]; if ($token eq '-' or $token eq '+') { $prepend = $token; } } if (!($current_scope & F_KEEP_TOKENS) and (exists $c->{callback}{$token} or exists $c->{keyword}{$token} or exists $c->{sub}{$token}) and $token_type ne 'METHOD' and !$c->token_expects_word($prev_token)) { $current_scope |= F_KEEP_TOKENS; } if ($c->token_expects_block($token)) { $waiting_for_a_block = 1; } if ($current_scope & F_EVAL or ($parent_scope & F_EVAL and (!@{$c->{stack}} or $c->{stack}[-1][0] ne '{'))) { if ($token_type eq 'STRING') { if ($token->[0] =~ /\b(?:(?:use|no)\s+[A-Za-z]|require\s+(?:q[qw]?.|['"])?[A-Za-z])/) { my $eval_string = $token->[0]; if (defined $eval_string and $eval_string ne '') { $eval_string =~ s/\\(.)/$1/g; pos($eval_string) = 0; $c->{eval} = 1; my $saved_stack = $c->{stack}; $c->{stack} = []; eval { $self->_scan($c, \$eval_string, ( ($current_scope | $parent_scope | F_STRING_EVAL) & F_RESCAN ))}; $c->{stack} = $saved_stack; } } $current_scope &= MASK_EVAL; } elsif ($token_desc eq 'HEREDOC') { if ($token->[0] =~ /\b(?:use|require|no)\s+[A-Za-z]/) { my $eval_string = $token->[0]; if (defined $eval_string and $eval_string ne '') { $eval_string =~ s/\\(.)/$1/g; pos($eval_string) = 0; $c->{eval} = 1; my $saved_stack = $c->{stack}; $c->{stack} = []; eval { $self->_scan($c, \$eval_string, ( ($current_scope | $parent_scope | F_STRING_EVAL) & F_RESCAN ))}; $c->{stack} = $saved_stack; } } $current_scope &= MASK_EVAL; } elsif ($token_type eq 'VARIABLE') { $current_scope &= MASK_EVAL; } $c->{eval} = ($current_scope | $parent_scope) & F_EVAL ? 1 : 0; } if ($token eq 'eval') { $current_scope |= F_EVAL; $c->{eval} = 1; } if ($current_scope & F_KEEP_TOKENS) { push @tokens, [$token, $token_desc]; if ($token eq '-' or $token eq '+') { $prepend = $token; } if ($token_type eq 'KEYWORD' and $has_sideff{$token}) { $current_scope |= F_SIDEFF; } } if ($stack) { push @{$c->{stack}}, $stack; _dump_stack($c, $stack->[0]) if DEBUG; my $child_scope = $current_scope | $parent_scope; if ($token eq '{' and $is_conditional{$stack->[2]}) { $child_scope |= F_CONDITIONAL } my $scanned_tokens = $self->_scan($c, $rstr, ( $child_scope & F_RESCAN )); if ($token eq '{' and $current_scope & F_EVAL) { $current_scope &= MASK_EVAL; $c->{eval} = ($current_scope | $parent_scope) & F_EVAL ? 1 : 0; } if ($current_scope & F_KEEP_TOKENS) { my $start = pop @tokens || ''; my $end = pop @$scanned_tokens || ''; push @tokens, [$scanned_tokens, "$start->[0]$end->[0]"]; } elsif ($parent_scope & F_KEEP_TOKENS) { my $start = pop @scope_tokens || ''; my $end = pop @$scanned_tokens || ''; push @scope_tokens, [$scanned_tokens, "$start->[0]$end->[0]"]; } if ($stack->[0] eq '(' and $prev_token_type eq 'KEYWORD' and @keywords and $keywords[-1] eq $prev_token and !$c->token_expects_expr_block($prev_token)) { pop @keywords; } if ($stack->[0] eq '{' and @keywords and $c->token_expects_block($keywords[0]) and !$c->token_expects_block_list($keywords[-1])) { $current_scope |= F_STATEMENT_END unless @tokens and ($c->token_defines_sub($keywords[-1]) or $keywords[-1] eq 'eval'); } $stack = undef; } if ($current_scope & F_STATEMENT_END) { if (($current_scope & F_KEEP_TOKENS) and @tokens) { my $first_token = $tokens[0][0]; if ($first_token eq '->') { $first_token = $tokens[1][0]; # ignore ->use and ->no # ->require may be from UNIVERSAL::require if ($first_token eq 'use' or $first_token eq 'no') { $first_token = ''; } } my $cond = (($current_scope | $parent_scope) & (F_CONDITIONAL|F_SIDEFF)) ? 1 : 0; if (exists $c->{callback}{$first_token}) { $c->{current_scope} = \$current_scope; $c->{cond} = $cond; $c->{callback}{$first_token}->($c, $rstr, \@tokens); if ($c->{found_unsupported_package} and !$c->{quick}) { my $unsupported = $c->{found_unsupported_package}; $c->{quick} = 1; $self->_skim_string($c, $rstr); warn "Unsupported package '$unsupported' is found. Result may be incorrect.\n"; } } if (exists $c->{keyword}{$first_token}) { $c->{current_scope} = \$current_scope; $c->{cond} = $cond; $tokens[0][1] = 'KEYWORD'; $c->run_callback_for(keyword => $first_token, \@tokens); } if (exists $c->{method}{$first_token} and $caller_package) { unshift @tokens, [$caller_package, 'WORD']; $c->{current_scope} = \$current_scope; $c->{cond} = $cond; $c->run_callback_for(method => $first_token, \@tokens); } if ($current_scope & F_SIDEFF) { $current_scope &= MASK_SIDEFF; while(my $token = shift @tokens) { last if $has_sideff{$token->[0]}; } $current_scope &= F_SIDEFF if grep {$has_sideff{$_->[0]}} @tokens; if (@tokens) { $first_token = $tokens[0][0]; $cond = (($current_scope | $parent_scope) & (F_CONDITIONAL|F_SIDEFF)) ? 1 : 0; if (exists $c->{callback}{$first_token}) { $c->{current_scope} = \$current_scope; $c->{cond} = $cond; $c->{callback}{$first_token}->($c, $rstr, \@tokens); } if (exists $c->{keyword}{$first_token}) { $c->{current_scope} = \$current_scope; $c->{cond} = $cond; $tokens[0][1] = 'KEYWORD'; $c->run_callback_for(keyword => $first_token, \@tokens); } if (exists $c->{method}{$first_token} and $caller_package) { unshift @tokens, [$caller_package, 'WORD']; $c->{current_scope} = \$current_scope; $c->{cond} = $cond; $c->run_callback_for(method => $first_token, \@tokens); } } } } @tokens = (); @keywords = (); $current_scope &= MASK_STATEMENT_END; $caller_package = undef; $token = $token_type = ''; _debug('END SENTENSE') if DEBUG; } if ($unstack and @{$c->{stack}}) { my $stacked = pop @{$c->{stack}}; my $stacked_type = substr($stacked->[0], -1); if ( ($unstack eq '}' and $stacked_type ne '{') or ($unstack eq ']' and $stacked_type ne '[') or ($unstack eq ')' and $stacked_type ne '(') ) { my $prev_pos = $stacked->[1] || 0; die "mismatch $stacked_type $unstack\n" . substr($$rstr, $prev_pos, pos($$rstr) - $prev_pos); } _dump_stack($c, $unstack) if DEBUG; $current_scope |= F_SCOPE_END; $unstack = undef; } last if $current_scope & F_SCOPE_END; last if $c->{ended}; last if $c->{last_found_by_skimming} and $c->{last_found_by_skimming} < pos($$rstr); ($prev_token, $prev_token_type) = ($token, $token_type); } if (@{$c->{errors}} and !($parent_scope & F_STRING_EVAL)) { my $rest = substr($$rstr, pos($$rstr)); _error("REST:\n\n".$rest) if $rest; last; } } if (@tokens) { if (my $first_token = $tokens[0][0]) { if (exists $c->{callback}{$first_token}) { $c->{callback}{$first_token}->($c, $rstr, \@tokens); } if (exists $c->{keyword}{$first_token}) { $tokens[0][1] = 'KEYWORD'; $c->run_callback_for(keyword => $first_token, \@tokens); } } } _dump_stack($c, "END SCOPE") if DEBUG; \@scope_tokens; } sub _match_quotelike { my ($self, $c, $rstr, $op) = @_; # '#' only works when it comes just after the op, # without prepending spaces $$rstr =~ m/\G(?:\s(?:$re_comment))?\s*/gcs; unless ($$rstr =~ m/\G(\S)/gc) { return _match_error($rstr, "No block delimiter found after $op"); } my $ldel = $1; my $startpos = pos($$rstr); if ($ldel =~ /[[(<{]/) { my ($rdel, $re_skip) = _gen_rdel_and_re_skip($ldel); my @nest = ($ldel); my ($p, $c1); while(defined($p = pos($$rstr))) { $c1 = substr($$rstr, $p, 1); if ($c1 eq '\\') { pos($$rstr) = $p + 2; next; } if ($c1 eq $ldel) { pos($$rstr) = $p + 1; push @nest, $ldel; next; } if ($c1 eq $rdel) { pos($$rstr) = $p + 1; pop @nest; last unless @nest; next; } $$rstr =~ m{\G$re_skip}gc and next; last; } return if @nest; } else { my $re = _gen_re_str_in_delims_with_end_delim($ldel); $$rstr =~ /\G$re/gcs or return; } my $endpos = pos($$rstr); return [substr($$rstr, $startpos, $endpos - $startpos - 1), $op]; } sub _match_regexp0 { # // my ($self, $c, $rstr, $startpos, $token_type) = @_; pos($$rstr) = $startpos + 1; my $re_shortcut = _gen_re_regexp_shortcut('/'); $$rstr =~ m{\G$re_shortcut}gcs or # shortcut defined($self->_scan_re($c, $rstr, '/', '/', $token_type ? 'm' : '')) or return _match_error($rstr, "Closing delimiter was not found: $@"); $$rstr =~ m/\G([msixpodualgc]*)/gc; my $mod = $1; my $endpos = pos($$rstr); my $re = substr($$rstr, $startpos, $endpos - $startpos); if ($re =~ /\n/s and $mod !~ /x/) { return _match_error($rstr, "multiline without x"); } return $re; } sub _match_regexp { my ($self, $c, $rstr) = @_; my $startpos = pos($$rstr) || 0; # '#' only works when it comes just after the op, # without prepending spaces $$rstr =~ m/\G(?:\s(?:$re_comment))?\s*/gcs; unless ($$rstr =~ m/\G(\S)/gc) { return _match_error($rstr, "No block delimiter found"); } my ($ldel, $rdel) = ($1, $1); if ($ldel =~ /[[(<{]/) { $rdel =~ tr/[({/; } my $re_shortcut = _gen_re_regexp_shortcut($ldel, $rdel); $$rstr =~ m{\G$re_shortcut}gcs or # shortcut defined($self->_scan_re($c, $rstr, $ldel, $rdel, 'm/qr')) or return _match_error($rstr, "Closing delimiter was not found: $@"); # strictly speaking, qr// doesn't support gc. $$rstr =~ m/\G[msixpodualgc]*/gc; my $endpos = pos($$rstr); return substr($$rstr, $startpos, $endpos - $startpos); } sub _match_substitute { my ($self, $c, $rstr) = @_; my $startpos = pos($$rstr) || 0; # '#' only works when it comes just after the op, # without prepending spaces $$rstr =~ m/\G(?:\s(?:$re_comment))?\s*/gcs; unless ($$rstr =~ m/\G(\S)/gc) { return _match_error($rstr, "No block delimiter found"); } my ($ldel1, $rdel1) = ($1, $1); if ($ldel1 =~ /[[(<{]/) { $rdel1 =~ tr/[({/; } my $re_shortcut = _gen_re_regexp_shortcut($ldel1, $rdel1); ($ldel1 ne '\\' and $$rstr =~ m{\G$re_shortcut}gcs) or # shortcut defined($self->_scan_re($c, $rstr, $ldel1, $rdel1, 's')) or return _match_error($rstr, "Closing delimiter was not found: $@"); defined($self->_scan_re2($c, $rstr, $ldel1, 's')) or return; $$rstr =~ m/\G[msixpodualgcer]*/gc; my $endpos = pos($$rstr); return substr($$rstr, $startpos, $endpos - $startpos); } sub _match_transliterate { my ($self, $c, $rstr) = @_; my $startpos = pos($$rstr) || 0; # '#' only works when it comes just after the op, # without prepending spaces $$rstr =~ m/\G(?:\s(?:$re_comment))?\s*/gcs; unless ($$rstr =~ m/\G(\S)/gc) { return _match_error($rstr, "No block delimiter found"); } my $ldel1 = $1; my $ldel2; if ($ldel1 =~ /[[(<{]/) { (my $rdel1 = $ldel1) =~ tr/[({/; my $re = _gen_re_str_in_delims_with_end_delim($rdel1); $$rstr =~ /\G$re/gcs or return; $$rstr =~ /\G(?:$re_comment)/gcs; unless ($$rstr =~ /\G\s*(\S)/gc) { return _match_error($rstr, "Missing second block"); } $ldel2 = $1; } else { my $re = _gen_re_str_in_delims_with_end_delim($ldel1); $$rstr =~ /\G$re/gcs or return; $ldel2 = $ldel1; } if ($ldel2 =~ /[[(<{]/) { (my $rdel2 = $ldel2) =~ tr/[({/; my $re = _gen_re_str_in_delims_with_end_delim($rdel2); $$rstr =~ /\G$re/gcs or return; } else { my $re = _gen_re_str_in_delims_with_end_delim($ldel2); $$rstr =~ /\G$re/gcs or return; } $$rstr =~ m/\G[cdsr]*/gc; my $endpos = pos($$rstr); return substr($$rstr, $startpos, $endpos - $startpos); } sub _match_heredoc { my ($self, $c, $rstr) = @_; my $startpos = pos($$rstr) || 0; $$rstr =~ m{\G(?:<<(~)?\s*)}gc; my $indent = $1 ? "\\s*" : ""; my $label; if ($$rstr =~ m{\G\\?([A-Za-z_]\w*)}gc) { $label = $1; } elsif ($$rstr =~ m{ \G ' ($re_str_in_single_quotes) ' | \G " ($re_str_in_double_quotes) " | \G ` ($re_str_in_backticks) ` }gcsx) { $label = $+; } else { return; } $label =~ s/\\(.)/$1/g; my $extrapos = pos($$rstr); $$rstr =~ m{\G.*\n}gc; my $str1pos = pos($$rstr)--; unless ($$rstr =~ m{\G.*?\n$indent(?=\Q$label\E\n)}gcs) { return _match_error($rstr, qq{Missing here doc terminator ('$label')}); } my $ldpos = pos($$rstr); $$rstr =~ m{\G\Q$label\E\n}gc; my $ld2pos = pos($$rstr); my $heredoc = [ substr($$rstr, $str1pos, $ldpos-$str1pos), substr($$rstr, $startpos, $extrapos-$startpos), substr($$rstr, $ldpos, $ld2pos-$ldpos), ]; substr($$rstr, $str1pos, $ld2pos - $str1pos) = ''; pos($$rstr) = $extrapos; if ($indent) { $c->add_perl('5.026', '<<~'); } return $heredoc; } sub _scan_re { my ($self, $c, $rstr, $ldel, $rdel, $op) = @_; my $startpos = pos($$rstr) || 0; _debug(" L $ldel R $rdel") if DEBUG_RE; my ($outer_opening_delimiter, $outer_closing_delimiter); if (@{$c->{stack}}) { ($outer_closing_delimiter = $outer_opening_delimiter = $c->{stack}[-1][0]) =~ tr/[({/; } my @nesting = ($ldel); my $multiline = 0; my $saw_sharp = 0; my $prev; my ($p, $c1); while (defined($p = pos($$rstr))) { $c1 = substr($$rstr, $p, 1); if ($c1 eq "\n") { $$rstr =~ m{\G\n\s*}gcs; $multiline = 1; $saw_sharp = 0; # _debug("CRLF") if DEBUG_RE; next; } if ($c1 eq ' ' or $c1 eq "\t") { $$rstr =~ m{\G\s*}gc; # _debug("WHITESPACE") if DEBUG_RE; next; } if ($c1 eq '#' and $rdel ne '#') { if ($multiline and $$rstr =~ m{\G(#[^\Q$rdel\E]*?)\n}gcs) { _debug(" comment $1") if DEBUG_RE } else { pos($$rstr) = $p + 1; $saw_sharp = 1; _debug(" saw #") if DEBUG_RE; } next; } if ($c1 eq '\\' and $rdel ne '\\') { if ($$rstr =~ m/\G(\\.)/gcs) { _debug(" escaped $1") if DEBUG_RE; next; } } _debug(" looking @nesting: $c1") if DEBUG_RE; if ($c1 eq '[') { # character class may have other (ignorable) delimiters if ($$rstr =~ m/\G(\[\[:\w+?:\]\])/gcs) { _debug(" character class $1") if DEBUG_RE; next; } if ($$rstr =~ m/\G(\[[^\\\]]]*?(\\.[^\\\]]]*)*\])/gcs) { _debug(" character class: $1") if DEBUG_RE; next; } } if ($c1 eq $rdel) { pos($$rstr) = $p + 1; if ($saw_sharp) { my $tmp_pos = $p + 1; if ($op eq 's') { _debug(" looking for latter part") if DEBUG_RE; my $latter = $self->_scan_re2($c, $rstr, $ldel, $op); if (!defined $latter) { pos($$rstr) = $tmp_pos; next; } _debug(" latter: $latter") if DEBUG_RE; } if ($$rstr =~ m/\G[a-wyz]*x/) { # looks like an end of block _debug(" end of block $rdel (after #)") if DEBUG_RE; @nesting = (); pos($$rstr) = $tmp_pos; last; } pos($$rstr) = $tmp_pos; if ($multiline) { next; # part of a comment } } _debug(" end of block $rdel") if DEBUG_RE; my $expected = $rdel; if ($ldel ne $rdel) { $expected =~ tr/)}]>/({[_scan($c, $rstr, F_EXPECTS_BRACKET); 1 }) { _debug("scan failed") if DEBUG_RE; return; } next; } # comment if ($$rstr =~ m{\G(\(\?\#[^\\\)]*(?:\\.[^\\\)]*)*\))}gcs) { _debug(" comment $1") if DEBUG_RE; next; } } # grouping may have (ignorable) <> if ($$rstr =~ m/\G((\()(?:<[!=]|<\w+?>|>)?)/gc) { _debug(" group $1") if DEBUG_RE; push @nesting, $2; next; } } # maybe variables (maybe not) if ($c1 eq '$' and substr($$rstr, $p + 1, 1) eq '{') { my @tmp_stack = @{$c->{stack}}; next if eval { $self->_scan($c, $rstr, F_EXPECTS_BRACKET); 1 }; pos($$rstr) = $p; $c->{stack} = \@tmp_stack; } if ($c1 eq ')') { if (@nesting and $nesting[-1] eq '(') { _debug(" end of group $c1") if DEBUG_RE; pop @nesting; pos($$rstr) = $p + 1; next; } else { # die "unnested @nesting" unless $saw_sharp; } } # for //, see if an outer closing delimiter is found first (ie. see if it was actually a /) if (!$op) { if ($outer_opening_delimiter and $c1 eq $outer_opening_delimiter) { push @nesting, $c1; pos($$rstr) = $p + 1; next; } if ($outer_closing_delimiter and $c1 eq $outer_closing_delimiter) { if (@nesting and $nesting[-1] eq $outer_opening_delimiter) { pop @nesting; pos($$rstr) = $p + 1; next; } return _match_error($rstr, "Outer closing delimiter: $outer_closing_delimiter is found"); } } if ($$rstr =~ m/\G(\w+|.)/gcs) { _debug(" rest $1") if DEBUG_RE; next; } last; } if ($#nesting>=0) { return _match_error($rstr, "Unmatched opening bracket(s): ". join("..",@nesting).".."); } my $endpos = pos($$rstr); return substr($$rstr, $startpos, $endpos - $startpos); } sub _scan_re2 { my ($self, $c, $rstr, $ldel, $op) = @_; my $startpos = pos($$rstr); if ($ldel =~ /[[(<{]/) { $$rstr =~ /\G(?:$re_comment)/gcs; unless ($$rstr =~ /\G\s*(\S)/gc) { return _match_error($rstr, "Missing second block for quotelike $op"); } $ldel = $1; } if ($ldel =~ /[[(<{]/) { my ($rdel, $re_skip) = _gen_rdel_and_re_skip($ldel); my @nest = $ldel; my ($p, $c1); while(defined($p = pos($$rstr))) { $c1 = substr($$rstr, $p, 1); if ($c1 eq '\\') { pos($$rstr) = $p + 2; next; } if ($c1 eq $ldel) { pos($$rstr) = $p + 1; push @nest, $ldel; next; } if ($c1 eq $rdel) { pos($$rstr) = $p + 1; pop @nest; last unless @nest; next; } $$rstr =~ m{\G$re_skip}gc and next; last; } return _match_error($rstr, "nesting mismatch: @nest") if @nest; } else { my $re = _gen_re_str_in_delims_with_end_delim($ldel); $$rstr =~ /\G$re/gcs or return; } my $endpos = pos($$rstr); return substr($$rstr, $startpos, $endpos - $startpos); } sub _use { my ($c, $rstr, $tokens) = @_; _debug("USE TOKENS: ".(Data::Dump::dump($tokens))) if DEBUG; shift @$tokens; # discard 'use' itself # TODO: see if the token is WORD or not? my $name_token = shift @$tokens or return; my $name = $name_token->[0]; return if !defined $name or ref $name or $name eq ''; my $c1 = substr($name, 0, 1); if ($c1 eq '5') { $c->add(perl => $name); return; } if ($c1 eq 'v') { my $c2 = substr($name, 1, 1); if ($c2 eq '5') { $c->add(perl => $name); return; } if ($c2 eq '6') { $c->{perl6} = 1; $c->{ended} = 1; return; } } if ($c->enables_utf8($name)) { $c->add($name => 0); $c->{utf8} = 1; if (!$c->{decoded}) { $c->{decoded} = 1; _debug("UTF8 IS ON") if DEBUG; utf8::decode($$rstr); pos($$rstr) = 0; $c->{ended} = $c->{redo} = 1; } } if (is_module_name($name)) { my $maybe_version_token = $tokens->[0]; my $maybe_version_token_desc = $maybe_version_token->[1]; if ($maybe_version_token_desc and ($maybe_version_token_desc eq 'NUMBER' or $maybe_version_token_desc eq 'VERSION_STRING')) { $c->add($name => $maybe_version_token->[0]); shift @$tokens; } else { $c->add($name => 0); } if (exists $sub_keywords{$name}) { $c->register_sub_keywords(@{$sub_keywords{$name}}); $c->prototype_re(qr{\G(\((?:[^\\\(\)]*(?:\\.[^\\\(\)]*)*)\))}); } if (exists $filter_modules{$name}) { my $tmp = pos($$rstr); my $redo = $filter_modules{$name}->($rstr); pos($$rstr) = $tmp; $c->{ended} = $c->{redo} = 1 if $redo; } } if ($c->has_callback_for(use => $name)) { eval { $c->run_callback_for(use => $name, $tokens) }; warn "Callback Error: $@" if $@; } elsif ($name =~ /\b(?:Mo[ou]se?X?|MooX?|Elk|Antlers|Role)\b/) { my $module = $name =~ /Role/ ? 'Moose::Role' : 'Moose'; if ($c->has_callback_for(use => $module)) { eval { $c->run_callback_for(use => $module, $tokens) }; warn "Callback Error: $@" if $@; } } if (exists $unsupported_packages{$name}) { $c->{found_unsupported_package} = $name; } } sub _require { my ($c, $rstr, $tokens) = @_; _debug("REQUIRE TOKENS: ".(Data::Dump::dump($tokens))) if DEBUG; shift @$tokens; # discard 'require' itself # TODO: see if the token is WORD or not? my $name_token = shift @$tokens or return; my $name = $name_token->[0]; if (ref $name) { $name = $name->[0]; return if $name =~ /\.pl$/i; $name =~ s|/|::|g; $name =~ s|\.pm$||i; } return if !defined $name or $name eq ''; my $c1 = substr($name, 0, 1); if ($c1 eq '5') { $c->add_conditional(perl => $name); return; } if ($c1 eq 'v') { my $c2 = substr($name, 1, 1); if ($c2 eq '5') { $c->add_conditional(perl => $name); return; } if ($c2 eq '6') { $c->{perl6} = 1; $c->{ended} = 1; return; } } if (is_module_name($name)) { $c->add_conditional($name => 0); return; } } sub _no { my ($c, $rstr, $tokens) = @_; _debug("NO TOKENS: ".(Data::Dump::dump($tokens))) if DEBUG; shift @$tokens; # discard 'no' itself # TODO: see if the token is WORD or not? my $name_token = shift @$tokens or return; my $name = $name_token->[0]; return if !defined $name or ref $name or $name eq ''; my $c1 = substr($name, 0, 1); if ($c1 eq '5') { $c->add_no(perl => $name); return; } if ($c1 eq 'v') { my $c2 = substr($name, 1, 1); if ($c2 eq '5') { $c->add_no(perl => $name); return; } if ($c2 eq '6') { $c->{perl6} = 1; $c->{ended} = 1; return; } } if ($name eq 'utf8') { $c->{utf8} = 0; } if (is_module_name($name)) { my $maybe_version_token = $tokens->[0]; my $maybe_version_token_desc = $maybe_version_token->[1]; if ($maybe_version_token_desc and ($maybe_version_token_desc eq 'NUMBER' or $maybe_version_token_desc eq 'VERSION_STRING')) { $c->add_no($name => $maybe_version_token->[0]); shift @$tokens; } else { $c->add_no($name => 0); } } if ($c->has_callback_for(no => $name)) { eval { $c->run_callback_for(no => $name, $tokens) }; warn "Callback Error: $@" if $@; return; } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite - a tool to scan your Perl code for its prerequisites =head1 SYNOPSIS use Perl::PrereqScanner::NotQuiteLite; my $scanner = Perl::PrereqScanner::NotQuiteLite->new( parsers => [qw/:installed -UniversalVersion/], suggests => 1, perl_minimum_version => 1, ); my $context = $scanner->scan_file('path/to/file'); my $requirements = $context->requires; my $recommends = $context->recommends; my $suggestions = $context->suggests; # requirements in evals my $noes = $context->noes; =head1 DESCRIPTION Perl::PrereqScanner::NotQuiteLite is yet another prerequisites scanner. It passes almost all the scanning tests for L and L (ie. except for a few dubious ones), and runs slightly faster than PPI-based Perl::PrereqScanner. However, it doesn't run as fast as L (which uses an XS lexer). Perl::PrereqScanner::NotQuiteLite also recognizes C. Prerequisites in C are not considered as requirements, but you can collect them as suggestions. Conditional requirements or requirements loaded in a block are treated as recommends. Noed modules are stored separately (since 0.94). You may or may not need to merge them into requires. Perl::PrereqScanner::NotQuiteLite can also recognize some of the new language features such as C, subroutine signatures, and postfix dereferences, to improve the minimum perl requirement (since 0.9905). =head1 METHODS =head2 new creates a scanner object. Options are: =over 4 =item parsers By default, Perl::PrereqScanner::NotQuiteLite only recognizes modules loaded directly by C, C, C statements, plus modules loaded by a few common modules such as C, C, C (that are in the Perl core), and by two keywords exported by L family (C and C). If you need more, you can pass extra parser names to the scanner, or C<:bundled>, which loads and registers all the parsers bundled with this distribution. If you have your own parsers, you can specify C<:installed> to load and register all the installed parsers. You can also pass a project-specific parser (that lies outside the C namespace) by prepending C<+> to the name. use Perl::PrereqScanner::NotQuiteLite; my $scanner = Perl::PrereqScanner::NotQuiteLite->new( parsers => [qw/+PrereqParser::For::MyProject/], ); If you don't want to load a specific parser for some reason, prepend C<-> to the parser name. =item suggests Perl::PrereqScanner::NotQuiteLite ignores C-like statements in C by default. If you set this option to true, Perl::PrereqScanner::NotQuiteLite also parses statements in C, and records requirements as suggestions. =item recommends Perl::PrereqScanner::NotQuiteLite usually ignores C-like statements in a block by default. If you set this option to true, Perl::PrereqScanner::NotQuiteLite also records requirements in a block as recommendations. =item perl_minimum_version If you set this option to true, Perl::PrereqScanner::NotQuiteLite adds a specific version of perl as a requirement when it finds some of the new perl language features. =back =head2 scan_file takes a path to a file and returns a ::Context object. =head2 scan_string takes a string, scans and returns a ::Context object. =head1 SEE ALSO L, L, L L to scan a whole distribution. L is a command line interface of the above. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/0000755000175100017510000000000014422514733026636 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/0000755000175100017510000000000014422514733030072 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/KeywordDeclare.pm0000644000175100017510000000321014001101046033306 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::KeywordDeclare; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'Keyword::Declare' => 'parse_keyword_declare_args', }, }} sub parse_keyword_declare_args { my ($class, $c, $used_module, $raw_tokens) = @_; $c->register_sub_keywords(qw/keyword/); $c->register_keywords(qw/keytype is unkeyword/); $c->register_op_keywords(qw/is/); $c->register_sub_parser( 'keyword', [$class, 'parse_keyword_args', $used_module], ); $c->register_keyword_parser( 'unkeyword', [$class, 'parse_unkeyword_args', $used_module], ); } sub parse_keyword_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard keyword if (ref $tokens->[0] and $tokens->[0][1]) { $c->register_keywords($tokens->[0][1]); } } sub parse_unkeyword_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard unkeyword if (ref $tokens->[0] and $tokens->[0][1]) { $c->remove_keywords($tokens->[0][0]); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::KeywordDeclare =head1 DESCRIPTION This parser is to deal with keywords imported from L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2018 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/MooseXDeclare.pm0000644000175100017510000001113314001101046033077 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::MooseXDeclare; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'MooseX::Declare' => 'parse_moosex_declare_args', }, }} sub parse_moosex_declare_args { my ($class, $c, $used_module, $raw_tokens) = @_; $c->register_sub_parser( 'class', [$class, 'parse_class_args', $used_module], ); $c->register_sub_parser( 'role', [$class, 'parse_role_args', $used_module], ); $c->register_keyword_parser( 'extends', [$class, 'parse_extends_args', $used_module], ); $c->register_keyword_parser( 'with', [$class, 'parse_with_args', $used_module], ); $c->register_keyword_parser( 'namespace', [$class, 'parse_namespace_args', $used_module], ); $c->register_sub_keywords(qw/ class method role before after around override augment /); $c->prototype_re(qr{\G(\((?:[^\\\(\)]*(?:\\.[^\\\(\)]*)*)\))}); } sub parse_class_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $namespace = $c->stash->{moosex_declare}{namespace} || ''; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard class my $class_name = (shift @$tokens || [])->[0] or return; if ($class_name eq '::') { my $name = (shift @$tokens || [])->[0]; $class_name = $namespace . '::' . $name; } my $prev = ''; while(my $token = shift @$tokens) { if ($token->[0] eq 'extends' or $token->[0] eq 'with') { while(1) { my $name = (shift @$tokens || [])->[0]; if ($name eq '::') { $name = $namespace . '::' . (shift @$tokens || [])->[0]; } $c->add($name => 0) if is_module_name($name); last if !@$tokens; my $next_token = $tokens->[0]; last if $next_token->[0] ne ','; shift @$tokens; } } } } sub parse_role_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $namespace = $c->stash->{moosex_declare}{namespace} || ''; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard role my $class_name = (shift @$tokens)->[0]; if ($class_name eq '::') { my $name = (shift @$tokens)->[0]; $class_name = $namespace . '::' . $name; } my $prev = ''; while(my $token = shift @$tokens) { if ($token->[0] eq 'with') { while(1) { my $name = (shift @$tokens)->[0]; if ($name eq '::') { $name = $namespace . '::' . (shift @$tokens)->[0]; } $c->add($name => 0) if is_module_name($name); last if !@$tokens; my $next_token = $tokens->[0]; last if $next_token->[0] ne ','; shift @$tokens; } } } } sub parse_namespace_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard namespace my $first_token = (shift @$tokens)->[0]; if (is_module_name($first_token)) { $c->stash->{moosex_declare}{namespace} = $first_token; } } sub parse_extends_args { shift->_parse_loader_args(@_) } sub parse_with_args { shift->_parse_loader_args(@_) } sub _parse_loader_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $namespace = $c->stash->{moosex_declare}{namespace} || ''; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard extends, with; my $prev; while(my $token = shift @$tokens) { if (!ref $token) { if ($token =~ /^::/) { $token = $namespace . $token; } $c->add($token => 0); $prev = $token; next; } my $desc = $token->[1] || ''; if ($desc eq '{}') { my @hash_tokens = @{$token->[0] || []}; for(my $i = 0, my $len = @hash_tokens; $i < $len; $i++) { if ($hash_tokens[$i][0] eq '-version' and $i < $len - 2) { my $maybe_version_token = $hash_tokens[$i + 2]; my $maybe_version = $maybe_version_token->[0]; if (ref $maybe_version) { $maybe_version = $maybe_version->[0]; } if ($prev and is_version($maybe_version)) { $c->add($prev => $maybe_version); } } } } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::MooseXDeclare =head1 DESCRIPTION This parser is to deal with modules loaded by C and/or C from L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/MojoBase.pm0000644000175100017510000000254414001101046032112 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::MojoBase; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; my @MojoBaseLike = qw/ Mojo::Base Mojo::Weixin::Base Mojo::Webqq::Base Kelp::Base Rethinkdb::Base PMLTQ::Base /; sub register { my ($class, %args) = @_; my %mojo_base_like = map {$_ => 1} (@MojoBaseLike, @{$args{mojo_base_like} || []}); my %mapping; for my $module (keys %mojo_base_like) { $mapping{use}{$module} = 'parse_mojo_base_args'; } return \%mapping; } sub parse_mojo_base_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } my $module = $tokens->[0]; if (ref $module) { $module = $module->[0]; } if (is_module_name($module)) { $module =~ s|'|::|g; $c->add($module => 0); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::MojoBase =head1 DESCRIPTION This parser is to deal with module inheritance by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Plack.pm0000644000175100017510000000357214001101046031447 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Plack; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'Plack::Builder' => 'parse_plack_builder_args', }, }} sub parse_plack_builder_args { my ($class, $c, $used_module, $raw_tokens) = @_; # TODO: support add_middleware(_if) methods? $c->register_keyword_parser( 'enable', [$class, 'parse_enable_args', $used_module], ); $c->register_keyword_parser( 'enable_if', [$class, 'parse_enable_if_args', $used_module], ); } sub parse_enable_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard 'enable' itself my $module = shift @$tokens or return; if ($module =~ s/^\+//) { $c->add($module => 0); } else { $module =~ s/^Plack::Middleware:://; $c->add("Plack::Middleware::".$module => 0); } } sub parse_enable_if_args { my ($class, $c, $used_module, $raw_tokens) = @_; while(my $token = shift @$raw_tokens) { last if $token->[1] eq 'COMMA' or ref $token->[0]; } shift @$raw_tokens if $raw_tokens->[0][1] eq 'COMMA'; my $tokens = convert_string_tokens($raw_tokens); my $module = shift @$tokens or return; if ($module =~ s/^\+//) { $c->add($module => 0); } else { $module =~ s/^Plack::Middleware:://; $c->add("Plack::Middleware::".$module => 0); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Plack =head1 DESCRIPTION This parser is to deal with Plack middlewares loaded by L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Superclass.pm0000644000175100017510000000261714001101046032540 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Superclass; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { superclass => 'parse_superclass_args', }, }} sub parse_superclass_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } my ($module, $version, $prev); for my $token (@$tokens) { last if $token eq '-norequire'; if (ref $token) { last if $token->[0] eq '-norequire'; $prev = $token->[0]; next; } $prev = $token; if (is_module_name($token)) { if ($module) { $c->add($module => $version || 0); } $module = $token; next; } if (is_version($token)) { $c->add($module => $token); } } if ($module) { $c->add($module => 0); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Superclass =head1 DESCRIPTION This parser is to deal with module inheritance managed by L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/ClassLoad.pm0000644000175100017510000000716714001101046032266 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::ClassLoad; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; my %known_functions = map {$_ => 1} qw/ load_class try_load_class load_optional_class load_first_existing_class /; sub register { return { use => { 'Class::Load' => 'parse_class_load_args', }, }} sub register_fqfn { return { map { "Class::Load::".$_ => "parse_".$_."_args" } keys %known_functions }} sub parse_class_load_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } for my $token (@$tokens) { next if ref $token; if ($known_functions{$token}) { $c->register_keyword_parser( $token, [$class, 'parse_'.$token.'_args', $used_module], ); } elsif ($token eq ':all') { for my $func (keys %known_functions) { $c->register_keyword_parser( $func, [$class, 'parse_'.$func.'_args', $used_module], ); } } } } sub parse_load_class_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # function my ($module, undef, $options) = @$tokens; my $version = 0; if (ref $options and $options->[1] eq '{}') { my $tokens_in_hashref = convert_string_tokens($options->[0]); while(my ($key, undef, $value, undef) = splice @$tokens_in_hashref, 0, 4) { if (ref $key and $key->[0] eq '-version' and is_version($value)) { $version = $value; } } } $c->add_conditional($module => $version); } sub parse_try_load_class_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # function my ($module, undef, $options) = @$tokens; my $version = 0; if (ref $options and $options->[1] eq '{}') { my $tokens_in_hashref = convert_string_tokens($options->[0]); while(my ($key, undef, $value, undef) = splice @$tokens_in_hashref, 0, 4) { if (ref $key and $key->[0] eq '-version' and is_version($value)) { $version = $value; } } } $c->add_suggestion($module => $version); } sub parse_load_optional_class_args { my ($class, $c, $used_module, $raw_tokens) = @_; $class->parse_try_load_class_args($c, $used_module, $raw_tokens); } sub parse_load_first_existing_class_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # function my ($module, $version); for my $token (@$tokens) { if (is_module_name($token)) { if ($module) { $c->add_suggestion($module => $version); } $module = $token; $version = 0; next; } if (ref $token and ($token->[1] || '') eq '{}') { my $tokens_in_hashref = convert_string_tokens($token->[0]); while(my ($key, undef, $value, undef) = splice @$tokens_in_hashref, 0, 4) { if (ref $key and $key->[0] eq '-version' and is_version($value)) { $version = $value; } } } } if ($module) { $c->add_suggestion($module => $version); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::ClassLoad =head1 DESCRIPTION This parser is to deal with module loading by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Aliased.pm0000644000175100017510000000207514001101046031754 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Aliased; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { aliased => 'parse_aliased_args', }, }} sub parse_aliased_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } my $module = $tokens->[0]; if (ref $module) { $module = $module->[0]; } if (is_module_name($module)) { $c->add($module => 0); } # TODO: support alias keyword? } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Aliased =head1 DESCRIPTION This parser is to deal with a module loaded (aliased) by L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Autouse.pm0000644000175100017510000000204514001101046032034 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Autouse; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'autouse' => 'parse_autouse_args', }, }} sub parse_autouse_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } my $module = $tokens->[0]; if (ref $module) { $module = $module->[0]; } if (is_module_name($module)) { $c->add_recommendation($module => 0); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Autouse =head1 DESCRIPTION This parser is to deal with lazy module loading by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/TestMore.pm0000644000175100017510000000326314001101046032154 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::TestMore; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'Test::More' => 'parse_test_more_args', }, }} sub register_fqfn { return +{ 'Test::More::done_testing' => 'parse_done_testing_args', 'Test::More::plan' => 'parse_plan_args', }} sub parse_test_more_args { my ($class, $c, $used_module, $raw_tokens) = @_; $c->register_keyword_parser( 'done_testing', [$class, 'parse_done_testing_args', $used_module], ); $c->register_keyword_parser( 'plan', [$class, 'parse_plan_args', $used_module], ); } sub parse_done_testing_args { my ($class, $c, $used_module, $raw_tokens) = @_; $c->add($used_module => '0.88'); } sub parse_plan_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard plan my $first_token = $tokens->[0] or return; $first_token = $first_token->[0] if ref $first_token; if ($first_token eq 'skip_all') { if (grep {$_->[0] eq '{' and $_->[2] eq 'BEGIN'} @{$c->{stack} || []}) { $c->{force_cond} = 1; } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::TestMore =head1 DESCRIPTION This parser is to update the minimum version requirement of L to 0.88 if C is found by the scanner. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/SyntaxCollector.pm0000644000175100017510000000400714001101046033544 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::SyntaxCollector; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'Syntax::Collector' => 'parse_syntax_collector_args', }, }} sub parse_syntax_collector_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_token_list($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } my $spec; if (!(@$tokens % 2)) { while(my ($key, $value) = splice @$tokens, 0, 2) { my $keystr = ref $key ? $key->[0] : $key; if ($keystr eq '-collect') { $spec = $value; last; } } } else { $spec = $tokens->[0]; } if (ref $spec) { $spec = $spec->[0]; } return unless $spec; my @features = map { m{^ (use|no) \s+ # "use" or "no" (\S+) \s+ # module name ([\d\._v]+) # module version (?: # everything else \s* (.+) )? # ... perhaps [;] \s* # semicolon $}x ? [$1, $2, $3, [ defined($4) ? eval "($4)" : ()] ] : die("Line q{$_} doesn't conform to 'use MODULE VERSION [ARGS];'") } grep { ! m/^#/ } # not a comment grep { m/[A-Z0-9]/i } # at least one alphanum map { s/(^\s+)|(\s+$)//; $_ } # trim map { split /(\r?\n|\r)/ } # split lines $spec; for my $feature (@features) { $c->add($feature->[1], $feature->[2]); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::SyntaxCollector =head1 DESCRIPTION This parser is to deal with modules loading by L module. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Mixin.pm0000644000175100017510000000165014001101046031474 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Mixin; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { mixin => 'parse_mixin_args', }, }} sub parse_mixin_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } $c->add($_ => 0) for grep {!ref $_} @$tokens; } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Mixin =head1 DESCRIPTION This parser is to deal with module loading by C module. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Prefork.pm0000644000175100017510000000201614001101046032015 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Prefork; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { prefork => 'parse_prefork_args', }, }} sub parse_prefork_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } my $module = $tokens->[0]; if (ref $module) { $module = $module->[0]; } if (is_module_name($module)) { $c->add($module => 0); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Prefork =head1 DESCRIPTION This parser is to deal with module loaded by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut ././@LongLink0000644000000000000000000000014600000000000011604 Lustar rootrootPerl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/UniversalVersion.pmPerl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/UniversalVersion.p0000644000175100017510000000262114001101046033550 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::UniversalVersion; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { method => { VERSION => 'parse_version_args', }, }} sub parse_version_args { my ($class, $c, $raw_tokens) = @_; my ($module_token, undef, undef, $args_tokens) = @$raw_tokens; my $module = $module_token->[0]; return unless ref $args_tokens->[0]; my @tokens_in_parens = @{$args_tokens->[0] || []}; return if @tokens_in_parens > 1; my $version_token = $tokens_in_parens[0]; my $module_version; if ($version_token->[1] and $version_token->[1] eq 'NUMBER') { $module_version = $version_token->[0]; } elsif (ref $version_token->[0]) { $module_version = $version_token->[0][0]; } else { return; } if ($module_version =~ /^v?[0-9._]+$/) { $c->add_conditional($module => $module_version) if $c->has_added_conditional($module); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::UniversalVersion =head1 DESCRIPTION This parser is to deal with a VERSION method called by a module. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/ClassAccessor.pm0000644000175100017510000000435514001101046033145 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::ClassAccessor; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register {{ use => { 'Class::Accessor' => 'parse_class_accessor_args', 'Class::Accessor::Fast' => 'parse_class_accessor_args', 'Class::Accessor::Faster' => 'parse_class_accessor_args', 'Class::XSAccessor::Compat' => 'parse_class_accessor_args', } }} sub parse_class_accessor_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } while(my $token = shift @$tokens) { if ($token =~ /^(?:antlers|moose-?like)$/i) { $c->register_keyword_parser( 'extends', [$class, 'parse_extends_args', $used_module], ); last; } } } sub parse_extends_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard extends, with; my $prev; for my $token (@$tokens) { if (!ref $token) { $c->add($token => 0); $prev = $token; next; } my $desc = $token->[1] || ''; if ($desc eq '{}') { my @hash_tokens = @{$token->[0] || []}; for(my $i = 0, my $len = @hash_tokens; $i < $len; $i++) { if ($hash_tokens[$i][0] eq '-version' and $i < $len - 2) { my $maybe_version_token = $hash_tokens[$i + 2]; my $maybe_version = $maybe_version_token->[0]; if (ref $maybe_version) { $maybe_version = $maybe_version->[0]; } if ($prev and is_version($maybe_version)) { $c->add($prev => $maybe_version); } } } } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::ClassAccessor =head1 DESCRIPTION This parser is to deal with modules loaded by C from L and its friends. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/POE.pm0000644000175100017510000000165714001101046031042 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::POE; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { POE => 'parse_poe_args', }, }} sub parse_poe_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } $c->add($_ eq "POE" ? $_ : "POE::".$_ => 0) for grep {!ref $_} @$tokens; } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::POE =head1 DESCRIPTION This parser is to deal with modules loaded by L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/PackageVariant.pm0000644000175100017510000000475014001101046033274 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::PackageVariant; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register {{ use => { 'Package::Variant' => 'parse_package_variant_args', }, }} sub parse_package_variant_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); while(my $token = shift @$tokens) { if (ref $token and $token->[0] eq 'importing') { shift @$tokens if @$tokens && $tokens->[0][1] eq 'COMMA'; my $next_token = shift @$tokens or last; if (!ref $next_token) { my $module = $next_token; if (is_module_name($module)) { $c->add($module); if ($c->has_callback_for(use => $module)) { $c->run_callback_for('use', $module, [["use", "KEYWORD"], [$module, "WORD"], [";", ";"]]); } } } elsif ($next_token->[1] eq '[]') { my $modules = convert_string_token_list($next_token->[0]); while(my $module = shift @$modules) { next unless is_module_name($module); $c->add($module); if ($c->has_callback_for(use => $module)) { $c->run_callback_for('use', $module, [["use", "KEYWORD"], [$module, "WORD"], [";", ";"]]); } } } elsif ($next_token->[1] eq '{}') { my $hash_tokens = convert_string_token_list($next_token->[0]); while(my $module = shift @$hash_tokens) { my $arg = shift @$hash_tokens; my @args = $arg->[1] eq '[]' ? @{$arg->[0]} : $arg; $c->add($module); if ($c->has_callback_for(use => $module)) { $c->run_callback_for('use', $module, [["use", "KEYWORD"], [$module, "WORD"], @args, [";", ";"]]); } } } } elsif (ref $token && !ref $token->[0] && $token->[1] eq 'WORD') { shift @$tokens if @$tokens && $tokens->[0][1] eq 'COMMA'; shift @$tokens if @$tokens; } shift @$tokens if @$tokens && ref $tokens->[0] && $tokens->[0][1] eq 'COMMA'; } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::PackageVariant =head1 DESCRIPTION This parser is to deal with modules loaded by L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2018 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/ObjectPad.pm0000644000175100017510000000565414422514456032277 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::ObjectPad; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'Object::Pad' => 'parse_object_pad_args', }, }} sub parse_object_pad_args { my ($class, $c, $used_module, $raw_tokens) = @_; $c->register_sub_parser( 'class', [$class, 'parse_class_args', $used_module], ); $c->register_sub_parser( 'role', [$class, 'parse_role_args', $used_module], ); $c->register_keyword_parser( 'class', [$class, 'parse_class_args', $used_module], ); $c->register_keyword_parser( 'role', [$class, 'parse_role_args', $used_module], ); $c->register_sub_keywords(qw/ class method role /); $c->prototype_re(qr{\G(\((?:[^\\\(\)]*(?:\\.[^\\\(\)]*)*)\))}); } sub parse_class_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard class my $isa = my $does = 0; while(my $token = shift @$tokens) { my ($name, $version) = ('', 0); if (ref $token && $token->[1] && $token->[1] eq 'WORD') { if ($token->[0] eq 'isa' or $token->[0] eq 'extends') { $isa = 1; $does = 0; next; } if ($token->[0] eq 'does' or $token->[0] eq 'implements') { $isa = 0; $does = 1; next; } if (is_module_name($token->[0])) { $name = $token->[0]; if (@$tokens && is_version($tokens->[0])) { $version = shift @$tokens; } if ($isa or $does) { $c->add($name => $version); } else { $c->add_package($name => $version); } } } if (ref $token && $token->[1] && $token->[1] eq 'ATTRIBUTE') { while($token->[0] =~ s/:(?:isa|does)\(([^)]+)\)//) { my ($name, $version) = split /\s+/, $1; $version ||= 0; if (is_module_name($name) && is_version($version)) { $c->add($name => $version); } } } } } sub parse_role_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard role while(my $token = shift @$tokens) { my ($name, $version) = ('', 0); if (is_module_name($token->[0])) { $name = $token->[0]; if (@$tokens && is_version($tokens->[0])) { $version = shift @$tokens; } $c->add_package($name => $version); } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::ObjectPad =head1 DESCRIPTION This parser is to deal with modules loaded by C and/or C from L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2021 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Core.pm0000644000175100017510000001164014001101046031300 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Core; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; my %feature_since = ( say => '5.010', state => '5.010', switch => '5.010', unicode_strings => '5.012', current_sub => '5.016', evalbytes => '5.016', fc => '5.016', arybase => '5.016', unicode_eval => '5.016', lexical_subs => '5.018', postderef => '5.020', postderef_qq => '5.020', signatures => '5.020', bitwise => '5.022', refaliasing => '5.022', declared_refs => '5.026', ); sub register { return { use => { if => 'parse_if_args', base => 'parse_base_args', parent => 'parse_parent_args', feature => 'parse_feature_args', }, keyword => { package => 'parse_package', exit => 'parse_begin_exit', }, }} sub parse_if_args { my ($class, $c, $used_module, $raw_tokens) = @_; while(my $token = shift @$raw_tokens) { last if $token->[1] eq 'COMMA'; } my $tokens = convert_string_tokens($raw_tokens); my $module = shift @$tokens; if (ref $module and ($module->[1] eq 'WORD' or $module->[1] eq 'KEYWORD')) { $module = $module->[0]; } if (is_module_name($module)) { if (is_version($tokens->[0])) { my $version = shift @$tokens; $c->add_recommendation($module => $version); } else { $c->add_recommendation($module => 0); } } else { push @{$c->{errors}}, "use if module not found"; } } sub parse_base_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } while(my $token = shift @$tokens) { my $module = $token; if (ref $module and ($module->[1] || '') eq 'WORD') { # allow bareword, but disallow function() $module = $module->[0]; next if @$tokens and ref $tokens->[0] and ($tokens->[0][1] || '') eq '()'; } # bareword in parentheses if (ref $module and ref $module->[0]) { $module = $module->[0][0]; } if (is_module_name($module)) { $c->add($module => 0); } } } sub parse_parent_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } while(my $token = shift @$tokens) { last if $token eq '-norequire'; my $module = $token; if (ref $token) { last if $token->[0] eq '-norequire'; } if (ref $module and ($module->[1] || '') eq 'WORD') { # allow bareword, but disallow function() $module = $module->[0]; next if @$tokens and ref $tokens->[0] and ($tokens->[0][1] || '') eq '()'; } # bareword in parentheses if (ref $module and ref $module->[0]) { $module = $module->[0][0]; } $c->add($module => 0) if is_module_name($module); } } sub parse_feature_args { my ($class, $c, $used_module, $raw_tokens) = @_; $c->add_perl('5.010', 'feature'); my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } while(my $token = shift @$tokens) { next if ref $token; if (exists $feature_since{$token}) { $c->add_perl($feature_since{$token} => "feature $token"); next; } if ($token =~ /^:5\.([0-9]+)(\.\[0-9]+)?/) { my $version = sprintf '5.%03d', $1; $c->add_perl($version, $token); next; } } } sub parse_begin_exit { my ($class, $c, $raw_tokens) = @_; my @stack = @{$c->{stack} || []}; if (grep {$_->[0] eq '{' and $_->[2] eq 'BEGIN'} @stack) { if (grep {$c->token_is_conditional($_->[0])} @$raw_tokens) { $c->{force_cond} = 1; } elsif (grep {$_->[0] eq '{' and $c->token_is_conditional($_->[2])} @stack) { $c->{force_cond} = 1; } else { $c->{ended} = 1; @{$c->{stack}} = (); } } } sub parse_package { my ($class, $c, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # drop "package" my $token = shift @$tokens; if (ref $token && $token->[1] && $token->[1] eq 'WORD') { $c->add_package($token->[0]); } if (@$tokens) { $token = shift @$tokens; if (is_version($token)) { $c->add_perl("5.012", "package PACKAGE VERSION"); $token = shift @$tokens; } if (ref $token && $token->[1] && $token->[1] =~ /^\{/) { $c->add_perl("5.014", "package PACKAGE (VERSION) {}"); } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Core =head1 DESCRIPTION This parser is to deal with module inheritance by C and C modules, and conditional loading by C module. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/AnyMoose.pm0000644000175100017510000000650314001101046032144 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::AnyMoose; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register {{ use => { 'Any::Moose' => 'parse_any_moose_args', }, no => { 'Any::Moose' => 'remove_extends_and_with', }, }} sub parse_any_moose_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } while(my $token = shift @$tokens) { next if ref $token; # As Any::Moose falls back to Mouse, it's nice to have # a Mouse variant, but that should not be required. my $module = "Mouse$token"; $c->add_recommendation($module => 0) if is_module_name($module); } $c->register_keyword_parser( 'extends', [$class, 'parse_extends_args', $used_module], ); $c->register_keyword_parser( 'with', [$class, 'parse_with_args', $used_module], ); } sub remove_extends_and_with { my ($class, $c, $used_module, $raw_tokens) = @_; $c->remove_keyword('extends'); $c->remove_keyword('with'); } sub parse_extends_args { shift->_parse_loader_args(@_) } sub parse_with_args { shift->_parse_loader_args(@_) } sub _parse_loader_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard extends, with; my $prev; my $saw_any_moose; while(my $token = shift @$tokens) { if (!ref $token) { if ($saw_any_moose) { my $module = "Mouse$token"; $c->add_recommendation($module => 0); $prev = $module; } else { $c->add($token => 0); $prev = $token; } next; } if ($token->[0] eq 'any_moose') { $saw_any_moose = 1; next; } my $desc = $token->[1] || ''; if ($desc eq '{}') { my @hash_tokens = @{$token->[0] || []}; for(my $i = 0, my $len = @hash_tokens; $i < $len; $i++) { if ($hash_tokens[$i][0] eq '-version' and $i < $len - 2) { my $maybe_version_token = $hash_tokens[$i + 2]; my $maybe_version = $maybe_version_token->[0]; if (ref $maybe_version) { $maybe_version = $maybe_version->[0]; } if ($prev and is_version($maybe_version)) { if ($saw_any_moose) { $c->add_recommendation($prev => $maybe_version); } else { $c->add($prev => $maybe_version); } } } } } if ($saw_any_moose and $desc eq '()') { my $tokens_in_parentheses = convert_string_tokens($token->[0]); for my $token_in_parentheses (@$tokens_in_parentheses) { next if ref $token_in_parentheses; my $module = "Mouse$token_in_parentheses"; $c->add_recommendation($module => 0) if is_module_name($module); } } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::AnyMoose =head1 DESCRIPTION This parser is to deal with modules loaded by C from L and its friends. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Inline.pm0000644000175100017510000000234414001101046031627 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Inline; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { Inline => 'parse_inline_args', }, }} sub parse_inline_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } if (ref $tokens->[0] and is_module_name($tokens->[0][0])) { my $module = (shift @$tokens)->[0]; if ($module eq 'with') { $module = $tokens->[1]; if (is_module_name($module)) { $c->add($module => 0); } } elsif ($module eq 'Config') { # Configuration only } else { $c->add("Inline::".$module => 0); } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Inline =head1 DESCRIPTION This parser is to deal with a module loaded by L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Later.pm0000644000175100017510000000203114001101046031451 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Later; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'later' => 'parse_later_args', }, }} sub parse_later_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } my $module = $tokens->[0]; if (ref $module) { $module = $module->[0]; } if (is_module_name($module)) { $c->add_recommendation($module => 0); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Later =head1 DESCRIPTION This parser is to deal with lazy module loading by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Syntax.pm0000644000175100017510000000274714001101046031706 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Syntax; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; my %Unsupported = map {$_ => 1} qw( ); sub register { return { use => { syntax => 'parse_syntax_args', }, }} sub parse_syntax_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } return if ref $tokens->[0]; my $feature_name = $tokens->[0]; my $name = join '::', map ucfirst, split m{/}, join '', map ucfirst, split qr{_}, $feature_name; my $feature_module = "Syntax::Feature::$name"; if (is_module_name($feature_module)) { $c->add($feature_module => 0); } if ($feature_name =~ /^q[sil]$/) { $c->register_quotelike_keywords($feature_name, 'q'.$feature_name); } # Some of the features change syntax too much if ($Unsupported{$feature_name}) { $c->{aborted} = "syntax '$feature_name'"; $c->{ended} = 1; } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Syntax =head1 DESCRIPTION This parser is to deal with L features. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Only.pm0000644000175100017510000000237714001101046031340 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Only; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { only => 'parse_only_args', }, }} sub parse_only_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } while(my $token = shift @$tokens) { my $module = $token; if (ref $module) { $module = $module->[0]; } next unless is_module_name($module); my $version = shift @$tokens; $version = shift @$tokens if ref $version; if (is_version($version)) { $c->add($module => $version); } else { $c->add($module => 0); # Can't determine a version } last; } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Only =head1 DESCRIPTION This parser is to deal with a module loaded by L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Unless.pm0000644000175100017510000000246414001101046031665 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Unless; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { unless => 'parse_unless_args', }, }} sub parse_unless_args { my ($class, $c, $used_module, $raw_tokens) = @_; while(my $token = shift @$raw_tokens) { last if $token->[1] eq 'COMMA'; } my $tokens = convert_string_tokens($raw_tokens); my $module = shift @$tokens; if (ref $module and ($module->[1] eq 'WORD' or $module->[1] eq 'KEYWORD')) { $module = $module->[0]; } if (is_module_name($module)) { if (is_version($tokens->[0])) { my $version = shift @$tokens; $c->add_recommendation($module => $version); } else { $c->add_recommendation($module => 0); } } else { push @{$c->{errors}}, "use unless module not found"; } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Unless =head1 DESCRIPTION This parser is to deal with conditional loading by C module. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/TestRequires.pm0000644000175100017510000000346514001101046033055 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::TestRequires; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'Test::Requires' => 'parse_test_requires_args', }, }} sub parse_test_requires_args { my ($class, $c, $used_module, $raw_tokens) = @_; $c->register_keyword_parser( 'test_requires', [$class, 'parse_test_requires_function_args', $used_module], ); my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } if (ref $tokens->[0] and $tokens->[0][1] and $tokens->[0][1] eq '{}') { my $tokens_in_hashref = convert_string_tokens($tokens->[0][0]); while(my ($key, undef, $value, undef) = splice @$tokens_in_hashref, 0, 4) { next unless is_module_name($key); next unless is_version($value); $c->add_recommendation($key => $value); } } else { for my $token (@$tokens) { next if ref $token; if ($token =~ /^v?5/) { $c->add_recommendation(perl => $token); } else { $c->add_recommendation($token => 0); } } } } sub parse_test_requires_function_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); $c->add_recommendation($_ => 0) for grep {!ref $_} @$tokens; } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::TestRequires =head1 DESCRIPTION This parser is to deal with conditional loading by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Moose.pm0000644000175100017510000001225614001101046031476 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Moose; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; # There are so many Moose-like variants # Like Moose; modules that are not listed here but have Moose # in their name are implicitly treated like these as well my @ExportsExtendsAndWith = qw/ Moose Moo Mouse MooX Moo::Lax Moos MooseX::App MooseX::Singleton MooseX::SingletonMethod HTML::FormHandler::Moose Test::Class::Moose App::GHPT::Wrapper::OurMoose App::wmiirc::Plugin Ark Bot::Backbone::Service Bubblegum::Class CatalystX::Declare Cogwheel CPAN::Testers::Backend::Base Dancer2::Plugin Data::Object::Class DBICx::Modeler::Model Digital::Driver Elastic::Doc Fey::ORM::Table Form::Factory::Processor Jedi::App Momo Moonshine::Magic Moxie Nile::Base Parse::FixedRecord Pcore Reaction::Class Reaction::UI::WidgetClass Squirrel Statocles::Base TAEB::OO Test::Able Test::Roo Web::Simple XML::Rabbit /; # Like Moose::Role; modules that are not listed here but have Role # in their name are implicitly treated like these as well my @ExportsWith = qw/ Moose::Role Moo::Role Mouse::Role MooseX::Role::Parameterized Mason::PluginRole Mojo::RoleTiny MooX::Cmd Role::Basic Role::Tiny Role::Tiny::With Reflex::Role Template::Caribou Test::Routine App::SimulateReads::Base /; # Like Mo my @ExportsExtends = qw/ Mo Lingy::Base OptArgs2::Mo Parse::SAMGov::Mo Pegex::Base Sub::Mage TestML::Base Type::Utils VSO /; sub register { my ($class, %args) = @_; # Make sure everything is unique my %exports_extends_and_with = map {$_ => 1} (@ExportsExtendsAndWith, @{$args{exports_extends_and_with} || []}); my %exports_extends = map {$_ => 1} (@ExportsExtends, @{$args{exports_extends} || []}); my %exports_with = map {$_ => 1} (@ExportsWith, @{$args{exports_with} || []}); for my $module (keys %exports_with) { if (exists $exports_extends_and_with{$module}) { delete $exports_with{$module}; next; } if (exists $exports_extends{$module}) { $exports_extends_and_with{$module} = 1; delete $exports_with{$module}; next; } } for my $module (keys %exports_extends) { if (exists $exports_extends_and_with{$module}) { delete $exports_extends{$module}; next; } } my %mapping; for my $module (keys %exports_with) { $mapping{use}{$module} = 'register_with'; $mapping{no}{$module} = 'remove_with'; } for my $module (keys %exports_extends) { $mapping{use}{$module} = 'register_extends'; $mapping{no}{$module} = 'remove_extends'; } for my $module (keys %exports_extends_and_with) { $mapping{use}{$module} = 'register_extends_and_with'; $mapping{no}{$module} = 'remove_extends_and_with'; } return \%mapping; } sub register_extends_and_with { my ($class, $c, $used_module, $raw_tokens) = @_; $c->register_keyword_parser( 'extends', [$class, 'parse_extends_args', $used_module], ); $c->register_keyword_parser( 'with', [$class, 'parse_with_args', $used_module], ); } sub register_with { my ($class, $c, $used_module, $raw_tokens) = @_; $c->register_keyword_parser( 'with', [$class, 'parse_with_args', $used_module], ); } sub register_extends { my ($class, $c, $used_module, $raw_tokens) = @_; $c->register_keyword_parser( 'extends', [$class, 'parse_extends_args', $used_module], ); } sub remove_extends_and_with { my ($class, $c, $used_module, $raw_tokens) = @_; $c->remove_keyword('extends'); $c->remove_keyword('with'); } sub remove_with { my ($class, $c, $used_module, $raw_tokens) = @_; $c->remove_keyword('with'); } sub remove_extends { my ($class, $c, $used_module, $raw_tokens) = @_; $c->remove_keyword('extends'); } sub parse_extends_args { shift->_parse_loader_args(@_) } sub parse_with_args { shift->_parse_loader_args(@_) } sub _parse_loader_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # discard extends, with; my $prev; for my $token (@$tokens) { if (!ref $token) { $c->add($token => 0); $prev = $token; next; } my $desc = $token->[1] || ''; if ($desc eq '{}') { my @hash_tokens = @{$token->[0] || []}; for(my $i = 0, my $len = @hash_tokens; $i < $len; $i++) { if ($hash_tokens[$i][0] eq '-version' and $i < $len - 2) { my $maybe_version_token = $hash_tokens[$i + 2]; my $maybe_version = $maybe_version_token->[0]; if (ref $maybe_version) { $maybe_version = $maybe_version->[0]; } if ($prev and is_version($maybe_version)) { $c->add($prev => $maybe_version); } } } } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Moose =head1 DESCRIPTION This parser is to deal with modules loaded by C and/or C from L and its friends. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/ModuleRuntime.pm0000644000175100017510000000434314001101046033203 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::ModuleRuntime; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; my %known_functions = map {$_ => 1} qw/ require_module use_module use_package_optimistically /; sub register { return { use => { 'Module::Runtime' => 'parse_module_runtime_args', }, }} sub register_fqfn { return { map { "Module::Runtime::".$_ => "parse_".$_."_args" } keys %known_functions }} sub parse_module_runtime_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } for my $token (@$tokens) { next if ref $token; if ($known_functions{$token}) { $c->register_keyword_parser( $token, [$class, 'parse_'.$token.'_args', $used_module], ); } } } sub parse_require_module_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # function my $module = shift @$tokens; return unless is_module_name($module); $c->add_conditional($module => 0); } sub parse_use_module_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # function my ($module, undef, $version) = @$tokens; $version = 0 unless $version and is_version($version); $c->add_conditional($module => $version); } sub parse_use_package_optimistically_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); shift @$tokens; # function my ($module, undef, $version) = @$tokens; $version = 0 unless $version and is_version($version); $c->add_conditional($module => $version); } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::ModuleRuntime =head1 DESCRIPTION This parser is to deal with module loading by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/Catalyst.pm0000644000175100017510000000270314001101046032174 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::Catalyst; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { Catalyst => 'parse_catalyst_args', }, }} sub parse_catalyst_args { my ($class, $c, $used_module, $raw_tokens) = @_; my @copied_tokens = @$raw_tokens; if (($copied_tokens[0][1] || '') eq '()') { my $token = shift @copied_tokens; unshift @copied_tokens, @{$token->[0]}; } if (is_version($copied_tokens[0])) { $c->add($used_module => shift @copied_tokens); } my @plugins; for my $token (@copied_tokens) { my $desc = $token->[1] or next; if ($desc eq 'STRING') { push @plugins, $token->[0][0]; } elsif ($desc eq 'QUOTED_WORD_LIST') { push @plugins, split /\s/, $token->[0][0]; } } for my $plugin (@plugins) { next if $plugin =~ /^\-/; $plugin = "Catalyst::Plugin::$plugin" unless $plugin =~ s/^\+//; $c->add($plugin => 0) if is_module_name($plugin); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::Catalyst =head1 DESCRIPTION This parser is to deal with module inheritance by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/ClassAutouse.pm0000644000175100017510000000324114001101046033021 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::ClassAutouse; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'Class::Autouse' => 'parse_class_autouse_args', }, }} sub parse_class_autouse_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } while(my $token = shift @$tokens) { my $module = $token; if (ref $module) { $module = $module->[0]; } if (is_module_name($module)) { $c->add_recommendation($module => 0); } } $c->register_method_parser( 'autouse', [$class, 'parse_autouse_method_args', $used_module], ); } sub parse_autouse_method_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_tokens($raw_tokens); # Check class my ($klass, $arrow, $method, @args) = @$tokens; return unless $klass and ref $klass and $klass->[0] eq $used_module; return unless $method and ref $method and $method->[0] eq 'autouse'; for my $arg (@args) { next if ref $arg; $c->add_recommendation($arg => 0); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::ClassAutouse =head1 DESCRIPTION This parser is to deal with modules loaded dynamically by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Parser/TestClassMost.pm0000644000175100017510000000243414001101046033161 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Parser::TestClassMost; use strict; use warnings; use Perl::PrereqScanner::NotQuiteLite::Util; sub register { return { use => { 'Test::Class::Most' => 'parse_test_class_most_args', }, }} sub parse_test_class_most_args { my ($class, $c, $used_module, $raw_tokens) = @_; my $tokens = convert_string_token_list($raw_tokens); if (is_version($tokens->[0])) { $c->add($used_module => shift @$tokens); } while(my ($key, $value) = splice @$tokens, 0, 2) { my $keystr = ref $key ? $key->[0] : $key; if ($keystr eq 'parent') { if (!ref $value) { $c->add($value => 0); } elsif ($value->[1] eq '[]') { my $tokens_inside = convert_string_token_list($value->[0]); $c->add($_ => 0) for @$tokens_inside; } } } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Parser::TestClassMost =head1 DESCRIPTION This parser is to deal with conditional loading by C. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Util.pm0000644000175100017510000000711514001101046030073 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Util; use strict; use warnings; use Exporter 5.57 qw/import/; our %FLAGS; BEGIN { my $i = 0; %FLAGS = map {$_ => 1 << $i++} qw/ F_KEEP_TOKENS F_EVAL F_STRING_EVAL F_EXPECTS_BRACKET F_CONDITIONAL F_SIDEFF F_SCOPE_END F_STATEMENT_END F_EXPR_END F_EXPR /; } use constant \%FLAGS; use constant { MASK_KEEP_TOKENS => ~(F_KEEP_TOKENS), MASK_EXPR_END => ~(F_EXPR_END|F_EXPR), MASK_STATEMENT_END => ~(F_KEEP_TOKENS|F_STATEMENT_END|F_EXPR|F_EXPR_END|F_SIDEFF), MASK_EVAL => ~(F_EVAL), MASK_SIDEFF => ~(F_SIDEFF), F_RESCAN => (F_KEEP_TOKENS|F_EVAL|F_STRING_EVAL|F_CONDITIONAL), }; our @EXPORT = ((keys %FLAGS), qw/ is_module_name is_version convert_string_tokens convert_string_token_list MASK_KEEP_TOKENS MASK_EXPR_END MASK_STATEMENT_END MASK_EVAL MASK_SIDEFF F_RESCAN /); sub is_module_name { my $name = shift or return; return 1 if $name =~ /^[A-Za-z_][A-Za-z0-9_]*(?:(?:::|')[A-Za-z0-9_]+)*$/; return; } sub is_version { my $version = shift; return unless defined $version; return 1 if $version =~ /\A ( [0-9]+(?:\.[0-9]+)? | v[0-9]+(?:\.[0-9]+)* | [0-9]+(?:\.[0-9]+){2,} ) (?:_[0-9]+)? \z/x; return; } sub convert_string_tokens { my $org_tokens = shift; my @tokens; my @copied_tokens = @$org_tokens; my $prev = ''; while(my $copied_token = shift @copied_tokens) { my ($token, $desc) = @$copied_token; if ($desc and $desc eq '()' and $prev ne 'WORD') { unshift @copied_tokens, @$token; next; } if (!$desc) { push @tokens, $copied_token; } elsif ($desc eq 'VERSION_STRING' or $desc eq 'NUMBER') { push @tokens, $token; } elsif ($desc eq 'STRING') { push @tokens, $token->[0]; } elsif ($desc eq 'QUOTED_WORD_LIST') { push @tokens, grep {defined $_ and $_ ne ''} split /\s/, $token->[0]; } else { push @tokens, $copied_token; } $prev = $desc; } \@tokens; } sub convert_string_token_list { my $org_tokens = shift; my @list; my @tokens; my @copied_tokens = @$org_tokens; my $prev = ''; while(my $copied_token = shift @copied_tokens) { my ($token, $desc) = @$copied_token; if ($desc and $desc eq '()' and $prev ne 'WORD') { unshift @copied_tokens, @$token; next; } if (!$desc) { push @tokens, $copied_token; } elsif ($desc eq 'VERSION_STRING' or $desc eq 'NUMBER') { push @tokens, $token; } elsif ($desc eq 'STRING') { push @tokens, $token->[0]; } elsif ($desc eq 'QUOTED_WORD_LIST') { push @list, grep {defined $_ and $_ ne ''} split /\s/, $token->[0]; } elsif ($token eq ',' or $token eq '=>') { push @list, @tokens == 1 ? $tokens[0] : \@tokens; @tokens = (); $prev = ''; } elsif ($desc eq ';') { last; } else { push @tokens, $copied_token; } $prev = $desc; } if (@tokens) { push @list, @tokens == 1 ? $tokens[0] : \@tokens; } \@list; } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Util =head1 DESCRIPTION This provides a few utility functions for internal use. =head1 FUNCTIONS =head2 is_module_name takes a string and returns true if it looks like a module. =head2 is_version takes a string and returns true if it looks like a version. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Util/0000755000175100017510000000000014422514733027553 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Util/Prereqs.pm0000644000175100017510000000432314001101046031512 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Util::Prereqs; use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT = qw/dedupe_prereqs_and_features/; sub dedupe_prereqs_and_features { my ($prereqs, $features) = @_; my @valid_features = grep defined, values %$features; for my $phase ($prereqs->phases) { my $requires = $prereqs->requirements_for($phase, 'requires'); for my $type (qw/recommends suggests/) { my $target = $prereqs->requirements_for($phase, $type); _dedupe($requires, $target); } for my $feature (@valid_features) { for my $type (qw/requires recommends suggests/) { my $target = $feature->requirements_for($phase, $type); _dedupe($requires, $target); } } my $recommends = $prereqs->requirements_for($phase, 'recommends'); for my $type (qw/suggests/) { my $target = $prereqs->requirements_for($phase, $type); _dedupe($recommends, $target); } for my $feature (@valid_features) { for my $type (qw/recommends suggests/) { my $target = $feature->requirements_for($phase, $type); _dedupe($recommends, $target); } } my $suggests = $prereqs->requirements_for($phase, 'suggests'); for my $feature (@valid_features) { for my $type (qw/suggests/) { my $target = $feature->requirements_for($phase, $type); _dedupe($suggests, $target); } } } } sub _dedupe { my ($source, $target) = @_; my @modules = $source->required_modules; for my $module (@modules) { my $version = $target->requirements_for_module($module); next unless defined $version; next unless $version =~ /^[0-9._]+$/; next unless $source->accepts_module($module, $version); $target->clear_requirement($module); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Util::Prereqs =head1 SYNOPSIS =head1 DESCRIPTION This is an internal utility to dedupe prereqs. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Util/CPANfile.pm0000644000175100017510000000754514001101046031463 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Util::CPANfile; use strict; use warnings; use parent 'Module::CPANfile'; use Perl::PrereqScanner::NotQuiteLite::Util::Prereqs; sub load_and_merge { my ($class, $file, $prereqs, $features) = @_; $prereqs = $prereqs->as_string_hash unless ref $prereqs eq 'HASH'; my $self; if (-f $file) { $self = $class->load($file); $self->_merge_prereqs($prereqs); } else { $self = $class->from_prereqs($prereqs); } if ($features) { for my $identifier (keys %$features) { my $feature = $features->{$identifier}; next unless $feature->{prereqs}; $self->_merge_prereqs($feature->{prereqs}, $identifier) or next; $self->{_prereqs}->add_feature($identifier, $feature->{description}); } } $self->_dedupe; $self; } sub features { my $self = shift; map $self->feature($_), sort $self->{_prereqs}->identifiers; # TWEAKED } sub _merge_prereqs { my ($self, $prereqs, $feature_id) = @_; $prereqs = $prereqs->as_string_hash unless ref $prereqs eq 'HASH'; my $current = CPAN::Meta::Prereqs->new($self->{_prereqs}->specs($feature_id)); my $merged = $current->with_merged_prereqs(CPAN::Meta::Prereqs->new($prereqs)); $self->__replace_prereqs($merged, $feature_id); } sub __replace_prereqs { my ($self, $prereqs, $feature_id) = @_; $prereqs = $prereqs->as_string_hash unless ref $prereqs eq 'HASH'; @{$self->{_prereqs}{prereqs}{$feature_id || ''}} = (); my $added = 0; for my $phase (keys %$prereqs) { for my $type (keys %{$prereqs->{$phase}}) { while (my($module, $requirement) = each %{$prereqs->{$phase}{$type}}) { $self->{_prereqs}->add( feature => $feature_id, phase => $phase, type => $type, module => $module, requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement), ); $added++ } } } delete $self->{_prereqs}{cpanmeta} unless $feature_id; # to rebuild cpanmeta $added; } sub _dedupe { my $self = shift; my $prereqs = $self->prereqs; my %features = map {$_ => $self->feature($_)->{prereqs} } $self->{_prereqs}->identifiers; dedupe_prereqs_and_features($prereqs, \%features); $self->__replace_prereqs($prereqs); for my $feature_id (keys %features) { $self->__replace_prereqs($features{$feature_id}, $feature_id); } } sub _dump_prereqs { my($self, $prereqs, $include_empty, $base_indent) = @_; my $code = ''; my @x_phases = sort grep {/^x_/i} keys %$prereqs; # TWEAKED for my $phase (qw(runtime configure build test develop), @x_phases) { my $indent = $phase eq 'runtime' ? '' : ' '; $indent = (' ' x ($base_indent || 0)) . $indent; my($phase_code, $requirements); $phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime'; my @x_types = sort grep {/^x_/i} keys %{$prereqs->{$phase}}; # TWEAKED for my $type (qw(requires recommends suggests conflicts), @x_types) { for my $mod (sort keys %{$prereqs->{$phase}{$type}}) { my $ver = $prereqs->{$phase}{$type}{$mod}; $phase_code .= $ver eq '0' ? "${indent}$type '$mod';\n" : "${indent}$type '$mod', '$ver';\n"; $requirements++; } } $phase_code .= "\n" unless $requirements; $phase_code .= "};\n" unless $phase eq 'runtime'; $code .= $phase_code . "\n" if $requirements or $include_empty; } $code =~ s/\n+$/\n/s; $code; } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Util::CPANfile =head1 SYNOPSIS =head1 DESCRIPTION This is a wrapper of L. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2017 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Context.pm0000644000175100017510000004312714221572253030625 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Context; use strict; use warnings; use CPAN::Meta::Requirements; use Regexp::Trie; use Perl::PrereqScanner::NotQuiteLite::Util; my %defined_keywords = _keywords(); my %default_op_keywords = map {$_ => 1} qw( x eq ne and or xor cmp ge gt le lt not ); my %default_conditional_keywords = map {$_ => 1} qw( if elsif unless else ); my %default_expects_expr_block = map {$_ => 1} qw( if elsif unless given when for foreach while until ); my %default_expects_block_list = map {$_ => 1} qw( map grep sort ); my %default_expects_fh_list = map {$_ => 1} qw( print printf say ); my %default_expects_fh_or_block_list = ( %default_expects_block_list, %default_expects_fh_list, ); my %default_expects_block = map {$_ => 1} qw( else default eval sub do while until continue BEGIN END INIT CHECK if elsif unless given when for foreach while until map grep sort ); my %default_expects_word = map {$_ => 1} qw( use require no sub ); my %enables_utf8 = map {$_ => 1} qw( utf8 Mojo::Base Mojo::Base::Che ); my %new_keyword_since = ( say => '5.010', state => '5.010', given => '5.010', when => '5.010', default => '5.010', ); my $default_g_re_prototype = qr{\G(\([^\)]*?\))}; sub new { my ($class, %args) = @_; my %context = ( requires => CPAN::Meta::Requirements->new, noes => CPAN::Meta::Requirements->new, file => $args{file}, verbose => $args{verbose}, optional => $args{optional}, stash => {}, ); if ($args{suggests} or $args{recommends}) { $context{recommends} = CPAN::Meta::Requirements->new; } if ($args{suggests}) { $context{suggests} = CPAN::Meta::Requirements->new; } if ($args{perl_minimum_version}) { $context{perl} = CPAN::Meta::Requirements->new; } for my $type (qw/use no method keyword sub/) { if (exists $args{_}{$type}) { for my $key (keys %{$args{_}{$type}}) { $context{$type}{$key} = [@{$args{_}{$type}{$key}}]; } } } bless \%context, $class; } sub stash { shift->{stash} } sub register_keyword_parser { my ($self, $keyword, $parser_info) = @_; $self->{keyword}{$keyword} = $parser_info; $self->{defined_keywords}{$keyword} = 0; } sub remove_keyword_parser { my ($self, $keyword) = @_; delete $self->{keyword}{$keyword}; delete $self->{keyword} if !%{$self->{keyword}}; delete $self->{defined_keywords}{$keyword}; } sub register_method_parser { my ($self, $method, $parser_info) = @_; $self->{method}{$method} = $parser_info; } *register_keyword = \®ister_keyword_parser; *remove_keyword = \&remove_keyword_parser; *register_method = \®ister_method_parser; sub register_sub_parser { my ($self, $keyword, $parser_info) = @_; $self->{sub}{$keyword} = $parser_info; $self->{defined_keywords}{$keyword} = 0; } sub requires { shift->{requires} } sub recommends { shift->_optional('recommends') } sub suggests { shift->_optional('suggests') } sub noes { shift->{noes} } sub _optional { my ($self, $key) = @_; my $optional = $self->{$key} or return; # no need to recommend/suggest what are listed as requires if (my $requires = $self->{requires}) { my $hash = $optional->as_string_hash; for my $module (keys %$hash) { if (defined $requires->requirements_for_module($module) and $requires->accepts_module($module, $hash->{$module}) ) { $optional->clear_requirement($module); } } } $optional; } sub add { my $self = shift; if ($self->{optional}) { $self->_add('suggests', @_); } else { $self->_add('requires', @_); } } sub add_recommendation { shift->_add('recommends', @_); } sub add_suggestion { shift->_add('suggests', @_); } sub add_conditional { shift->_add('conditional', @_); } sub add_no { shift->_add('noes', @_); } sub add_perl { my ($self, $perl, $reason) = @_; return unless $self->{perl}; $self->_add('perl', 'perl', $perl); $self->{perl_minimum_version}{$reason} = $perl; } sub _add { my ($self, $type, $module, $version) = @_; return unless is_module_name($module); my $CMR = $self->_object($type) or return; $version = 0 unless defined $version; if ($self->{verbose}) { if (!defined $CMR->requirements_for_module($module)) { print STDERR " found $module $version ($type)\n"; } } $CMR->add_minimum($module, "$version"); } sub has_added { shift->_has_added('requires', @_); } sub has_added_recommendation { shift->_has_added('recommends', @_); } sub has_added_suggestion { shift->_has_added('suggests', @_); } sub has_added_conditional { shift->_has_added('conditional', @_); } sub has_added_no { shift->_has_added('no', @_); } sub _has_added { my ($self, $type, $module) = @_; return unless is_module_name($module); my $CMR = $self->_object($type) or return; defined $CMR->requirements_for_module($module) ? 1 : 0; } sub _object { my ($self, $key) = @_; if ($self->{eval}) { $key = 'suggests'; } elsif ($self->{force_cond}) { $key = 'recommends'; } elsif ($key && $key eq 'conditional') { if ($self->{cond}) { $key = 'recommends'; } elsif (grep {$_->[0] eq '{' and $_->[2] ne 'BEGIN'} @{$self->{stack} || []}) { $key = 'recommends'; } else { $key = 'requires'; } } elsif (!$key) { $key = 'requires'; } $self->{$key} or return; } sub has_callbacks { my ($self, $type) = @_; exists $self->{$type}; } sub has_callback_for { my ($self, $type, $name) = @_; exists $self->{$type}{$name}; } sub run_callback_for { my ($self, $type, $name, @args) = @_; return unless $self->_object; my ($parser, $method, @cb_args) = @{$self->{$type}{$name}}; $parser->$method($self, @cb_args, @args); } sub prototype_re { my $self = shift; if (@_) { $self->{prototype_re} = shift; } return $default_g_re_prototype unless exists $self->{prototype_re}; $self->{prototype_re}; } sub quotelike_re { my $self = shift; return qr/qq?/ unless exists $self->{quotelike_re}; $self->{quotelike_re}; } sub register_quotelike_keywords { my ($self, @keywords) = @_; push @{$self->{quotelike}}, @keywords; $self->{defined_keywords}{$_} = 0 for @keywords; my $trie = Regexp::Trie->new; $trie->add($_) for 'q', 'qq', @{$self->{quotelike} || []}; $self->{quotelike_re} = $trie->regexp; } sub token_expects_block_list { my ($self, $token) = @_; return 1 if exists $default_expects_block_list{$token}; return 0 if !exists $self->{expects_block_list}; return 1 if exists $self->{expects_block_list}{$token}; return 0; } sub token_expects_fh_list { my ($self, $token) = @_; return 1 if exists $default_expects_fh_list{$token}; return 0 if !exists $self->{expects_fh_list}; return 1 if exists $self->{expects_fh_list}{$token}; return 0; } sub token_expects_fh_or_block_list { my ($self, $token) = @_; return 1 if exists $default_expects_fh_or_block_list{$token}; return 0 if !exists $self->{expects_fh_or_block_list}; return 1 if exists $self->{expects_fh_or_block_list}{$token}; return 0; } sub token_expects_expr_block { my ($self, $token) = @_; return 1 if exists $default_expects_expr_block{$token}; return 0 if !exists $self->{expects_expr_block}; return 1 if exists $self->{expects_expr_block}{$token}; return 0; } sub token_expects_block { my ($self, $token) = @_; return 1 if exists $default_expects_block{$token}; return 0 if !exists $self->{expects_block}; return 1 if exists $self->{expects_block}{$token}; return 0; } sub token_expects_word { my ($self, $token) = @_; return 1 if exists $default_expects_word{$token}; return 0 if !exists $self->{expects_word}; return 1 if exists $self->{expects_word}{$token}; return 0; } sub token_is_conditional { my ($self, $token) = @_; return 1 if exists $default_conditional_keywords{$token}; return 0 if !exists $self->{is_conditional_keyword}; return 1 if exists $self->{is_conditional_keyword}{$token}; return 0; } sub token_is_keyword { my ($self, $token) = @_; return 1 if exists $defined_keywords{$token}; return 0 if !exists $self->{defined_keywords}; return 1 if exists $self->{defined_keywords}{$token}; return 0; } sub token_is_op_keyword { my ($self, $token) = @_; return 1 if exists $default_op_keywords{$token}; return 0 if !exists $self->{defined_op_keywords}; return 1 if exists $self->{defined_op_keywords}{$token}; return 0; } sub check_new_keyword { my ($self, $token) = @_; if (exists $new_keyword_since{$token}) { $self->add_perl($new_keyword_since{$token}, $token); } } sub register_keywords { my ($self, @keywords) = @_; for my $keyword (@keywords) { $self->{defined_keywords}{$keyword} = 0; } } sub register_op_keywords { my ($self, @keywords) = @_; for my $keyword (@keywords) { $self->{defined_op_keywords}{$keyword} = 0; } } sub remove_keywords { my ($self, @keywords) = @_; for my $keyword (@keywords) { delete $self->{defined_keywords}{$keyword} if exists $self->{defined_keywords}{$keyword} and !$self->{defined_keywords}{$keyword}; } } sub register_sub_keywords { my ($self, @keywords) = @_; for my $keyword (@keywords) { $self->{defines_sub}{$keyword} = 1; $self->{expects_block}{$keyword} = 1; $self->{expects_word}{$keyword} = 1; $self->{defined_keywords}{$keyword} = 0; } } sub token_defines_sub { my ($self, $token) = @_; return 1 if $token eq 'sub'; return 0 if !exists $self->{defines_sub}; return 1 if exists $self->{defines_sub}{$token}; return 0; } sub enables_utf8 { my ($self, $module) = @_; exists $enables_utf8{$module} ? 1 : 0; } sub add_package { my ($self, $package) = @_; $self->{packages}{$package} = 1; } sub packages { my $self = shift; keys %{$self->{packages} || {}}; } sub remove_inner_packages_from_requirements { my $self = shift; for my $package ($self->packages) { for my $rel (qw/requires recommends suggests noes/) { next unless $self->{$rel}; $self->{$rel}->clear_requirement($package); } } } sub merge_perl { my $self = shift; return unless $self->{perl}; my $perl = $self->{requires}->requirements_for_module('perl'); if ($self->{perl}->accepts_module('perl', $perl)) { delete $self->{perl_minimum_version}; } else { $self->add(perl => $self->{perl}->requirements_for_module('perl')); } } sub _keywords {( '__FILE__' => 1, '__LINE__' => 2, '__PACKAGE__' => 3, '__DATA__' => 4, '__END__' => 5, '__SUB__' => 6, AUTOLOAD => 7, BEGIN => 8, UNITCHECK => 9, DESTROY => 10, END => 11, INIT => 12, CHECK => 13, abs => 14, accept => 15, alarm => 16, and => 17, atan2 => 18, bind => 19, binmode => 20, bless => 21, break => 22, caller => 23, chdir => 24, chmod => 25, chomp => 26, chop => 27, chown => 28, chr => 29, chroot => 30, close => 31, closedir => 32, cmp => 33, connect => 34, continue => 35, cos => 36, crypt => 37, dbmclose => 38, dbmopen => 39, default => 40, defined => 41, delete => 42, die => 43, do => 44, dump => 45, each => 46, else => 47, elsif => 48, endgrent => 49, endhostent => 50, endnetent => 51, endprotoent => 52, endpwent => 53, endservent => 54, eof => 55, eq => 56, eval => 57, evalbytes => 58, exec => 59, exists => 60, exit => 61, exp => 62, fc => 63, fcntl => 64, fileno => 65, flock => 66, for => 67, foreach => 68, fork => 69, format => 70, formline => 71, ge => 72, getc => 73, getgrent => 74, getgrgid => 75, getgrnam => 76, gethostbyaddr => 77, gethostbyname => 78, gethostent => 79, getlogin => 80, getnetbyaddr => 81, getnetbyname => 82, getnetent => 83, getpeername => 84, getpgrp => 85, getppid => 86, getpriority => 87, getprotobyname => 88, getprotobynumber => 89, getprotoent => 90, getpwent => 91, getpwnam => 92, getpwuid => 93, getservbyname => 94, getservbyport => 95, getservent => 96, getsockname => 97, getsockopt => 98, given => 99, glob => 100, gmtime => 101, goto => 102, grep => 103, gt => 104, hex => 105, if => 106, index => 107, int => 108, ioctl => 109, join => 110, keys => 111, kill => 112, last => 113, lc => 114, lcfirst => 115, le => 116, length => 117, link => 118, listen => 119, local => 120, localtime => 121, lock => 122, log => 123, lstat => 124, lt => 125, m => 126, map => 127, mkdir => 128, msgctl => 129, msgget => 130, msgrcv => 131, msgsnd => 132, my => 133, ne => 134, next => 135, no => 136, not => 137, oct => 138, open => 139, opendir => 140, or => 141, ord => 142, our => 143, pack => 144, package => 145, pipe => 146, pop => 147, pos => 148, print => 149, printf => 150, prototype => 151, push => 152, q => 153, qq => 154, qr => 155, quotemeta => 156, qw => 157, qx => 158, rand => 159, read => 160, readdir => 161, readline => 162, readlink => 163, readpipe => 164, recv => 165, redo => 166, ref => 167, rename => 168, require => 169, reset => 170, return => 171, reverse => 172, rewinddir => 173, rindex => 174, rmdir => 175, s => 176, say => 177, scalar => 178, seek => 179, seekdir => 180, select => 181, semctl => 182, semget => 183, semop => 184, send => 185, setgrent => 186, sethostent => 187, setnetent => 188, setpgrp => 189, setpriority => 190, setprotoent => 191, setpwent => 192, setservent => 193, setsockopt => 194, shift => 195, shmctl => 196, shmget => 197, shmread => 198, shmwrite => 199, shutdown => 200, sin => 201, sleep => 202, socket => 203, socketpair => 204, sort => 205, splice => 206, split => 207, sprintf => 208, sqrt => 209, srand => 210, stat => 211, state => 212, study => 213, sub => 214, substr => 215, symlink => 216, syscall => 217, sysopen => 218, sysread => 219, sysseek => 220, system => 221, syswrite => 222, tell => 223, telldir => 224, tie => 225, tied => 226, time => 227, times => 228, tr => 229, truncate => 230, uc => 231, ucfirst => 232, umask => 233, undef => 234, unless => 235, unlink => 236, unpack => 237, unshift => 238, untie => 239, until => 240, use => 241, utime => 242, values => 243, vec => 244, wait => 245, waitpid => 246, wantarray => 247, warn => 248, when => 249, while => 250, write => 251, x => 252, xor => 253, y => 254 || 255, )} 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Context =head1 DESCRIPTION This is typically used to keep callbacks, an eval state, and found prerequisites for a processing file. =head1 METHODS =head2 add $c->add($module); $c->add($module => $minimum_version); adds a module with/without a minimum version as a requirement or a suggestion, depending on the eval state. You can add a module with different versions as many times as you wish. The actual minimum version for the module is calculated inside (by L). =head2 register_keyword_parser, remove_keyword_parser, register_method_parser, register_sub_parser $c->register_keyword_parser( 'func_name', [$parser_class, 'parser_for_the_func', $used_module], ); $c->remove_keyword_parser('func_name'); $c->register_method_parser( 'method_name', [$parser_class, 'parser_for_the_method', $used_module], ); If you find a module that can export a loader function is actually Cd (such as L that can export an C function that will load a module internally), you might also register the loader function as a custom keyword dynamically so that the scanner can also run a callback for the function to parse its argument tokens. You can also remove the keyword when you find the module is Ced (and when the module supports C). You can also register a method callback on the fly (but you can't remove it). If you always want to check some functions/methods when you load a plugin, just register them using a C method in the plugin. =head2 requires returns a CPAN::Meta::Requirements object for requirements. =head2 suggests returns a CPAN::Meta::Requirements object for suggestions (requirements in Cs), or undef when it is not expected to parse tokens in C. =head1 METHODS MOSTLY FOR INTERNAL USE =head2 new creates an instance. You usually don't need to call this because it's automatically created in the scanner. =head2 has_callbacks, has_callback_for, run_callback_for next unless $c->has_callbacks('use'); next unless $c->has_callbacks_for('use', 'base'); $c->run_callbacks_for('use', 'base', $tokens); C returns true if a callback for C, C, C, or C is registered. C returns true if a callback for the module/keyword/method is registered. C is to run the callback. =head2 has_added returns true if a module has already been added as a requirement or a suggestion. Only useful for the ::UniversalVersion plugin. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/App.pm0000644000175100017510000005200714223750611027714 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::App; use strict; use warnings; use File::Find; use File::Glob 'bsd_glob'; use File::Basename; use File::Spec; use CPAN::Meta::Prereqs; use CPAN::Meta::Requirements; use Perl::PrereqScanner::NotQuiteLite; use Perl::PrereqScanner::NotQuiteLite::Util::Prereqs; use Parse::Distname; use constant WIN32 => $^O eq 'MSWin32'; my %IsTestClassFamily = map {$_ => 1} qw( Test::Class Test::Class::Moose Test::Class::Most Test::Class::Sugar Test::Classy ); sub new { my ($class, %opts) = @_; for my $key (keys %opts) { next unless $key =~ /\-/; (my $replaced_key = $key) =~ s/\-/_/g; $opts{$replaced_key} = $opts{$key}; } $opts{prereqs} = CPAN::Meta::Prereqs->new; $opts{parsers} = [':bundled'] unless defined $opts{parsers}; $opts{recommends} = 0 unless defined $opts{recommends}; $opts{suggests} = 0 unless defined $opts{suggests}; $opts{base_dir} ||= File::Spec->curdir; $opts{cpanfile} = 1 if $opts{save_cpanfile}; if ($opts{features} and ref $opts{features} ne 'HASH') { my @features; if (!ref $opts{features}) { @features = split ';', $opts{features}; } elsif (ref $opts{features} eq 'ARRAY') { @features = @{$opts{features}}; } my %map; for my $spec (@features) { my ($identifier, $description, $paths) = split ':', $spec; my @paths = map { bsd_glob(File::Spec->catdir($opts{base_dir}, $_)) } split ',', $paths; if (WIN32) { s|\\|/|g for @paths; } $map{$identifier} = { description => $description, paths => \@paths, }; } $opts{features} = \%map; } if ($opts{ignore} and ref $opts{ignore} eq 'ARRAY') { require Regexp::Trie; my $re = Regexp::Trie->new; for (@{$opts{ignore}}) { s|\\|/|g if WIN32; $re->add($_); } $opts{ignore_re} ||= $re->_regexp; } if ($opts{private} and ref $opts{private} eq 'ARRAY') { require Regexp::Trie; my $re = Regexp::Trie->new; for (@{$opts{private}}) { $re->add($_); } $opts{private_re} ||= $re->_regexp; } if ($opts{optional} and ref $opts{optional} eq 'ARRAY') { require Regexp::Trie; my $re = Regexp::Trie->new; for (@{$opts{optional}}) { s|\\|/|g if WIN32; $re->add($_); } $opts{optional_re} ||= $re->_regexp; } if ($opts{optional_re}) { $opts{suggests} = 1; } if (my $index_name = delete $opts{use_index}) { my $index_package = "CPAN::Common::Index::$index_name"; if (eval "require $index_package; 1") { $opts{index} = $index_package->new; } } if ($opts{scan_also}) { $opts{libs} ||= delete $opts{scan_also}; } bless \%opts, $class; } sub run { my ($self, @args) = @_; unless (@args) { # for configure requires push @args, "Makefile.PL", "Build.PL"; # for test requires push @args, "t"; # for runtime requires; if ($self->{blib} and -d File::Spec->catdir($self->{base_dir}, 'blib')) { push @args, "blib/lib", "blib/bin", "blib/script"; } else { push @args, "lib"; push @args, glob(File::Spec->catfile($self->{base_dir}, '*.pm')); push @args, "bin", "script", "scripts"; } # extra libs push @args, map { bsd_glob(File::Spec->catdir($self->{base_dir}, $_)) } @{$self->{libs} || []}; # for develop requires push @args, "xt", "author" if $self->{develop}; } if ($self->{verbose}) { print STDERR "Scanning the following files/directories\n"; print STDERR " $_\n" for sort @args; } for my $path (@args) { my $item = File::Spec->file_name_is_absolute($path) ? $path : File::Spec->catfile($self->{base_dir}, $path); -d $item ? $self->_scan_dir($item) : -f $item ? $self->_scan_file($item) : next; } # add test requirements by .pm files used in .t files $self->_add_test_requires($self->{allow_test_pms}); $self->_exclude_local_modules; if ($self->{exclude_core}) { $self->_exclude_core_prereqs; } if ($self->{index}) { $self->_dedupe_indexed_prereqs; } $self->_dedupe; if ($self->{print} or $self->{cpanfile}) { if ($self->{json}) { # TODO: feature support (how should we express it?) eval { require JSON::PP } or die "requires JSON::PP"; print JSON::PP->new->pretty(1)->canonical->encode($self->{prereqs}->as_string_hash); } elsif ($self->{cpanfile}) { eval { require Perl::PrereqScanner::NotQuiteLite::Util::CPANfile } or die "requires Module::CPANfile"; my $file = File::Spec->catfile($self->{base_dir}, "cpanfile"); my $cpanfile = Perl::PrereqScanner::NotQuiteLite::Util::CPANfile->load_and_merge($file, $self->{prereqs}, $self->{features}); $self->_dedupe_indexed_prereqs($cpanfile->prereqs) if $self->{index}; if ($self->{save_cpanfile}) { $cpanfile->save($file); } elsif ($self->{print}) { print $cpanfile->to_string, "\n"; } return $cpanfile; } elsif ($self->{print}) { $self->_print_prereqs; } } $self->{prereqs}; } sub index { shift->{index} } sub _print_prereqs { my $self = shift; my $combined = CPAN::Meta::Requirements->new; for my $req ($self->_requirements) { $combined->add_requirements($req); } my $hash = $combined->as_string_hash; for my $module (sort keys %$hash) { next if $module eq 'perl'; my $version = $hash->{$module} || 0; $version = qq{"$version"} unless $version =~ /^[0-9]+(?:\.[0-9]+)?$/; print $version eq '0' ? "$module\n" : "$module~$version\n"; } } sub _requirements { my ($self, $prereqs) = @_; $prereqs ||= $self->{prereqs}; my @phases = qw/configure runtime build test/; push @phases, 'develop' if $self->{develop}; my @types = $self->{suggests} ? qw/requires recommends suggests/ : $self->{recommends} ? qw/requires recommends/ : qw/requires/; my @requirements; for my $phase (@phases) { for my $type (@types) { my $req = $prereqs->requirements_for($phase, $type); next unless $req->required_modules; push @requirements, $req; } } if ($self->{features}) { my @feature_prereqs = grep defined, map {$self->{features}{$_}{prereqs}} keys %{$self->{features} || {}}; for my $feature_prereqs (@feature_prereqs) { for my $phase (@phases) { for my $type (@types) { my $req = $feature_prereqs->requirements_for($phase, $type); next unless $req->required_modules; push @requirements, $req; } } } } @requirements; } sub _exclude_local_modules { my $self = shift; my @local_dirs = ("inc", @{$self->{libs} || []}); for my $dir (@local_dirs) { my $local_dir = File::Spec->catdir($self->{base_dir}, $dir); next unless -d $local_dir; find({ wanted => sub { my $file = $_; return unless -f $file; my $relpath = File::Spec->abs2rel($file, $local_dir); return unless $relpath =~ /\.pm$/; my $module = $relpath; $module =~ s!\.pm$!!; $module =~ s![\\/]!::!g; $self->{possible_modules}{$module} = 1; $self->{possible_modules}{"inc::$module"} = 1 if $dir eq 'inc'; }, no_chdir => 1, }, $local_dir); } my $private_re = $self->{private_re}; for my $req ($self->_requirements) { for my $module ($req->required_modules) { next unless $self->{possible_modules}{$module} or ($private_re and $module =~ /$private_re/); $req->clear_requirement($module); if ($self->{verbose}) { print STDERR " excluded $module (local)\n"; } } } } sub _exclude_core_prereqs { my $self = shift; eval { require Module::CoreList; Module::CoreList->VERSION('2.99') } or die "requires Module::CoreList 2.99"; my $perl_version = $self->{perl_version} || $self->_find_used_perl_version || '5.008001'; if ($perl_version =~ /^v?5\.(0?[1-9][0-9]?)(?:\.([0-9]))?$/) { $perl_version = sprintf '5.%03d%03d', $1, $2 || 0; } $perl_version = '5.008001' unless exists $Module::CoreList::version{$perl_version}; my %core_alias = ( 'Getopt::Long::Parser' => 'Getopt::Long', 'Tie::File::Cache' => 'Tie::File', 'Tie::File::Heap' => 'Tie::File', 'Tie::StdScalar' => 'Tie::Scalar', 'Tie::StdArray' => 'Tie::Array', 'Tie::StdHash' => 'Tie::Hash', 'Tie::ExtraHash' => 'Tie::Hash', 'Tie::RefHash::Nestable' => 'Tie::RefHash', ); for my $req ($self->_requirements) { for my $module ($req->required_modules) { $module = $core_alias{$module} if exists $core_alias{$module}; if (Module::CoreList::is_core($module, undef, $perl_version) and !Module::CoreList::deprecated_in($module, undef, $perl_version) ) { next unless exists $Module::CoreList::version{$perl_version}{$module}; my $core_version = $Module::CoreList::version{$perl_version}{$module}; next unless $req->accepts_module($module => $core_version); $req->clear_requirement($module); if ($self->{verbose}) { print STDERR " excluded $module ($perl_version core)\n"; } } } } } sub _find_used_perl_version { my $self = shift; my @perl_versions; my $perl_requirements = CPAN::Meta::Requirements->new; for my $req ($self->_requirements) { my $perl_req = $req->requirements_for_module('perl'); $perl_requirements->add_string_requirement('perl', $perl_req) if $perl_req; } return $perl_requirements->is_simple ? $perl_requirements->requirements_for_module('perl') : undef; } sub _add_test_requires { my ($self, $force) = @_; if (my $test_reqs = $self->{prereqs}->requirements_for('test', 'requires')) { my @required_modules = $test_reqs->required_modules; for my $module (@required_modules) { $force = 1 if exists $IsTestClassFamily{$module}; my $relpath = $self->{possible_modules}{$module} or next; my $context = delete $self->{_test_pm}{$relpath} or next; $test_reqs->add_requirements($context->requires); if ($self->{recommends} or $self->{suggests}) { $self->{prereqs}->requirements_for('test', 'recommends')->add_requirements($context->recommends); } if ($self->{suggests}) { $self->{prereqs}->requirements_for('test', 'suggests')->add_requirements($context->suggests); } } if ($force) { for my $context (values %{$self->{_test_pm} || {}}) { $test_reqs->add_requirements($context->requires); if ($self->{recommends} or $self->{suggests}) { $self->{prereqs}->requirements_for('test', 'recommends')->add_requirements($context->recommends); } if ($self->{suggests}) { $self->{prereqs}->requirements_for('test', 'suggests')->add_requirements($context->suggests); } } } } } sub _dedupe { my $self = shift; my $prereqs = $self->{prereqs}; my %features = map {$_ => $self->{features}{$_}{prereqs}} keys %{$self->{features} || {}}; dedupe_prereqs_and_features($prereqs, \%features); } sub _get_uri { my ($self, $module) = @_; $self->{uri_cache}{$module} ||= $self->__get_uri($module); } sub __get_uri { my ($self, $module) = @_; my $res = $self->{index}->search_packages({ package => $module }) or return; ## ignore (non-dual) core modules return if _dist_from_uri($res->{uri}) eq 'perl'; return $res->{uri}; } sub _dist_from_uri { my $uri = shift; $uri =~ s!^cpan:///\w+/!!; Parse::Distname->new($uri)->dist; } sub _dedupe_indexed_prereqs { my ($self, $prereqs) = @_; for my $req ($self->_requirements($prereqs)) { my %uri_map; for my $module ($req->required_modules) { next if $module eq 'perl'; my $uri = $self->_get_uri($module) or next; $uri_map{$uri}{$module} = $req->requirements_for_module($module); } for my $uri (keys %uri_map) { my @modules = keys %{$uri_map{$uri}}; next if @modules < 2; my @modules_without_version = grep {!$uri_map{$uri}{$_}} @modules; next unless @modules_without_version; # clear unversioned prereqs if a versioned prereq exists if (@modules > @modules_without_version) { $req->clear_requirement($_) for @modules_without_version; next; } # Replace with the main module if none is versioned my $dist = _dist_from_uri($uri); (my $main_module = $dist) =~ s/-/::/g; if ($self->_get_uri($main_module)) { $req->add_minimum($main_module); for my $module (@modules_without_version) { next if $main_module eq $module; $req->clear_requirement($module); if ($self->{verbose}) { print STDERR " deduped $module (in favor of $main_module)\n"; } } } else { # special case for distributions without a main module my %score; for my $module (@modules_without_version) { my $depth = $module =~ s/::/::/g; my $length = length $module; $score{$module} = join ".", ($depth || 0), $length; } my $topmost = (sort {$score{$a} <=> $score{$b} or $a cmp $b} @modules_without_version)[0]; for my $module (@modules_without_version) { next if $topmost eq $module; $req->clear_requirement($module); if ($self->{verbose}) { print STDERR " deduped $module (in favor of $topmost)\n"; } } } } } } sub _scan_dir { my ($self, $dir) = @_; find ({ no_chdir => 1, wanted => sub { my $file = $_; return unless -f $file; my $relpath = File::Spec->abs2rel($file, $self->{base_dir}); return unless $relpath =~ /\.(?:pl|PL|pm|cgi|psgi|t)$/ or dirname($relpath) =~ m!\b(?:bin|scripts?)$! or ($self->{develop} and $relpath =~ /^(?:author)\b/); $self->_scan_file($file); }, }, $dir); } sub _scan_file { my ($self, $file) = @_; $file =~ s|\\|/|g if WIN32; if ($self->{ignore_re}) { return if $file =~ /\b$self->{ignore_re}\b/; } my $optional = $self->{optional_re} && $file =~ /\b$self->{optional_re}\b/ ? 1 : 0; my $context = Perl::PrereqScanner::NotQuiteLite->new( parsers => $self->{parsers}, recommends => $self->{recommends}, suggests => $self->{suggests}, verbose => $self->{verbose}, optional => $optional, )->scan_file($file); my $relpath = File::Spec->abs2rel($file, $self->{base_dir}); $relpath =~ s|\\|/|g if WIN32; my $prereqs = $self->{prereqs}; if ($self->{features}) { for my $identifier (keys %{$self->{features}}) { my $feature = $self->{features}{$identifier}; if (grep {$file =~ m!^$_(?:/|$)!} @{$feature->{paths}}) { $prereqs = $feature->{prereqs} ||= CPAN::Meta::Prereqs->new; last; } } } if ($relpath =~ m!(?:^|[\\/])t[\\/]!) { if ($relpath =~ /\.t$/) { $self->_add($prereqs, test => $context); } elsif ($relpath =~ /\.pm$/) { $self->{_test_pm}{$relpath} = $context; } } elsif ($relpath =~ m!(?:^|[\\/])(?:xt|inc|author)[\\/]!) { $self->_add($prereqs, develop => $context); } elsif ($relpath =~ m!(?:(?:^|[\\/])Makefile|^Build)\.PL$!) { $self->_add($prereqs, configure => $context); } elsif ($relpath =~ m!(?:^|[\\/])(?:.+)\.PL$!) { $self->_add($prereqs, build => $context); } else { $self->_add($prereqs, runtime => $context); } if ($relpath =~ /\.pm$/) { my $module = $relpath; $module =~ s!\.pm$!!; $module =~ s![\\/]!::!g; $self->{possible_modules}{$module} = $relpath; $module =~ s!^(?:inc|blib|x?t)::!!; $self->{possible_modules}{$module} = $relpath; $module =~ s!^lib::!!; $self->{possible_modules}{$module} = $relpath; } } sub _add { my ($self, $prereqs, $phase, $context) = @_; $prereqs->requirements_for($phase, 'requires') ->add_requirements($context->requires); if ($self->{suggests} or $self->{recommends}) { $prereqs->requirements_for($phase, 'recommends') ->add_requirements($context->recommends); } if ($self->{suggests}) { $prereqs->requirements_for($phase, 'suggests') ->add_requirements($context->suggests); } } 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::App =head1 SYNOPSIS scan-perl-prereqs-nqlite [options] [DIRS|FILES] -or- use Perl::PrereqScanner::NotQuiteLite::App; my $app = Perl::PrereqScanner::NotQuiteLite::App->new( parsers => [qw/:bundled/], suggests => 1, perl_minimum_version => 1, ); my $prereqs = $app->run; =head1 DESCRIPTION Perl::PrereqScanner::NotQuiteLite::App walks down a directory and scans appropriate files to find prerequisites. You usually don't need to touch this module directly, but you might want to if you need finer control (to use a custom CPAN index etc). =head1 METHODS =head2 new creates an object. Notable options are: =over 4 =item parsers Perl::PrereqScanner::NotQuiteLite::App uses all the bundled parsers by default, but you can change if you need your own parsers. See L for details. =item recommends, suggests, perl_minimum_version Perl::PrereqScanner::NotQuiteLite::App usually returns Cd modules only, but you can change this behavior by setting these options. See L for details. =item develop If set, Perl::PrereqScanner::NotQuiteLite::App also scans files under C and C directories to find requirements for development. =item exclude_core If set, Perl::PrereqScanner::NotQuiteLite::App ignores prerequisites that are bundled with Perl (of 5.008001 by default, or of a Cd perl version if any). This requires L version 2.99 or above. =item perl_version You can explicitly use this option to exclude core modules of a specific perl version. =item allow_test_pms Perl::PrereqScanner::NotQuiteLite::App usually ignores C<.pm> files under C directory if they are not used in C<.t> files, considering they are some kind of sample files. However, this assumption may be wrong sometimes. If this option is set, it scans all the C<.pm> files under C directory, considering some of the test modules will use them. If L (or its equivalent) is used in a test file, this option is implicitly set. =item base_dir Perl::PrereqScanner::NotQuiteLite::App usually starts traversing from the current directory. If this option is set, it starts from there. =item scan_also Perl::PrereqScanner::NotQuiteLite::App usually scans C<.pm> files in the base dir, C/C, files under C, C, C, C directories (and C, C if asked). If your distribution uses a different file layout, or uses extra directories to keep submodules, you can add (a reference to) a list of paths to scan. =item ignore, ignore_re Your distribution may have OS-specific modules whose prerequisites can not be installed in other platforms. You can specify (a reference to) a list of files that should not be scanned (with C option), or a regular expression that matches the files (with C option). =item features my $app = Perl::PrereqScanner::NotQuiteLite::App->new( features => { 'windows' => { description => 'Windows support', paths => ['lib/Foo/Win32.pm'], } }, ); Instead of ignoring a set of files, you can use C option to let their prerequisites belong to a specific feature that will not be installed unless asked. However, you are advised to create a separate distribution for the specific feature. =item optional, optional_re Instead of ignoring a set of files, you can also use C option to mark all the prerequisites found in some of the files in your distribution optional (i.e. suggests). You can specify (a reference to) a list of files (with C option), or a regular expression that matches the files (with C option). =item private, private_re Your distribution may use private modules that are not uploaded to the CPAN and thus should not be included in C. You can specify (a reference to) a list of those private modules (with C option) or a regular expression that matches those modules (with C option). =item use_index, index Perl::PrereqScanner::NotQuiteLite::App usually lists all the Cd modules as prerequisites, but some of them may belong to the same distribution. If an instance of L backend is passed, it is used to dedupe those prerequisites (as long as they are not versioned). use CPAN::Common::Index::LocalPackage; my $index = CPAN::Common::Index::LocalPackage->new( { source => "$ENV{HOME}/minicpan/modules/02packages.details.txt" } ); my $app = Perl::PrereqScanner::NotQuiteLite::App->new( index => $index, ); =back =head2 run traverses files and directories and returns a L object that keeps all the requirements/suggestions, without printing anything unless you explicitly pass a C option to C. =head2 index returns a L backend object (if any). =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/lib/Perl/PrereqScanner/NotQuiteLite/Tokens.pm0000644000175100017510000000115214001101046030414 0ustar ishigakiishigakipackage Perl::PrereqScanner::NotQuiteLite::Tokens; use strict; use warnings; 1; __END__ =encoding utf-8 =head1 NAME Perl::PrereqScanner::NotQuiteLite::Tokens =head1 DESCRIPTION The interface of this module is not completely settled yet. If you need something to make it easier to write your own parsers, let me know. =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyclose (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/META.yml0000664000175100017510000000177414422514733021314 0ustar ishigakiishigaki--- abstract: 'a tool to scan your Perl code for its prerequisites' author: - 'Kenichi Ishigaki ' build_requires: ExtUtils::MakeMaker: '0' Test::FailWarnings: '0' Test::More: '0.98' Test::UseAllModules: '0.17' configure_requires: ExtUtils::MakeMaker::CPANfile: '0.09' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Perl-PrereqScanner-NotQuiteLite no_index: directory: - t - inc requires: CPAN::Meta::Prereqs: '2.150010' CPAN::Meta::Requirements: '2.140' Data::Dump: '0' Exporter: '5.57' Module::CPANfile: '1.1004' Module::CoreList: '3.11' Module::Find: '0' Parse::Distname: '0' Regexp::Trie: '0' parent: '0' perl: '5.008001' resources: repository: https://github.com/charsbar/Perl-PrereqScanner-NotQuiteLite version: '0.9917' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Perl-PrereqScanner-NotQuiteLite-0.9917/cpanfile0000644000175100017510000000215414223750666021544 0ustar ishigakiishigakirequires 'CPAN::Meta::Prereqs', '2.150010'; requires 'CPAN::Meta::Requirements', '2.140'; requires 'Data::Dump'; requires 'Exporter', '5.57'; requires 'Module::CPANfile', '1.1004'; requires 'Module::CoreList', '3.11'; requires 'Module::Find'; requires 'Parse::Distname'; requires 'Regexp::Trie'; requires 'parent'; requires 'perl', '5.008001'; suggests 'JSON::PP'; suggests 'CPAN::Common::Index'; on configure => sub { requires 'ExtUtils::MakeMaker::CPANfile', '0.06'; }; on test => sub { requires 'Test::FailWarnings'; requires 'Test::More', '0.98'; requires 'Test::UseAllModules', '0.17'; }; on develop => sub { requires 'Archive::Any::Lite'; requires 'CPAN::DistnameInfo'; requires 'Data::Dump'; requires 'Exporter', '5.57'; requires 'JSON::XS'; requires 'Log::Handler'; requires 'Module::ExtractUse'; requires 'Package::Abbreviate'; requires 'Path::Tiny'; requires 'Perl::PrereqScanner'; requires 'Test::More', '0.88'; requires 'Time::Piece'; requires 'Test::CPANfile', '0.06'; suggests 'Perl::PrereqScanner::Lite'; suggests 'Test::Pod', '1.18'; }; Perl-PrereqScanner-NotQuiteLite-0.9917/MANIFEST0000644000175100017510000000751714422514733021173 0ustar ishigakiishigakibin/scan-perl-prereqs-nqlite Changes cpanfile lib/Perl/PrereqScanner/NotQuiteLite.pm lib/Perl/PrereqScanner/NotQuiteLite/App.pm lib/Perl/PrereqScanner/NotQuiteLite/Context.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Aliased.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/AnyMoose.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Autouse.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Catalyst.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/ClassAccessor.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/ClassAutouse.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/ClassLoad.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Core.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Inline.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/KeywordDeclare.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Later.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Mixin.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/ModuleRuntime.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/MojoBase.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Moose.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/MooseXDeclare.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/ObjectPad.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Only.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/PackageVariant.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Plack.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/POE.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Prefork.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Superclass.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Syntax.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/SyntaxCollector.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/TestClassMost.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/TestMore.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/TestRequires.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/UniversalVersion.pm lib/Perl/PrereqScanner/NotQuiteLite/Parser/Unless.pm lib/Perl/PrereqScanner/NotQuiteLite/Tokens.pm lib/Perl/PrereqScanner/NotQuiteLite/Util.pm lib/Perl/PrereqScanner/NotQuiteLite/Util/CPANfile.pm lib/Perl/PrereqScanner/NotQuiteLite/Util/Prereqs.pm LICENSE Makefile.PL MANIFEST This list of files README t/00_load.t t/10_use.t t/11_require.t t/12_no.t t/15_eval.t t/20_parsers.t t/aliased.t t/app/allow_test_pms.t t/app/basic.t t/app/cpanfile.t t/app/dedupe.t t/app/exclude_core.t t/app/features.t t/app/ignore.t t/app/optional.t t/app/private.t t/app/scan_also.t t/app/use_index.t t/autouse.t t/begin_exit.t t/bin/basic.t t/bin/parser.t t/bin/scan_also.t t/catalyst.t t/class_autouse.t t/class_load.t t/compat/module_extractuse/10_basic.t t/compat/module_extractuse/21_comment.t t/compat/module_extractuse/22_eval.t t/compat/perl_prereqscanner/autoprereq.t t/core/base.t t/core/if.t t/core/parent.t t/inline.t t/later.t t/minimum_version.t t/mixin.t t/module_runtime.t t/mojo_base.t t/moose/any_moose.t t/moose/class_accessor.t t/moose/extends_inner_package.t t/moose/moose.t t/moose/no_moose.t t/moose/todo.t t/moose/with_variable.t t/moosex_declare.t t/object_pad.t t/object_pad_attr.t t/only.t t/package_variant.t t/plack.t t/prefork.t t/scan/apos.t t/scan/comment.t t/scan/data.t t/scan/elem.t t/scan/eval.t t/scan/format.t t/scan/function_parameters.t t/scan/glob.t t/scan/heredoc.t t/scan/if.t t/scan/keyword_declare.t t/scan/map.t t/scan/method.t t/scan/moosex_declare/attribute_issues.t t/scan/moosex_declare/parameterized_role.t t/scan/moosex_declare/with_newline.t t/scan/op.t t/scan/pod.t t/scan/postderef.t t/scan/print.t t/scan/qq.t t/scan/qr.t t/scan/re.t t/scan/recursion.t t/scan/sub.t t/scan/syntax/qs.t t/scan/trycatch.t t/scan/tt.t t/scan/utf8.t t/scan/Util.pm t/scan/variable.t t/syntax_collector.t t/test_class_most.t t/test_more.t t/test_requires.t t/universal_version.t t/unless.t t/Util.pm xt/99_pod.t xt/bundle.t xt/cpanfile.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Perl-PrereqScanner-NotQuiteLite-0.9917/Makefile.PL0000644000175100017510000000114214001101046021756 0ustar ishigakiishigakiuse strict; use warnings; use ExtUtils::MakeMaker::CPANfile 0.06; WriteMakefile( NAME => 'Perl::PrereqScanner::NotQuiteLite', AUTHOR => 'Kenichi Ishigaki ', VERSION_FROM => 'lib/Perl/PrereqScanner/NotQuiteLite.pm', ABSTRACT_FROM => 'lib/Perl/PrereqScanner/NotQuiteLite.pm', LICENSE => 'perl', EXE_FILES => ['bin/scan-perl-prereqs-nqlite'], META_MERGE => { resources => { repository => 'https://github.com/charsbar/Perl-PrereqScanner-NotQuiteLite', }, }, test => {TESTS => "t/*.t t/*/*.t t/*/*/*.t"}, ); Perl-PrereqScanner-NotQuiteLite-0.9917/t/0000755000175100017510000000000014422514733020273 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/scan/0000755000175100017510000000000014422514733021217 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/scan/recursion.t0000644000175100017510000000130214001101046023367 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test_with_error(<<'TEST'); # DCANTRELL/Data-Compare-1.25/t/deep-recursion.t # check that we DTRT on very deep recursion $a = [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[0]]]]]]]]]]]]]]]]]]]]]] ]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]; $b = [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[0]]]]]]]]]]]]]]]]]]]]]] ]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]; Compare($a, $b); TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/op.t0000644000175100017510000000132614001101046022002 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # MSERGEANT/XML-QL-0.07/QL.pm if ( ( ! $cm->{done} ) && ( $expat->context < $cm->{fail} ) ) { $cm->{done} = 1; $cm->{reason} = "out of context on $element"; } TEST test(<<'TEST'); # INGY/Spoon-0.24/lib/Spoon/Command.pm sub process { no warnings 'once'; local *boolean_arguments = sub { qw( -q -quiet ) }; my ($args, @values) = $self->parse_arguments(@_); $self->quiet(1) if $args->{-q} || $args->{-quiet}; my $action = $self->get_action(shift(@values)) || sub { $self->default_action(@_) }; $action->(@values); return $self; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/heredoc.t0000644000175100017510000005717314001101046023010 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # EGROSS/Lingua-PT-Conjugate-1.20/Infinitives.pm $infinitives = <Dump of tokens and values

Dump of tokens and values

EOHTML dumpit(@_); print "
TokenValue
"; } sub dumpit() { my ($self, $block) = @_; if (defined $block) { $self = \%$block if (defined $block); } my $repeating = $self->{'_C__REPEAT__'}; } TEST test(<<'TEST'); # GOMOR/Net-Packet-2.22/Packet/TCP.pm my $offX2Flags = ($self->off << 12) | (0x0f00 & ($self->x2 << 8)) | (0x00ff & $self->flags); my $phpkt; # Handle checksumming with DescL2&3 if ($frame->l3) { if ($frame->l3->isIpv4) { $phpkt = $self->SUPER::pack('a4a4CCn', inetAton($frame->l3->src), inetAton($frame->l3->dst), 0, $frame->l3->protocol, $frame->l3->getPayloadLength, ) or return undef; } elsif ($frame->l3->isIpv6) { $phpkt = $self->SUPER::pack('a*a*NnCC', inet6Aton($frame->l3->src), inet6Aton($frame->l3->dst), $frame->l3->payloadLength, 0, 0, $frame->l3->nextHeader, ) or return undef; } } # Handle checksumming with DescL4 else { my $totalLength = $self->getLength; $totalLength += $frame->l7->getLength if $frame->l7; if ($env->desc->isFamilyIpv4) { $phpkt = $self->SUPER::pack('a4a4CCn', inetAton($env->ip), inetAton($env->desc->target), 0, $env->desc->protocol, $totalLength, ) or return undef; } elsif ($env->desc->isFamilyIpv6) { $phpkt = $self->SUPER::pack('a*a*NnCC', inet6Aton($env->ip6), inet6Aton($env->desc->target), $totalLength, 0, 0, $env->desc->protocol, ) or return undef; } } TEST test(<<'TEST'); # FEDOROV/File-Stat-Bits-1.01/Bits.pm sub dev_join { my ($major, $minor) = @_; package File::Stat::Bits::dirty; if ( defined MAJOR_SHIFT ) { return (($major << MAJOR_SHIFT) & MAJOR_MASK) | (($minor << MINOR_SHIFT) & MINOR_MASK); } else { return undef; } } TEST test(<<'TEST'); # GAAL/Perl6-Signature-0.04/lib/Perl6/Signature.pm package Perl6::Signature; use warnings; use Parse::RecDescent; use Text::Balanced; use Perl6::Signature::Val; our $VERSION = '0.04'; #$::RD_TRACE = 1; $::RD_HINT = 1; our $SIGNATURE_GRAMMAR = << '#\'END'; #\ { use Text::Balanced qw(extract_bracketed); use Carp qw(croak); } Sig: Sig_colon | Sig_nocolon Sig_colon: ':' Sig_nocolon Sig_nocolon: '(' Sigbody ')' { $item{Sigbody} } Sigbody: Sigbody_inv | Sigbody_noinv Sigbody_inv: Invocant ':' Sigbody_noinv { my $sig = $item{Sigbody_noinv}; die "invocant cannot be optional" unless $item{Invocant}->{required}; $sig->s_invocant( $item{Invocant}->{param} ); $return = $sig; } Sigbody_noinv: Param(s? /,/) { my @params = @{ $item{'Param(s?)'} }; my @slurpies = map { $_->{param} } grep { $_->{slurpy} } @params; my @nonslurpies = grep { !$_->{slurpy} } @params; my @positionals = grep { $_->{style} eq 'positional' } @nonslurpies; my @named = grep { $_->{style} eq 'named' } @nonslurpies; my $seen_optional; my $requiredPositionalCount = 0; # calculate requiredPositionalCount, and make sure we don't have # :($optional?, $required!) -- that's invalid. for my $param (@positionals) { $seen_optional++ if ! $param->{required}; die "can't place required positional after an optional one" if $param->{required} && $seen_optional; $requiredPositionalCount++ if ! $seen_optional; } my %slurpies = map { $_->p_sigil => $_ } @slurpies; my ( $slurpy_array, $slurpy_hash ) = ( @slurpies{qw(@ %)} ); croak "Only one slurpy of every type is allowed" if keys %slurpies != @slurpies; my $sig = Perl6::Signature::Val::Sig->new ( s_requiredPositionalCount => $requiredPositionalCount , s_positionalList => [ map { $_->{param} } @positionals ] , s_namedList => [ map { $_->{param} } @named ] , s_requiredNames => { map { $_->{param}->p_label => 1 } grep { $_->{required} } @named } , ( $slurpy_array ? ( s_slurpyArray => $slurpy_array ) : () ), , ( $slurpy_hash ? ( s_slurpyHash => $slurpy_hash ) : () ), ); $return = $sig; } Invocant: Param Param: ParamType(s? /\|/) SlurpynessModifier(?) ParamIdentifier OptionalityModifier(?) Unpacking(?) DefaultValueSpec(?) Attrib(s?) Constraint(s?) { my ($variable, $label, $style) = @{$item{ParamIdentifier}}{qw/variable label style/}; my ($hasAccess, $isRef, $isContext, $isLazy, @slots); # unfortunately, we can't use a hash and delete from it: # "is ro is rw" means "is rw". (Or maybe, a parse error.) ATTR: for (@{ $item{'Attrib(s?)'} }) { /^(ro|rw|copy)$/ && do { $hasAccess = $_; next ATTR }; /^ref$/ && do { $isRef = 1; next ATTR }; /^context$/ && do { $isContext = 1; next ATTR }; /^lazy$/ && do { $isLazy = 1; next ATTR }; push @slots, $_; } my $param = Perl6::Signature::Val::SigParam->new ( p_types => $item{'ParamType(s?)'} , p_variable => $variable , p_label => $label , ($item{'Unpacking(?)'} ? (p_unpacking => $item{'Unpacking(?)'}->[0]) : ()) , (@{ $item{'DefaultValueSpec(?)'} } ? (p_default => $item{'DefaultValueSpec(?)'}->[0]) : ()) , (@{ $item{'Constraint(s?)'} } ? (p_constraints => [ @{ $item{'Constraint(s?)'} } ]) : ()) , ( $hasAccess ? ( p_hasAccess => $hasAccess ) : () ), , p_isRef => $isRef , p_isContext => $isContext , p_isLazy => $isLazy , p_slots => { map { $_ => 1 } @slots } # "is foo<42>" not supported yet. ); my $slurpy = 1 == @{ $item{'SlurpynessModifier(?)'} }; my $optionality = $item{'OptionalityModifier(?)'}->[0] || ''; my $optional = scalar @{ $item{'DefaultValueSpec(?)'} }; die "required parameter can't have default value" if $optional && $optionality eq '!'; $optional = 1 if $style eq 'named' && $optionality ne '!'; $optional = 1 if $optionality eq '?'; $return = { param => $param , required => !$optional , style => $style , slurpy => $slurpy }; } ParamType: /[a-zA-Z]\w+/ ParamIdentifier: ParamIdentifier_positional | ParamIdentifier_named # Perl 6 allows placeholder parameters, e.g. :($) - sub of arity 1 (scalar). ParamIdentifier_positional: Sigil Label(?) { my $label = @{ $item{'Label(?)'} } ? $item{'Label(?)'}->[0] : ''; $return = { variable => $item{Sigil} . $label , label => $label , style => 'positional' }; } # TODO: L, whoa. ParamIdentifier_named: ':' Label ParamIdentifier_named_variablename { $return = { variable => $item{'ParamIdentifier_named_variablename'} , label => $item{Label} , style => 'named' }; } | ':' Sigil Label { $return = { variable => $item{Sigil} . $item{Label} , label => $item{Label} , style => 'named' }; } ParamIdentifier_named_variablename: '(' ')' { $return = $item[2]; 1; } OptionalityModifier: /[!?]/ SlurpynessModifier: /\*/ Unpacking: Sig Constraint: 'where' # default values are _unevaluated_. DefaultValueSpec: '=' ValueOrSomeStabAtOne ValueOrSomeStabAtOne: Value_numberLiteral | Value_acceptableQuotelike | Value_variable | Value_looksBalanced | Value_looksClosure # perlfaq4 ftw Value_numberLiteral: /([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?/ # float | /-?(?:\d+(?:\.\d*)?|\.\d+)/ # decimal | /-?\d+\.?\d*/ # real | /[+-]?\d+/ # +/- integer | /-?\d+/ # integer | /\d+/ # whole number | /0x[0-9a-fA-F]+/ # hexadecimal | /0b[01]+/ # binary # note that octals will be captured by the "whole number" # production. Our consumer will have to eval this (we don't # want to do it for them because of roundtripping. But maybe # we need annotation nodes anyway? Value_acceptableQuotelike: { my $op = $item[1]->[0]; # q, qq etc. my %whitelist = map { $_ => 1 } qw(q qq qw qr); # TODO: lift this up die "rejected quotelike operator: $op" unless $whitelist{$op}; $return = join "", @{ $item[0] }; 1; } Value_variable: Value_looksBalanced: { extract_bracketed($text, '()') } | { extract_bracketed($text, '[]') } | { extract_bracketed($text, '{}') } Value_looksClosure: 'sub' Attrib: 'is' Label Sigil: /[\$\@\%]/ Label: /\w+/ # This one is a bummer: we don't want to provide a full parser for # Perl expressions here. If we are called in the context of Devel::Declare, # perhaps we can get a reference back to the real parser? Otherwise, we're # stuck with doing some half-assed parsing that would preclude e.g. # :($pi = 22/7) Literal: /\S+/ #'END my $parser = Parse::RecDescent->new($SIGNATURE_GRAMMAR) || die "GRAMMAR NO WORKY *CWY* *CWY*"; sub parse { my($self, $sig_str) = @_; my $res = $parser->Sig($sig_str); die "Unparsable signature" unless $res; return $res; } # These are my favorite debugging tools. Share and enjoy. #sub ::Y { require YAML::Syck; YAML::Syck::Dump(@_) } #sub ::YY { require Carp; Carp::confess(::Y(@_)) } 6; __END__ =head1 NAME Perl6::Signature - Parse, query, and pretty-print Perl 6 signatures =head1 SYNOPSIS use Perl6::Signature; my $sig = Perl6::Signature->parse( ':($self: $x, Int $y = 42 where { $_ % 2 == 0 }, :$z is copy)'); print $sig->s_requiredPositionalCount; # 1 print $sig->s_positionalList->[0]->p_label # "x" print $sig->s_namedList->[0]->p_hasAccess; # "copy" print $sig->to_string; # ":($self: $x, Int $y = 42 where { $_ % 2 == 0 }, :$z is copy)" =head1 DESCRIPTION I B models routine signatures as specified in Synopsis 6 of the Perl 6 documentation. These signatures offer a rich language for expressing type constraints, default values, and the optionality (among other things) of routine parameters. Included is a parser for the Signature language, accessors and convenience methods for querying Signature objects, and a pretty-printer for producing their canonical textual representation. =head1 MODULE LAYOUT OVERVIEW B contains a B-based parser for signatures. B is our local base class for Perl 6 values. It doesn't do anything interested in itself, but if this distribution is bridged to another Perl 6-modeling distribution, this could be the first insertion point for glue methods. The next two modules subclass it. B and B model full signatures and their consituent parameters. This is where you go to quiery and pretty-print your parsed objects. =head1 FUNCTIONS =head2 Perl6::Signature =over 4 =item Perl6::Signature->parse(STRING) Parse a well-formed signature specification into a B object. Returns undef on failure, and in some cases can die. (This needs to be regularized.) CAVEAT #1: we do "best effort" parsing for default values. Simple literals are okay; complex expressions may not be. CAVEAT #2: default value specifications are not evaluated by B, not-in-scope errors are not raised, and constant folding is not performed. There may be semantic implications to this. CAVEAT #3: we similarly do "best effort" to parse dynamic constraints (C<"where {....}"> blocks). Funky code might well fail to parse correctly. =back =head2 Perl6::Signature::Val::Sig =over 4 =item $sig->to_string Pretty-print a Sig object into canonical textual form. "Canonical form" means regualar whitespace, implicit "!" on mandatory positional parameters, impicit "?" on optional named parameters, and so on. Code from dynamic constraints is reproduced verbatim. =item has 's_invocant' => (is => 'rw', isa => 'Perl6::Signature::Val::SigParam', required => 0); =item has 's_requiredPositionalCount' => (is => 'rw', isa => 'Int'); =item has 's_requiredNames' => (is => 'rw', isa => 'HashRef'); # Set of names =item has 's_positionalList' => (is => 'rw', isa => 'ArrayRef[Perl6::Signature::Val::SigParam]'); =item has 's_namedList' => (is => 'rw', isa => 'ArrayRef[Perl6::Signature::Val::SigParam]'); =item has 's_slurpyScalarList' => (is => 'rw', isa => 'ArrayRef', required => 0); =item has 's_slurpyArray' => (is => 'rw', isa => 'Perl6::Signature::Val::SigParam', required => 0); =item has 's_slurpyHash' => (is => 'rw', isa => 'Perl6::Signature::Val::SigParam', required => 0); =item has 's_slurpyCode' => (is => 'rw', isa => 'Perl6::Signature::Val::SigParam', required => 0); =item has 's_slurpyCapture' => (is => 'rw', isa => 'Perl6::Signature::Val::SigParam', required => 0); =back =head2 Perl6::Signature::Val::SigParam =over 4 =item $param->to_string(%args) Pretty-print a SigParam object into canonical form. Note that a SigParam doesn't know whether it is required or optional; nor whether it is positional or named. This must be supplied by the Sig container. =item has 'p_variable' => (is => 'rw', isa => 'Str'); =item has 'p_types' => (is => 'rw', isa => 'ArrayRef'); # of types =item has 'p_constraints' => (is => 'rw', isa => 'ArrayRef'); # of code =item has 'p_unpacking' => (is => 'rw', isa => 'Perl6::Signature::Val::Sig|Undef', required => 0); =item has 'p_default' => (is => 'rw', required => 0); =item has 'p_label' => (is => 'rw', isa => 'Str'); =item has 'p_slots' => (is => 'rw', isa => 'HashRef'); =item has 'p_hasAccess' => (is => 'rw', ); # ro/rw/copy =item has 'p_isRef' => (is => 'rw', isa => 'Bool'); =item has 'p_isContext' => (is => 'rw', isa => 'Bool'); =item has 'p_isLazy' => (is => 'rw', isa => 'Bool'); =back =head1 SEE ALSO =over 4 =item L =item L =item L =back =head1 AUTHORS Gaal Yahas, C<< >> Contributions by: Yuval Kogman, CC< >> Florian Ragwitz, CC< >> =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Perl6::Signature You can also contact the maintainer at the address above or look for information at: =over 4 =item * AnnoCPAN: Annotated CPAN documentation L =item * Search CPAN L =item * Source repository L =back =head1 COPYRIGHT (The "MIT" License) Copyright 2008 Gaal Yahas. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =cut TEST test(<<'TEST'); # JENDA/CGI-Authent-0.2.1/Authent.pm sub between ($) { unless (isbetween(@_)) { $header =~ s/401.*?\n/403 Forbidden\x0D\x0A/m; $msg = <<"*END*"; Temporarily forbidden

Temporarily forbidden

This resource is available only at $_[0]. Please come later. *END* } return $res; } TEST test(<<'TEST'); # PFEIFFER/SQL-Steno-0.3.2/lib/SQL/Steno.pm print <<\HELP; All entries are single line unless \\wrapped at 1st bol and last eol\\ or continued.\ Queries have the form: {{!}/regexp/{i}}{=}query The query has lots of short-hands expanded, unless it is prefixed by the optional =. The fields joined with '~' are grepped if regexp is given, case-insensitively if i is given. ??query Only shows massaged query. !perl-code Runs perl-code. >file Next query's output to file. In csv or yaml format if filename has that suffix. Query has the form {select|update|insert|delete}{fieldlist};tablelist{;clause} or set ... 'select' is prepended if none of these initial keywords. fieldlist defaults to '*', also if Query starts with '#'. ';' is alternately replaced by 'from' and 'where'. Abbreviations, more help with ?&{abbrev}, ?:{abbrev}, ?\{abbrev}, ?#{abbrev}, ?.{abbrev}, ?{abbrev}( &{Perl code}... # only at bol, if it returns undef then skip, else prepend to ... &query $1;$2;... # only at bol &query($1;$2;...)... # only at bol, only replace upto ) :macro :\quote(arg,...) # split, quote & join (?\ alone needs trailing space, because \ at end continues) :{Perl code} # dynamic macro #table #table#t .column .column.c # for any table recognized in statement function( Characters \t\n\r get masked in output, \r\n as \R. Date or time 0000-00-00 -> 0000- 1970-01-01 -> 1970- 00:00:00 -> 00: 23:59:59 -> 24: HELP TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/apos.t0000644000175100017510000000171714001101046022332 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # PHRED/WebService-NetSuite-0.04/lib/WebService/NetSuite.pm if (ref($hashOrInternalId) eq'HASH') { foreach my $k (keys %{$hashOrInternalId}) { $req{$k} = $hashOrInternalId->{$k}; } } else { $req{'internalId'} = $hashOrInternalId; } TEST test(<<'TEST'); # SPROUT/WWW-Scripter-0.031/lib/WWW/Scripter.pm $self->{page_stack} = WWW'Scripter'History->new( $self ); weaken(my $self_fc = $self); # for closures $class_info{$self} = [ \(%HTML::DOM'Interface, %CSS'DOM'Interface, our%Interface), { 'WWW::Scripter::Image' => "Image", Image => { _constructor => sub { my $i = $self_fc->document->createElement('img'); @_ and $i->attr('width',shift); @_ and $i->attr('height',shift); $i } }, } ]; TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/qq.t0000644000175100017510000003736014001101046022014 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # HTML-Perlinfo-1.68/lib/HTML/Perlinfo/Base.pm eval qq{ END { delete \$INC{'HTML/Perlinfo.pm'}; \$html .= print_thesemodules('loaded',[values %INC]); \$html .= print_variables(); \$html .= '' if \$self->{'full_page'}; print \$html; } }; die $@ if $@; TEST test(<<'TEST'); # KARASIK/Prima-1.46/Prima/Sliders.pm sub init { my $self = shift; my %profile = @_; my $visible = $profile{visible}; $profile{visible} = 0; for (qw( min max step circulate pageStep)) {$self-> {$_} = 1;}; $self-> {edit} = bless [], q\Prima::SpinEdit::DummyEdit\; %profile = $self-> SUPER::init(%profile); my ( $w, $h) = ( $self-> size); $self-> {spin} = $self-> insert( $profile{spinClass} => ownerBackColor => 1, name => 'Spin', bottom => 1, right => $w - 1, height => $h - 1 * 2, growMode => gm::Right, delegations => $profile{spinDelegations}, (map { $_ => $profile{$_}} grep { exists $profile{$_} ? 1 : 0} keys %spinDynas), %{$profile{spinProfile}}, ); $self-> {edit} = $self-> insert( $profile{editClass} => name => 'InputLine', origin => [ 1, 1], size => [ $w - $self-> {spin}-> width - 1 * 2, $h - 1 * 2], growMode => gm::GrowHiX|gm::GrowHiY, selectable => 1, tabStop => 1, borderWidth => 0, current => 1, delegations => $profile{editDelegations}, (map { $_ => $profile{$_}} keys %editProps), %{$profile{editProfile}}, text => $profile{value}, ); for (qw( min max step value circulate pageStep)) {$self-> $_($profile{$_});}; $self-> visible( $visible); return %profile; } sub on_paint { my ( $self, $canvas) = @_; my @s = $canvas-> size; $canvas-> rect3d( 0, 0, $s[0]-1, $s[1]-1, 1, $self-> dark3DColor, $self-> light3DColor); } sub InputLine_MouseWheel { my ( $self, $edit, $mod, $x, $y, $z) = @_; $z = int($z/120); $z *= $self-> {pageStep} if $mod & km::Ctrl; my $value = $self-> value; $self-> value( $value + $z * $self-> {step}); $self-> value( $z > 0 ? $self-> min : $self-> max) if $self-> {circulate} && ( $self-> value == $value); $edit-> clear_event; } sub Spin_Increment { my ( $self, $spin, $increment) = @_; my $value = $self-> value; $self-> value( $value + $increment * $self-> {step}); $self-> value( $increment > 0 ? $self-> min : $self-> max) if $self-> {circulate} && ( $self-> value == $value); } sub InputLine_KeyDown { my ( $self, $edit, $code, $key, $mod) = @_; $edit-> clear_event, return if $key == kb::NoKey && !($mod & (km::Alt | km::Ctrl)) && chr($code) !~ /^[.\d+-]$/; if ( $key == kb::Up || $key == kb::Down || $key == kb::PgDn || $key == kb::PgUp) { my ($s,$pgs) = ( $self-> step, $self-> pageStep); my $z = ( $key == kb::Up) ? $s : (( $key == kb::Down) ? -$s : (( $key == kb::PgUp) ? $pgs : -$pgs)); if (( $mod & km::Ctrl) && ( $key == kb::PgDn || $key == kb::PgUp)) { $self-> value( $key == kb::PgDn ? $self-> min : $self-> max); } else { my $value = $self-> value; $self-> value( $value + $z); $self-> value( $z > 0 ? $self-> min : $self-> max) if $self-> {circulate} && ( $self-> value == $value); } $edit-> clear_event; return; } if ($key == kb::Enter) { my $value = $edit-> text; $self-> value( $value); $edit-> clear_event if $value ne $self-> value; return; } } sub InputLine_Change { my ( $self, $edit) = @_; $self-> notify(q(Change)); } sub InputLine_Enter { my ( $self, $edit) = @_; $self-> notify(q(Enter)); } sub InputLine_Leave { my ( $self, $edit) = @_; $self-> notify(q(Leave)); } sub set_bounds { my ( $self, $min, $max) = @_; $max = $min if $max < $min; ( $self-> { min}, $self-> { max}) = ( $min, $max); my $oldValue = $self-> value; $self-> value( $max) if $max < $self-> value; $self-> value( $min) if $min > $self-> value; } sub set_step { my ( $self, $step) = @_; $step = 0 if $step < 0; $self-> {step} = $step; } sub circulate { return $_[0]-> {circulate} unless $#_; $_[0]-> {circulate} = $_[1]; } sub pageStep { return $_[0]-> {pageStep} unless $#_; $_[0]-> {pageStep} = $_[1]; } sub min {($#_)?$_[0]-> set_bounds($_[1], $_[0]-> {'max'}) : return $_[0]-> {min};} sub max {($#_)?$_[0]-> set_bounds($_[0]-> {'min'}, $_[1]) : return $_[0]-> {max};} sub step {($#_)?$_[0]-> set_step ($_[1]):return $_[0]-> {step}} sub value { if ($#_) { my ( $self, $value) = @_; if ( $value =~ m/^\s*([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?\s*$/) { $value = $self-> {min} if $value < $self-> {min}; $value = $self-> {max} if $value > $self-> {max}; } else { $value = $self-> {min}; } return if $value eq $self-> {edit}-> text; $self-> {edit}-> text( $value); } else { my $self = $_[0]; my $value = $self-> {edit}-> text; if ( $value =~ m/^\s*([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?\s*$/) { $value = $self-> {min} if $value < $self-> {min}; $value = $self-> {max} if $value > $self-> {max}; } else { $value = $self-> {min}; } return $value; } } # gauge reliefs package gr; use constant Sink => -1; use constant Border => 0; use constant Raise => 1; package Prima::Gauge; use vars qw(@ISA); @ISA = qw(Prima::Widget); { my %RNT = ( %{Prima::Widget-> notification_types()}, Stringify => nt::Action, ); sub notification_types { return \%RNT; } } sub profile_default { return { %{$_[ 0]-> SUPER::profile_default}, indent => 1, relief => gr::Sink, ownerBackColor => 1, hiliteBackColor=> cl::Blue, hiliteColor => cl::White, min => 0, max => 100, value => 0, threshold => 0, vertical => 0, } } sub init { my $self = shift; my %profile = $self-> SUPER::init(@_); for (qw( relief value indent min max threshold vertical)) {$self-> {$_} = 0} $self-> {string} = ''; for (qw( vertical threshold min max relief indent value)) {$self-> $_($profile{$_}); } return %profile; } sub setup { $_[0]-> SUPER::setup; $_[0]-> value($_[0]-> {value}); } sub on_paint { my ($self,$canvas) = @_; my ($x, $y) = $canvas-> size; my $i = $self-> indent; my ($clComplete,$clBack,$clFore,$clHilite) = ($self-> hiliteBackColor, $self-> backColor, $self-> color, $self-> hiliteColor); my $v = $self-> {vertical}; my $complete = $v ? $y : $x; my $range = ($self-> {max} - $self-> {min}) || 1; $complete = int(($complete - $i*2) * $self-> {value} / $range + 0.5); my ( $l3, $d3) = ( $self-> light3DColor, $self-> dark3DColor); $canvas-> color( $clComplete); $canvas-> bar ( $v ? ($i, $i, $x-$i-1, $i+$complete) : ( $i, $i, $i + $complete, $y-$i-1)); $canvas-> color( $clBack); $canvas-> bar ( $v ? ($i, $i+$complete+1, $x-$i-1, $y-$i-1) : ( $i+$complete+1, $i, $x-$i-1, $y-$i-1)); # draw the border my $relief = $self-> relief; $canvas-> color(( $relief == gr::Sink) ? $d3 : (( $relief == gr::Border) ? cl::Black : $l3)); for ( my $j = 0; $j < $i; $j++) { $canvas-> line( $j, $j, $j, $y - $j - 1); $canvas-> line( $j, $y - $j - 1, $x - $j - 1, $y - $j - 1); } $canvas-> color(( $relief == gr::Sink) ? $l3 : (( $relief == gr::Border) ? cl::Black : $d3)); for ( my $j = 0; $j < $i; $j++) { $canvas-> line( $j + 1, $j, $x - $j - 1, $j); $canvas-> line( $x - $j - 1, $j, $x - $j - 1, $y - $j - 1); } # draw the text, if neccessary my $s = $self-> {string}; if ( $s ne '') { my ($fw, $fh) = ( $canvas-> get_text_width( $s), $canvas-> font-> height); my $xBeg = int(( $x - $fw) / 2 + 0.5); my $xEnd = $xBeg + $fw; my $yBeg = int(( $y - $fh) / 2 + 0.5); my $yEnd = $yBeg + $fh; my ( $zBeg, $zEnd) = $v ? ( $yBeg, $yEnd) : ( $xBeg, $xEnd); if ( $zBeg > $i + $complete) { $canvas-> color( $clFore); $canvas-> text_out_bidi( $s, $xBeg, $yBeg); } elsif ( $zEnd < $i + $complete + 1) { $canvas-> color( $clHilite); $canvas-> text_out_bidi( $s, $xBeg, $yBeg); } else { $canvas-> clipRect( $v ? ( 0, 0, $x, $i + $complete) : ( 0, 0, $i + $complete, $y) ); $canvas-> color( $clHilite); $canvas-> text_out_bidi( $s, $xBeg, $yBeg); $canvas-> clipRect( $v ? ( 0, $i + $complete + 1, $x, $y) : ( $i + $complete + 1, 0, $x, $y) ); $canvas-> color( $clFore); $canvas-> text_out_bidi( $s, $xBeg, $yBeg); } } } sub set_bounds { my ( $self, $min, $max) = @_; $max = $min if $max < $min; ( $self-> { min}, $self-> { max}) = ( $min, $max); my $oldValue = $self-> {value}; $self-> value( $max) if $self-> {value} > $max; $self-> value( $min) if $self-> {value} < $min; } sub value { return $_[0]-> {value} unless $#_; my $v = $_[1] < $_[0]-> {min} ? $_[0]-> {min} : ($_[1] > $_[0]-> {max} ? $_[0]-> {max} : $_[1]); $v -= $_[0]-> {min}; my $old = $_[0]-> {value}; if (abs($old - $v) >= $_[0]-> {threshold}) { my ($x, $y) = $_[0]-> size; my $i = $_[0]-> {indent}; my $range = ( $_[0]-> {max} - $_[0]-> {min}) || 1; my $x1 = $i + ($x - $i*2) * $old / $range; my $x2 = $i + ($x - $i*2) * $v / $range; ($x1, $x2) = ( $x2, $x1) if $x1 > $x2; my $s = $_[0]-> {string}; $_[0]-> {value} = $v; $_[0]-> notify(q(Stringify), $v, \$_[0]-> {string}); ( $_[0]-> {string} eq $s) ? $_[0]-> invalidate_rect( $x1, 0, $x2+1, $y) : $_[0]-> repaint; } } 1; TEST test(<<'TEST'); # AGENT/Makefile-DOM-0.008/t/Shell.pm sub run_test ($) { my $block = shift; #warn Dumper($block->cmd); my $tempdir = tempdir( 'backend_XXXXXX', TMPDIR => 1, CLEANUP => 1 ); my $saved_cwd = Cwd::cwd; chdir $tempdir; process_pre($block); my $cmd = [ split_arg($SHELL), '-c', $block->cmd() ]; if ($^O eq 'MSWin32' and $block->stdout and $block->stdout eq qq{\\"\n}) { workaround($block, $cmd); } else { test_shell_command($block, $cmd); } process_found($block); process_not_found($block); process_post($block); chdir $saved_cwd; } sub workaround (@) { my ($block, $cmd) = @_; my ($error_code, $stdout, $stderr) = run_shell( $cmd ); #warn Dumper($stdout); my $stdout2 = $block->stdout; my $stderr2 = $block->stderr; my $error_code2 = $block->error_code; my $name = $block->name; SKIP: { skip 'Skip the test uncovers quoting issue on Win32', 3 if 1; is ($stdout, $stdout2, "stdout - $name"); is ($stderr, $stderr2, "stderr - $name"); is ($error_code, $error_code2, "error_code - $name"); } } TEST test(<<'TEST'); # BPMEDLEY/Mojolicious-Plugin-SaveRequest-0.04/lib/Mojolicious/Plugin/SaveRequest.pm print($handle qq(my \@exec = ( \@runme, "get", "-v", "-M", \$method, "-c", \$body, map({ ("-H", \"\$_:\$headers{\$_}\") } keys \%headers), \$url );\n)); TEST test(<<'TEST'); # HIO/Pod-MultiLang-0.14/lib/Pod/MultiLang/Dict/ja.pm sub make_linktext { my ($pkg,$lang,$name,$section) = @_; $name ? $section ? qq($name “à "$section") : $name : $section ? qq("$section") : undef; } TEST test(<<'TEST'); # KEICHNER/XML-Parsepp-Testgen-0.03/lib/XML/Parsepp/Testgen.pm if ($check_positions) { say {$ofh} q!!; say {$ofh} q! my $e_line = -1;!; say {$ofh} q! my $e_col = -1;!; say {$ofh} q! my $e_bytes = -1;!; say {$ofh} q!!; say {$ofh} q! if ($err =~ m{at \s+ line \s+ (\d+), \s+ column \s+ (\d+), \s+ byte \s+ (\d+) \s+ at \s+}xms) {!; say {$ofh} q! $e_line = $1;!; say {$ofh} q! $e_col = $2;!; say {$ofh} q! $e_bytes = $3;!; say {$ofh} q! }!; say {$ofh} q!!; say {$ofh} q! is($e_line, !.sprintf('%4d', $rl->{e_line}) .q!, 'Test-!, sprintf('%03d', $tno), q!v1: error - lineno');!; say {$ofh} q! is($e_col, !.sprintf('%4d', $rl->{e_col}) .q!, 'Test-!, sprintf('%03d', $tno), q!v2: error - column');!; say {$ofh} q! is($e_bytes, !.sprintf('%4d', $rl->{e_bytes}).q!, 'Test-!, sprintf('%03d', $tno), q!v3: error - bytes');!; say {$ofh} q!!; } TEST test(<<'TEST'); # MBARBON/Devel-Debug-DBGp-0.06/DB/Text/Balanced.pm { $rdelspec = eval "qq{$rdel}" || do { my $del; for (qw,~ ! ^ & * ) _ + - = } ] : " ; ' > . ? / | ',) { next if $rdel =~ /\Q$_/; $del = $_; last } unless ($del) { use Carp; croak "Can't interpolate right delimiter $rdel" } eval "qq$del$rdel$del"; }; } TEST test(<<'TEST'); # ABH/Authen-Bitcard-0.90/lib/Authen/Bitcard.pm sub _verify { my $bc = shift; my($msg, $key, $sig) = @_; my $u1 = Math::BigInt->new("0b" . unpack("B*", sha1($msg))); $sig->{s}->bmodinv($key->{q}); $u1 = ($u1 * $sig->{s}) % $key->{q}; $sig->{s} = ($sig->{r} * $sig->{s}) % $key->{q}; $key->{g}->bmodpow($u1, $key->{p}); $key->{pub_key}->bmodpow($sig->{s}, $key->{p}); $u1 = ($key->{g} * $key->{pub_key}) % $key->{p}; $u1 %= $key->{q}; $u1 == $sig->{r}; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/postderef.t0000644000175100017510000000262714001101046023364 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # perlref $sref->$*; # same as ${ $sref } $aref->@*; # same as @{ $aref } $aref->$#*; # same as $#{ $aref } $href->%*; # same as %{ $href } $cref->&*; # same as &{ $cref } $gref->**; # same as *{ $gref } $gref->*{SCALAR}; # same as *{ $gref }{SCALAR} $aref->@[ ... ]; # same as @$aref[ ... ] $href->@{ ... }; # same as @$href{ ... } $aref->%[ ... ]; # same as %$aref[ ... ] $href->%{ ... }; # same as %$href{ ... } TEST test(<<'TEST'); $aref->@[ qw(foo) ]; $href->@{ qw(foo) }; $aref->%[ qw(foo) ]; $href->%{ qw(foo) }; TEST test(<<'TEST'); # CVLIBRARY/WebDriver-Tiny-0.006/lib/WebDriver/Tiny/Elements.pm sub append { bless [ shift->@*, map @$_[ 1.. $#$_ ], @_ ] } sub first { bless [ $_[0]->@[ 0, 1 ] ] } sub last { bless [ $_[0]->@[ 0, -1 ] ] } sub size { $#{ $_[0] } } sub slice { my ( $drv, @ids ) = shift->@*; bless [ $drv, @ids[@_] ] } sub split { my ( $drv, @ids ) = $_[0]->@*; map { bless [ $drv, $_ ] } @ids } TEST test(<<'TEST'); # CPAN-Testers-Schema-0.023/lib/CPAN/Testers/Schema/ResultSet/Stats.pm die $LOG->error( sprintf 'No upload matches for dist %s version %s (report %s)', $data->{distribution}->@{qw( name version )}, $guid, ); TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/Util.pm0000644000175100017510000000137314001101046022454 0ustar ishigakiishigakipackage t::scan::Util; use strict; use warnings; use Test::More; use Perl::PrereqScanner::NotQuiteLite; use Exporter qw/import/; use if (-d ".git" and !$ENV{PERL_PSNQL_DEBUG}), "Test::FailWarnings"; our @EXPORT = (@Test::More::EXPORT, qw/test todo_test test_with_error/); sub todo_test { SKIP: { local $TODO = "FIXME"; test(@_); } } sub test { my $string = shift; my $scanner = Perl::PrereqScanner::NotQuiteLite->new( parsers => [':bundled'], ); my $c = $scanner->scan_string($string); ok !@{$c->{errors}} or note explain $c; } sub test_with_error { my $string = shift; my $scanner = Perl::PrereqScanner::NotQuiteLite->new( parsers => [':bundled'], ); my $c = $scanner->scan_string($string); ok @{$c->{errors}}; } 1; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/method.t0000644000175100017510000000064514001101046022647 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # SATOH/Text-Xatena-0.18/t/lib/Text/Xatena/Test.pm sub thx ($) { my ($str) = @_; $INLINE->use if $INLINE; my $thx = Text::Xatena->new( %{ $options }, inline => $INLINE ? $INLINE->new(@{ $INLINE_ARGS }) : undef ); my $ret = $thx->format($str, ); $ret; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/trycatch.t0000644000175100017510000000040114001101046023176 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::scan::Util; test(<<'TEST'); # ASH/TryCatch-1.003002/t/lib/NoVarName.pm use TryCatch; try { } catch(Error $) { print "Error catched\n"; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/pod.t0000644000175100017510000006210414001101046022147 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # JEPRICE/Meta-Widget-Gtk-Sprite-0.01/Sprite.pm sub new { _debug "New sprite manager created"; my $self = bless {}, ref($_[0]) || $_[0] || __PACKAGE__; $self->{sprite} = {}; $self->{croot} = $_[1]; $self->{cgroup} = {}; return $self; } =item $sprite_number = $sprites->create("/path/to/filename", 10, 20); Create will load an image file (right now, only xpm format) from disk and make a sprite out of it. The two numbers are the x and y positi on on the canvas. =cut sub create { my ($self, $filename, $x, $y) = @_; my $img = Gtk::Gdk::ImlibImage->load_image($filename) || die "Could not load requested tile, $filename. $!"; my ( $cg, $cg_index ) = $self->_get_new_cgroup(); $cg->hide; my $imgitem = $cg->new($cg, "Gnome::CanvasImage", 'image' => $img, 'x' => $x, 'y' => $y, width => $img->rgb_width, height => $img->rgb_height, ); $cg->{x} = $x; $cg->{y} = $y; $cg->{width} = $img->rgb_width; $cg->{height} = $img->rgb_height; #$cg->{radius} = sqrt($cg->{width}**2 + $cg->{height}**2)/2; $cg->{radius} = ($cg->{width} + $cg->{height})/4; $cg->{cx} = $cg->{x} + $cg->{width}/2; $cg->{cy} = $cg->{y} + $cg->{height}/2; my $index = $self->_add_sprite($cg); $cg->{index} = $index; return $index; } =item $sprites->show( $sprite_number ); Makes the sprite appear on the canvas =cut sub show { my ($self, $item) = @_; $self->{sprite}->{$item}->show; } =item $sprites->hide( $sprite_number ); Make the sprite picture disappear from the canvas. Note that it can still collide with other sprites. If you don't want it to hit anythi ng, move it out of the way or ignore it in your own collision handler. =cut sub hide { my ($self, $item) = @_; $self->{sprite}->{$item}->hide; } TEST test(<<'TEST'); b#!/usr/bin/perl #$Id: pssql.pm 4624 2011-05-26 18:10:55Z pro $ $URL: svn://svn.setun.net/search/trunk/lib/pssql.pm $ =copyright PRO-search sql library Copyright (C) 2003-2011 Oleg Alexeenkov http://pro.setun.net/search/ proler@gmail.com This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . =cut =c todo: pg 2009/10/06-13:53:11 dev HandleError DBD::Pg::db do failed: no connection to the server DBI::db=HASH(0x1229568) 7 no connection to the server 2009/06/02-19:37:35 dev HandleError DBD::Pg::st execute failed: FATAL: terminating connection due to administrator command server closed the connection unexpectedly This probably means the server terminated abnormally before or while processing the request. DBI::st=HASH(0x271b688) 7 FATAL: terminating connection due to administrator command server closed the connection unexpectedly This probably means the server terminated abnormally before or while processing the request. 2009/06/02-19:37:35 dev err_parse st0 ret1 wdi= di= fa= 1 er= 300 1000 fatal 57P01 2009/06/02-19:37:36 dev HandleError DBD::Pg::st execute failed: no connection to the server DBI::st=HASH(0x271b718) 7 no connection to the server 2009/06/02-19:37:39 dev HandleError DBD::Pg::db do failed: no connection to the server DBI::db=HASH(0x1209d38) 7 no connection to the server $work =cut #our ( %config); package #no cpan pssql; use strict; use utf8; no warnings qw(uninitialized); our $VERSION = ( split( ' ', '$Revision: 4624 $' ) )[1]; #use locale; use DBI; use Data::Dumper; #dev only $Data::Dumper::Sortkeys = $Data::Dumper::Useqq = $Data::Dumper::Indent = $Data::Dumper::Terse = 1; our ( %work, ); #%stat %static, $param, our (%config); #local *config = *main::config; #*pssql::config = *main::config; #*pssql::work = *main::work; #*pssql::stat = *main::stat; *config = *main::config; *work = *main::work; *stat = *main::stat; use lib::abs './'; use psmisc; #use psconn; #our ( %config, %work, %stat, %static, $param, ); use base 'psconn'; our $AUTOLOAD; #our $VERSION = ( split( ' ', '$Revision: 4624 $' ) )[1]; my ( $tq, $rq, $vq ); my ( $roworder, $tableorder, ); our ( %row, %default ); $config{ 'log_' . $_ } = 0 for grep { !exists $config{ 'log_' . $_ } } qw(trace dmpbef); #warn "SQL UESEEDDD" ; sub row { my $row = shift @_; return { %{ ( defined $config{'row'} ? $config{'row'}{$row} : undef ) || $row{$row} || {} }, %{ $config{'row_all'} || {} }, 'order' => --$roworder, @_ }; } sub table { my $table = shift @_; return @_; #{ #%{ ( defined $config{'row'} ? $config{'row'}{$row} : undef ) || $row{$row} || {} }, %{ $config{'row_all'} || {} }, #'order' => --$tableorder, #@_ #}; } #} BEGIN { %row = ( 'time' => { 'type' => 'INT', 'unsigned' => 1, 'default' => 0, 'date_time' => 1, #todo }, 'uint' => { 'type' => 'INTEGER', 'unsigned' => 1, 'default' => 0, }, 'uint16' => { 'type' => 'SMALLINT', 'unsigned' => 1, 'default' => 0, }, 'uint64' => { 'type' => 'BIGINT', 'unsigned' => 1, 'default' => 0, }, 'text' => { 'type' => 'VARCHAR', 'index' => 10, 'default' => '', }, 'stem' => { 'type' => 'VARCHAR', #! 'length' => 128, 'fulltext' => 'stemi', 'default' => '', 'not null' => 1, 'stem_index' => 1, }, ); $row{'id'} ||= row( 'uint', 'auto_increment' => 1, 'primary' => 1 ), $row{'added'} ||= row( 'time', 'default_insert' => int( time() ), 'no_insert_update' => 1, ); $row{'year'} ||= row('uint16'); $row{'size'} ||= row('uint64'); %default = ( 'sqlite' => { #'dbi' => 'SQLite2', 'dbi' => 'SQLite', 'params' => [qw(dbname)], 'dbname' => $config{'root_path'} . 'sqlite.db', 'table quote' => '"', 'row quote' => '"', 'value quote' => "'", 'IF NOT EXISTS' => 'IF NOT EXISTS', 'index_IF NOT EXISTS' => 'IF NOT EXISTS', 'IF EXISTS' => 'IF EXISTS', 'REPLACE' => 'REPLACE', 'AUTO_INCREMENT' => 'AUTOINCREMENT', 'ANALYZE' => 'ANALYZE', 'err_ignore' => [qw( 1 )], 'error_type' => sub { #TODO!!! my $self = shift; my ( $err, $errstr ) = @_; #$self->log('dev',"ERRDETECT($err, $errstr)"); return 'install' if $errstr =~ /no such table:|unable to open database file/i; return 'syntax' if $errstr =~ /syntax|unrecognized token/i or $errstr =~ /misuse of aggregate/; return 'retry' if $errstr =~ /database is locked/i; #return 'connection' if $errstr =~ /connect/i; return undef; }, 'on_connect' => sub { my $self = shift; $self->do("PRAGMA synchronous = OFF;"); #$self->log( 'sql', 'on_connect!' ); }, 'no_dbirows' => 1, }, 'pgpp' => { 'dbi' => 'PgPP', 'user' => ( $^O =~ /^(?:(ms)?(dos|win(32|nt)?))/i ? 'postgres' : 'pgsql' ), #'port' => 5432, 'IF EXISTS' => 'IF EXISTS', 'CREATE TABLE' => 'CREATE TABLE', 'OFFSET' => 'OFFSET', #'unsigned' => 0, 'UNSIGNED' => '', 'table quote' => '"', 'row quote' => '"', 'value quote' => "'", 'index_name_table' => 1, 'REPLACE' => 'INSERT', 'EXPLAIN' => 'EXPLAIN ANALYZE', 'CASCADE' => 'CASCADE', 'SET NAMES' => 'SET client_encoding = ', 'fulltext_config' => 'pg_catalog.simple', 'params' => [qw(dbname host port path debug)], 'err_ignore' => [qw( 1 7)], 'error_type' => sub { my $self = shift, my ( $err, $errstr ) = @_; #$self->log('dev',"ERRDETECT($err, [$errstr])"); return 'install_db' if $errstr =~ /FATAL:\s*database ".*?" does not exist/i; return 'fatal' if $errstr =~ /fatal/i; return 'syntax' if $errstr =~ /syntax/i; return 'connection' if $errstr =~ /connect|Unknown message type: ''/i; return 'install' if $errstr =~ /ERROR:\s*(?:relation \S+ does not exist)/i; #return 'retry' if $errstr =~ /ERROR:\s*cannot drop the currently open database/i; return 'retry' if $errstr =~ /ERROR: database ".*?" is being accessed by other users/i; return 'ignore' if $errstr =~ /(?:duplicate key violates unique constraint)|(?:duplicate key value violates unique constraint)|(?:ERROR:\s*(?:database ".*?" already exists)|(?:relation ".*?" already exists)|(?:invalid byte sequence for encoding)|(?:function .*? does not exist)|(?:null value in column .*? violates not-null constraint))/i; return undef; }, 'on_connect' => sub { my $self = shift; $self->set_names(); $self->do("select set_curcfg('default');") if $self->{'use_fulltext'} and $self->{'old_fulltext'}; }, 'no_dbirows' => 1, 'cp1251' => 'win1251', 'fulltext_word_glue' => '&', }, 'sphinx' => { 'dbi' => 'mysql', 'user' => 'root', 'port' => 9306, 'params' => [qw(host port )], # perldoc DBD::mysql 'sphinx' => 1, 'value quote' => "'", 'no_dbirows' => 1, 'no_column_prepend_table' => 1, 'no_join' => 1, 'OPTION' => 'OPTION', 'option' => { 'max_query_time' => 20000, 'cutoff' => 1000 }, }, 'mysql5' => { 'dbi' => 'mysql', 'user' => 'root', 'use_drh' => 1, 'mysql_enable_utf8' => 1, 'varchar_max' => 65530, 'unique_max' => 1000, 'primary_max' => 999, 'fulltext_max' => 1000, 'err_connection' => [qw( 1 1040 1053 1129 1213 1226 2002 2003 2006 2013 )], 'err_fatal' => [qw( 1016 1046 1251 )], # 1045, 'err_syntax' => [qw( 1054 1060 1064 1065 1067 1071 1096 1103 1118 1148 1191 1364 1366 1406 1439)], #maybe all 1045..1075 'err_repair' => [qw( 126 130 144 145 1034 1062 1194 1582 )], 'err_retry' => [qw( 1317 )], 'err_install' => [qw( 1146 )], 'err_install_db' => [qw( 1049 )], 'err_ignore ' => [qw( 2 1264 )], 'error_type' => sub { my $self = shift, my ( $err, $errstr ) = @_; #$self->log('dev',"MYERRDETECT($err, $errstr)"); for my $errtype (qw(connection retry syntax fatal repair install install_db)) { #$self->log('dev',"ERRDETECTED($err, $errstr) = $errtype"), return $errtype if grep { $err eq $_ } @{ $self->{ 'err_' . $errtype } }; } return undef; }, 'table quote' => "`", 'row quote' => "`", 'value quote' => "'", #'index quote' => "`", #'unsigned' => 1, 'quote_slash' => 1, 'index in create table' => 1, 'utf-8' => 'utf8', 'koi8-r' => 'koi8r', 'table options' => 'ENGINE = MYISAM DELAY_KEY_WRITE=1', 'IF NOT EXISTS' => 'IF NOT EXISTS', 'IF EXISTS' => 'IF EXISTS', 'IGNORE' => 'IGNORE', 'REPLACE' => 'REPLACE', 'INSERT' => 'INSERT', 'HIGH_PRIORITY' => 'HIGH_PRIORITY', 'SET NAMES' => 'SET NAMES', 'DEFAULT CHARACTER SET' => 'DEFAULT CHARACTER SET', 'USE_FRM' => 'USE_FRM', 'EXTENDED' => 'EXTENDED', 'QUICK' => 'QUICK', 'ON DUPLICATE KEY UPDATE' => 'ON DUPLICATE KEY UPDATE', 'UNSIGNED' => 'UNSIGNED', 'UNLOCK TABLES' => 'UNLOCK TABLES', 'LOCK TABLES' => 'LOCK TABLES', 'OPTIMIZE' => 'OPTIMIZE TABLE', 'ANALYZE' => 'ANALYZE TABLE', 'CHECK' => 'CHECK TABLE', 'FLUSH' => 'FLUSH TABLE', 'LOW_PRIORITY' => 'LOW_PRIORITY', 'on_connect' => sub { my $self = shift; $self->{'db_id'} = $self->{'dbh'}->{'mysql_thread_id'}; $self->set_names() if !( $ENV{'MOD_PERL'} || $ENV{'FCGI_ROLE'} ); }, 'on_user' => sub { my $self = shift; $self->set_names() if $ENV{'MOD_PERL'} || $ENV{'FCGI_ROLE'}; }, 'params' => [ qw(host port database mysql_client_found_rows mysql_compression mysql_connect_timeout mysql_read_default_file mysql_read_default_group mysql_socket mysql_ssl mysql_ssl_client_key mysql_ssl_client_cert mysql_ssl_ca_file mysql_ssl_ca_path mysql_ssl_cipher mysql_local_infile mysql_embedded_options mysql_embedded_groups mysql_enable_utf8) ], # perldoc DBD::mysql 'insert_by' => 1000, ( !$ENV{'SERVER_PORT'} ? ( 'auto_check' => 1 ) : () ), 'unique name' => 1, # test it 'match' => sub { my $self = shift; my ( $param, $param_num, $table, $search_str, $search_str_stem ) = @_; my ( $ask, $glue ); local %_; map { $_{ $self->{'table'}{$table}{$_}{'fulltext'} } = 1 } grep { $self->{'table'}{$table}{$_}{'fulltext'} or ( $self->{'sphinx'} and $self->{'table'}{$table}{$_}{'sphinx'} ) } keys %{ $self->{'table'}{$table} }; for my $index ( keys %_ ) { if ( $_ = join( ' , ', map { "$rq$_$rq" } sort { $self->{'table'}{$table}{$b}{'order'} <=> $self->{'table'}{$table}{$a}{'order'} } grep { $self->{'table'}{$table}{$_}{'fulltext'} eq $index } keys %{ $self->{'table'}{$table} } ) ) { my $stem = grep { $self->{'table'}{$table}{$_}{'fulltext'} eq $index and $self->{'table'}{$table}{$_}{'stem_index'} } keys %{ $self->{'table'}{$table} }; #TODO: maybe some message for user ? $self->{'accurate'} = 1, next, if ($stem and length $search_str_stem and $self->{'auto_accurate_on_slow'} and $search_str_stem =~ /\b\w{$self->{'auto_accurate_on_slow'}}\b/ ); my $double = grep { $self->{'table'}{$table}{$_}{'fulltext'} and $self->{'table'}{$table}{$_}{'stem'} } keys %{ $self->{'table'}{$table} }; next if $double and ( $self->{'accurate'} xor !$stem ); my $match; if ( $self->{'sphinx'} ) { $match = ' MATCH (' . $self->squotes( $stem ? $search_str_stem : $search_str ) . ')' } else { $match = ' MATCH (' . $_ . ')' . ' AGAINST (' . $self->squotes( $stem ? $search_str_stem : $search_str ) . ( ( !$self->{'no_boolean'} and $param->{ 'adv_query' . $param_num } eq 'on' ) ? 'IN BOOLEAN MODE' #: ( $self->{'allow_query_expansion'} ? 'WITH QUERY EXPANSION' : '' ) : $self->{'fulltext_extra'} ) . ') '; } $ask .= " $glue " . $match; $work{'what_relevance'}{$table} ||= $match . " AS $rq" . "relev$rq" if $self->{'select_relevance'} or $self->{'table_param'}{$table}{'select_relevance'}; } $glue = $self->{'fulltext_glue'}; } return $ask; }, }, ); } sub new { my $self = bless( {}, shift ); $self->init(@_); $self->psconn::init(@_); return $self; } sub cmd { my $self = shift; my $cmd = shift; $self->log( 'trace', "pssql::$cmd [$self->{'dbh'}]", @_ ) if $cmd ne 'log'; $self->{'handler_bef'}{$cmd}->( $self, \@_ ) if $self->{'handler_bef'}{$cmd}; my @ret = ref( $self->{$cmd} ) eq 'CODE' ? ( wantarray ? ( $self->{$cmd}->( $self, @_ ) ) : scalar $self->{$cmd}->( $self, @_ ) ) : ( exists $self->{$cmd} ? ( ( defined( $_[0] ) ? ( $self->{$cmd} = $_[0] ) : ( $self->{$cmd} ) ) ) : (!$self->{'dbh'} ? () : $self->{'dbh'}->can($cmd) ? $self->{'dbh'}->$cmd(@_) : exists $self->{'dbh'}{$cmd} ? ( ( defined( $_[0] ) ? ( $self->{'dbh'}->{$cmd} = $_[0] ) : ( $self->{'dbh'}->{$cmd} ) ) ) : undef) ); $self->{'handler'}{$cmd}->( $self, \@_, \@ret ) if $self->{'handler'}{$cmd}; return wantarray ? @ret : $ret[0]; } sub AUTOLOAD { my $self = shift; my $type = ref($self) or return; my $name = $AUTOLOAD; $name =~ s/.*://; # strip fully-qualified portion #$self->log('dev', 'autoload', $name, $AUTOLOAD, @_); return $self->cmd( $name, @_ ); } sub _disconnect { my $self = shift; $self->log( 'trace', 'pssql::_diconnect', "dbh=$self->{'dbh'}" ); $self->flush_insert() unless $self->{'in_disconnect'}; $self->{'in_disconnect'} = 1; return 0; } sub _dropconnect { my $self = shift; $self->log( 'trace', 'pssql::_dropconnect' ); $self->{'in_disconnect'} = 1; $self->{'sth'}->finish() if $self->{'sth'}; $self->{'dbh'}->disconnect(), $self->{'dbh'} = undef if $self->{'dbh'} and keys %{ $self->{'dbh'} }; delete $self->{'in_disconnect'}; return 0; } sub _check { my $self = shift; return 1 if !$self->{'dbh'} or !$self->{'connected'}; #or !keys %{$self->{'dbh'}}; return !$self->{'dbh'}->ping(); } sub init { my $self = shift; #warn Dumper $self, \@_; local %_ = ( 'log' => sub (@) { shift; psmisc::printlog(@_); }, 'driver' => 'mysql5', 'host' => ( $^O eq 'cygwin' ? '127.0.0.1' : 'localhost' ), 'database' => 'pssqldef', #'connect_tries' => 100, 'error_sleep' => ( $ENV{'SERVER_PORT'} ? 1 : 3600 ), 'error_tries' => ( $ENV{'SERVER_PORT'} ? 1 : 1000 ), 'error_chain_tries' => ( $ENV{'SERVER_PORT'} ? 1 : 100 ), #($ENV{'SERVER_PORT'} ? ('connect_tries'=>1) : ()), #'reconnect_tries' => 10, #look old 'connect_tries' => ( $ENV{'SERVER_PORT'} ? 1 : 0 ), 'connect_chain_tries' => 0, 'connect_auto' => 0, 'connect_params' => { 'RaiseError' => 0, 'AutoCommit' => 1, 'PrintError' => 0, 'PrintWarn' => 0, 'HandleError' => sub { $self->log( 'dev', 'HandleError', @_, $DBI::err, $DBI::errstr ); #$self->{'err'} = "$DBI::err, $DBI::errstr"; #psmisc::caller_trace(15) }, }, #'connect_check' => 1, #check connection on every keep() ( $ENV{'SERVER_PORT'} ? () : ( 'auto_repair' => 10 ) ), # or number 10-30 'auto_repair_selected' => 0, # repair all tables 'auto_install' => 1, 'auto_install_db' => 1, 'err_retry_unknown' => 0, #'reconnect_sleep' => 3600, #maximum sleep on connect error 'codepage' => 'utf-8', #'cp_in' => 'utf-8', 'index_postfix' => '_i', 'limit_max' => 1000, 'limit_default' => 100, #'limit' => 100, 'page_min' => 1, 'page_default' => 1, #'varchar_max' => 255, 'varchar_max' => 65535, 'row_max' => 65535, 'primary_max' => 65535, 'fulltext_max' => 65535, 'AUTO_INCREMENT' => 'AUTO_INCREMENT', 'EXPLAIN' => 'EXPLAIN', 'statable' => { 'queries' => 1, 'connect_tried' => 1, 'connects' => 1, 'inserts' => 1 }, 'statable_time' => { 'queries_time' => 1, 'queries_avg' => 1, }, 'param_trans_int' => { 'on_page' => 'limit', 'show_from' => 'limit_offset', 'page' => 'page', 'accurate' => 'accurate' }, #'param_trans' => { 'codepage'=>'cp_out' ,}, 'connect_cached' => 1, 'char_type' => 'VARCHAR', 'true' => 1, 'fulltext_glue' => 'OR', 'retry_vars' => [qw(auto_repair connect_tries connect_chain_tries error_sleep error_tries auto_check)], 'err' => 0, 'insert_cached_time' => 60, 'auto_repairs_max' => 2, @_, ); @{$self}{ keys %_ } = values %_; #$self->{$_} //= $_{$_} for keys %_; #%_ = @_; #$self->{$_} = $_{$_} for keys %_; #$self->log( 'dev', 'initdb', "$self->{'database'},$self->{'dbname'};"); $self->{'database'} = $self->{'dbname'} if $self->{'dbname'}; $self->{'dbname'} ||= $self->{'database'}; $self->calc(); $self->functions(); ( $tq, $rq, $vq ) = $self->quotes(); DBI->trace( $self->{'trace_level'}, $self->{'trace'} ) if $self->{'trace_level'} and $self->{'trace'}; return 0; } sub calc { my $self = shift; $self->{'default'} ||= \%default; $self->{'default'}{'pgpp'}{'match'} = sub { my $self = shift; return undef unless $self->{'use_fulltext'}; my ( $param, $param_num, $table, $search_str, $search_str_stem ) = @_; my ( $ask, $glue ); s/(?:^\s+)|(?:\s+$)//, s/\s+/$self->{'fulltext_word_glue'}/g for ( $search_str, $search_str_stem ); local %_; map { $_{ $self->{'table'}{$table}{$_}{'fulltext'} } = 1 } grep { $self->{'table'}{$table}{$_}{'fulltext'} } keys %{ $self->{'table'}{$table} }; for my $index ( keys %_ ) { my $stem = grep { $self->{'table'}{$table}{$_}{'fulltext'} eq $index and $self->{'table'}{$table}{$_}{'stem_index'} } keys %{ $self->{'table'}{$table} }; my $double = grep { $self->{'table'}{$table}{$_}{'fulltext'} and $self->{'table'}{$table}{$_}{'stem'} } keys %{ $self->{'table'}{$table} }; next if $double and ( $self->{'accurate'} xor !$stem ); $ask .= " $glue $index @@ to_tsquery( ${vq}$self->{'fulltext_config'}${vq}, " . $self->squotes( $stem ? $search_str_stem : $search_str ) . ")"; $glue ||= $self->{'fulltext_glue'}; } return $ask; } if $self->{'use_fulltext'}; %{ $self->{'default'}{'mysql6'} } = %{ $self->{'default'}{'mysql5'} }; %{ $self->{'default'}{'mysql4'} } = %{ $self->{'default'}{'mysql5'} }; $self->{'default'}{'mysql4'}{'SET NAMES'} = $self->{'default'}{'mysql4'}{'DEFAULT CHARACTER SET'} = $self->{'default'}{'mysql4'}{'ON DUPLICATE KEY UPDATE'} = ''; $self->{'default'}{'mysql4'}{'varchar_max'} = 255; %{ $self->{'default'}{'mysql3'} } = %{ $self->{'default'}{'mysql4'} }; $self->{'default'}{'mysql3'}{'table options'} = ''; $self->{'default'}{'mysql3'}{'USE_FRM'} = ''; $self->{'default'}{'mysql3'}{'no_boolean'} = 1; #%{ $self->{'default'}{'sqlite2'} } = %{ $self->{'default'}{'sqlite'} }; #$self->{'default'}{'sqlite2'}{'IF NOT EXISTS'} = $self->{'default'}{'sqlite2'}{'IF EXISTS'} = ''; $self->{'default'}{'pgpp'}{'fulltext_config'} = 'default' if $self->{'old_fulltext'}; %{ $self->{'default'}{'pg'} } = %{ $self->{'default'}{'pgpp'} }; $self->{'default'}{'pg'}{'dbi'} = 'Pg'; $self->{'default'}{'pg'}{'params'} = [qw(host port options tty dbname user password)]; %{ $self->{'default'}{'mysqlpp'} } = %{ $self->{'default'}{'mysql5'} }; $self->{'default'}{'mysqlpp'}{'dbi'} = 'mysqlPP'; $self->{'default'}{'sphinx'}{'match'} = $self->{'default'}{'mysql5'}{'match'}; $self->{'driver'} ||= 'mysql5'; $self->{'driver'} = 'mysql5' if $self->{'driver'} eq 'mysql'; #print "U0:", $self->{user}; #print "D0:", $self->{dbi}; $self->{$_} //= $self->{'default'}{ $self->{'driver'} }{$_} for keys %{ $self->{'default'}{ $self->{'driver'} } }; #print "U1:", $self->{user}; #print "D1:", $self->{dbi}; #$self->log( 'dev', "calc dbi[$self->{'dbi'} ||= $self->{'driver'}]"); $self->{'dbi'} ||= $self->{'driver'}, $self->{'dbi'} =~ s/\d+$//i unless $self->{'dbi'}; $self->{'codepage'} = psmisc::cp_normalize( $self->{'codepage'} ); local $_ = $self->{ $self->{'codepage'} } || $self->{'codepage'}; $self->{'cp'} = $_; $self->{'cp_set_names'} ||= $_; #$self->{'cp_int'} ||= 'cp1251'; # internal $self->{'cp_int'} ||= 'utf-8'; # internal $self->cp_client( $self->{'codepage'} ); } sub _connect { my $self = shift; =c $self->log( 'dev', 'conn', "dbi:$self->{'dbi'}:" #"dbi:$self->{'default'}{ $self->{'driver'} }{'dbi'}:database=$self->{'base'};" #map {"$_:$self->{$_}"} qw(dbi database) . join( ';', map( { $_ . '=' . $self->{$_} } grep { defined( $self->{$_} ) } @{ $self->{'params'} } ) ), $self->{'user'}, $self->{'pass'}, #\%{ $self->{'connect_params'} } $self->{'connect_params'} ); =cut local @_ = ( "dbi:$self->{'dbi'}:" . join( ';', map( { $_ . '=' . $self->{$_} } grep { defined( $self->{$_} ) } @{ $self->{'params'} } ) ), $self->{'user'}, $self->{'pass'}, $self->{'connect_params'} ); #$self->log('dmp', "connect_cached = ",$self->{'connect_cached'}, Dumper(\@_)); $self->{'dbh'} = ( $self->{'connect_cached'} ? DBI->connect_cached(@_) : DBI->connect(@_) ); local $_ = $self->err_parse( \'Connection', $DBI::err, $DBI::errstr ); return $_; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/eval.t0000644000175100017510000000103614001101046022311 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # AMW/ConfigReader-0.5/DirectiveStyle.pm return eval '"\\' . $1 . '"'; TEST test(<<'TEST'); # MARKSTOS/Data-FormValidator-4.66/lib/Data/FormValidator/Results.pm if (defined *{qualify_to_ref($routine)}{CODE}) { local $SIG{__DIE__} = \&confess; $c->{constraint} = eval 'sub { no strict qw/refs/; return defined &{"match_'.$c->{constraint}.'"}(@_)}'; } TEST done_testing;Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/map.t0000644000175100017510000000173014001101046022140 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # AUTRIJUS/Lingua-ZH-Summarize-0.01/Summarize.pm my %punct = map { $_ => $_ } qw(¡C ¡H ¡I ¡F ...); TEST test(<<'TEST'); # OVID/Data-Record-0.02/lib/Data/Record.pm sub _fields { my $self = shift; return $self->{fields} unless @_; my $fields = ref($self)->new(shift); if ( defined( my $token = $self->token ) ) { $fields->token($token); } $self->{fields} = $fields; return $self; } my @tokens = map { $_ x 6 } qw( ~ ` ? " { } ! @ $ % ^ & * - _ + = ); TEST test(<<'TEST'); # MSULLIVA/String-EscapeCage-0.02/lib/String/EscapeCage.pm cstring => do { # or maybe use String::Escape my %ESCAPE_OF = map { eval qq| "\\$_" | => "\\$_" } qw( 0 a b t n f r \ " ); my $RE = eval 'qr/[' . join( '', keys(%ESCAPE_OF) ) . ']/'; sub { my $string = shift; $string =~ s/$RE/$ESCAPE_OF{$&}/xg; return $string; } }, TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/glob.t0000644000175100017510000000035514001101046022310 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # RRA/Tie-ShadowHash-1.00/ShadowHash.pm while (!@result && $self->{EACH} < @{ $self->{SOURCES} }) { } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/function_parameters.t0000644000175100017510000000341514001101046025435 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::scan::Util; test(<<'TEST'); # MHOWARD/Class-Type-Enum-0.009/lib/Class/Type/Enum.pm use Function::Parameters; method coerce_any ($class: $value) { return $value if eval { $value->isa($class) }; for my $method (qw( inflate_ordinal inflate_symbol )) { my $enum = eval { $class->$method($value) }; return $enum if $enum; } croak "Could not coerce invalid value [$value] into $class"; } TEST test(<<'TEST'); # MHOWARD/Class-Type-Enum-0.009/lib/Class/Type/Enum.pm use Function::Parameters; method stringify ($, $) { $self->ord_to_sym->{$self->{ord}}; } TEST test(<<'TEST'); # TJC/Test-PostgreSQL-1.23/lib/Test/PostgreSQL.pm use Moo; use Function::Parameters qw(:strict); has base_dir => ( is => "rw", default => sub { File::Temp->newdir( 'pgtest.XXXXX', CLEANUP => $ENV{TEST_POSTGRESQL_PRESERVE} ? undef : 1, EXLOCK => 0, TMPDIR => 1 ); }, coerce => fun ($newval) { # Ensure base_dir is absolute; usually only the case if the user set it. # Avoid munging objects such as File::Temp ref $newval ? $newval : File::Spec->rel2abs($newval); }, ); TEST test(<<'TEST'); # ZMUGHAL/Renard-Curie-0.001/lib/Renard/Curie/Component/LogWindow.pm use Function::Parameters; method log( (Str) :$category, (Str) :$level, (Str) :$message ) { $self->add_log( { category => $category, level => $level, message => $message } ); my $buffer = $self->builder->get_object('log-text')->get_buffer; $buffer->insert( $buffer->get_end_iter, sprintf("[%s] {%s} %s\n", $level, $category, $message ) ); $self->_scroll_log_textview_to_end; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/utf8.t0000644000175100017510000004632114001101046022256 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # LAWALSH/P-1.1.34/lib/P.pm { package P; use warnings; use strict;use mem; our $VERSION='1.1.34'; # RCS $Revision: 1.45 $ - $Date: 2015-12-14 12:09:03-08 $ # 1.1.34 - Compensating for odd Strawberry Perl var-values... # 1.1.33 - Trying to Compensate for Strawberry Perl bugs... # 1.1.32 - Change FAILS in 1.1.31 for bad env's to "skips" # 1.1.31 - More pruning of bad test environments # 1.1.30 - Attempt to prune unsupported OS's (WinXP) # 1.1.29 - sprintf broken: include zero-width string spec to workaround # 1.1.28 - testsuite fix - unknown failure case in sprintf: # "Redundant argument in sprintf "... for "return sprintf $fmt, $v"; # Trying parens around sprintf($fmt, $v); # (shot in dark for strawberry win32 perl on win10...) # 1.1.27 - test fix -- Makefile.PL improperly specified "test", rather # rather than using t/*.*t as pattern # 1.1.26 - add code to allow changing defaults for literals and run-time # constants previously only accessible through the OO method # - Allow setting defaults globally as well as per-package # - fix for bug in testcase 5 in "P.t" in some later versions # of Strawberry Perl (5.22, 5.20?). Where the perlvar '$^X' # contained a win32-backslash-separated path to perl. In double # quotes, the backslashes are removed as literalizing the next # character. Changing the path usage to not have double-quotes # around the path should prevent the backslash-removal and pass # the literal string to the perl 'system' call. # 1.1.25 - put initial POD w/VERSION @ top to keep version #'s together # - remove BEGIN that was needed for running/passing tests # and instead use 'mem' # - move changelog to column one and use vim markers to hide # older changes # - add dflts hash to allow 'use' time change of defaults (W.I.P.) # - split local define+assignment ~#283 due to side effects # 1.1.24 - respin for another Makefile change # 1.1.23 - respin for a Makefile change # 1.1.22 - respin to use alt version format # 1.1.21 - respin to have BUID_REQ include more modern Ext:MM # 1.1.20 - respin to have Makefile rely on Xporter 1.0.6 # 1.1.19 - Prereqs not being loaded in Cpantesters; attempt fix # 1.1.18 - Unreported bugfix: # the words HASH & ARRAY were sometimes printed in ref notation # - remove included 'Types' code to use Types::Core (now published) # 1.1.17 - Documentation refinements/fixes; Found possible culprit as to # why Windows native tests could fail -- my source files in # lib have pointed back to my real lib dir via a symlink. # Windows wouldn't like those. Why any other platform did is # likely some fluke of directory organization during test # 1.1.16 - Different shot in dark to see if a change in P.env can make # things work on Win-native # 1.1.15 - Shot in dark to get 5.8.x to work(5.10 and newer seem to # be working! # 1.1.14 - and write out buffer from editor! (arg!) # 1.1.13 - get perl w/ ^X rather than config # 1.1.12 - Found another potential problem in the test prog. # 1.1.11 - May have found another test bug.... trying fix for some fails # 1.1.10 - Another internal format error bug (unreported), but caught # in testing. # 1.1.9 - Try to fix paths for test # 1.1.8 - use ptar to generate Archive::tar compat archives # 1.1.7 - Fix Makefile.PL # 1.1.6 - Use t/P.env for premodifying ENV # Document effect of printing to a FH & recording return val; # 1.1.5 - Distribution change: use --format=v7 on tar to produce tarball # (rt#90165) # - Use shell script to preset env for test since # Test::More doesn't set ENV # 1.1.4 - Quick patch to enable use of state w/CORE::state # 1.1.3 - [#$@%&!!!] # 1.1.2 - Second try for test in P.t to get prereq's right # 1.1.1 - Fix rest of (rt#89050) # 1.1.0 - Fixed Internal bug#001, below & embedded \n@end of int. str # (rt#89064) # Version history continued... #{{{ # 1.0.32 - Fix double nest test case @{[\*STDERR, ["fmt:%s", "string"]]} # (rt#89056) # only use sprintf's numeric formats (e.g. %d, %f...) on # numbers supported by sprintf (for now only arabic numerals). # Otherwise print as string. (rt#89063) # its numeric formats (ex "%d", "%f"...) # 1.0.31 - Fix check for previously printed items to apply only to # - the current output statement; # 1.0.30 - Fix LF suppression -- instead of suppressing EOL, suppressed # all output in the case where no FD was specified (code was # confused in deciding whether or not to suppress output and # return it as a string. (rt#89058) # - Add missing quote in Synopsis (rt#89047) # - Change NAME section to reference module following CPAN # standard to re-list name of module instead of functions # (rt#89046) # - Fix L<> in POD that referenced "module" P::P instead of name, "P" # (forms bad link in HTML) (rt#89051) # - Since ($;@) prototypes cause more problems than (@), clean p # proto's to use '@'; impliciation->remove array variations # (rt@89052, #89055) (rt#89058) # - fix outdated and inconsistent doc examples regarding old protos # (rt#89056)(rt#89058) # Had broken P's object oriented flag passing in adding # the 'seen' function (to prevent recursive outptut. Fixed this # while testing that main::DATA is properly closed (rt#89057,#89067) # - Internal Bug #001 # #our @a = ("Hello %s", "World"); # #P(\*STDERR, \@a); # # prints-> ARRAY(0x1003b40) # 1.0.29 - Convert to using 'There does not exist' sign (∄), U+2204 # instead of (undef); use '🔠' for recursion/repeat; # U+1F500 # 1.0.28 - When doing explicit out (FH specified), be sure to end # with newln. # 1.0.27 - DEFAULT change - don't do implicit IO reads (change via # impicit_io option) # - not usually needed in debugging or most output; # could cause problems # reading data from a file and causing desychronization problems; # 1.0.26 - detect recursive data structs and don't expand them # 1.0.25 - Add expansion for 'REF'; # - WIP: Trying to incorporate enumeration of duplicate adjacent # data: Work In Progress: status: disabled # 1.0.24 - limit default max string expanded to 140 chars (maybe want to # do this only in brace expansions?) Method to change in OOO # not documented at this time. NOTE: limiting output by default # is not a great idea. # 1.0.23 - When printing contents of a hash, print non-refs before # refs, and print each subset in alpha sorted order # 1.0.22 - Switch to {…} instead of HASH(0x12356892) or # […] for arrays # 1.0.21 - Doc change: added example of use in "die". # 1.0.20 - Rewrite of testcase 5 in self-execution; no external progs # anymore: use fork and print from P in perl child, then # print from FH in parent, including uses of \x83 to # inhibit extra LF's; # 1.0.19 - Regretting fancy thru 'rev' P direct from FH test case (a bit) # **seems** like some people don't have "." in path for test # cases, so running "t/prog" doesn't work, trying "./t/prog" # (1 fail on a Win32 base on a x64 system...so tempted # to just ignore it...) >;^); guess will up this for now # and think about that test case some more... # I'm so gonna rewrite that case! (see xtodox below) # 1.0.18 - convert top format-case statement to load-time compile # and see if that helps BSD errors; # - change test case w/array to use P & not old Pa-form # - change test case to print to STDERR to use Pe # - fix bug in decrement of $lvl in conditional (decrement must # be in first part of conditional) # - xtodox fix adaptation of 'rev' test case to work w/o # separate file(done) # 1.0.17 - another try at fixing pod decoding on metacpan # 1.0.16 - pod '=encoding' move to before '=head' # (ref:https://github.com/CPAN-API/metacpan-web/issues/800 ) # 1.0.15 - remove 'my $_' usage; old perl compat probs; use local # in once instance were needed local copy of $_ # 1.0.14 - arg! misspelled Win nul: devname(fixed) # 1.0.13 - test case change only to better test print to STDERR # 1.0.12 - test case change: change of OBJ->print to print OBJ to # try to get around problem on BSD5.12 in P.pm (worked!) # - change embedded test case to not use util 'rev', but # included perl script 'rev' in 't' directory...(for native win) # 1.0.11 - revert printing decimals using %d: dropped significant leading # zero's; Of NOTE: floating point output in objects is # not default: we use ".2f" # - left off space after comma in arrays(fixed) # - rewrite of sections using given/when/default to not use # them; try for 5.8 compat # - call perl for invoking test vs. relying on #! invokation # - pod updates mentioning 'ops'/depth # 1.0.10 - remove Carp::Always from test (wasn't needed and caused it # to fail on most test systems) # add OO-oriented way to set internal P ops (to be documented) # - fixed bug in logic trimming recursion depth on objects # 1.0.9 - Add Px - recursive object print in squished form; # Default to using Px for normal print # 1.0.8 - fix when ref to IO -- wasn't dereferenced properly # - upgrade of self-test/demo to allow specifying which test # to run from cmd line; test numbers are taken from # the displayed examples when run w/no arguments # B:still doesn't run cleanly under test harness may need to # change cases for that (Fixed) # - POD update to current code # 1.0.7 - (2013-1-9) add support for printing blessed objects # - pod corrections # - strip added LF from 'rev' example with tr (looks wrong) # 1.0.6 - add manual check for LF at end (chomp doesn't always work) # 1.0.5 - if don't recognize ref type, print var # 1.0.4 - added support for printing contents of arrays and hashes. # (tnx 2 MidLifeXis@prlmnks 4 brain reset) # 1.0.3 - add Pea # 1.0.2 - found 0x83 = "no break here" -- use that for NL suppress # - added support for easy inclusion in other files # (not just as lib); # - add ISA and EXPORT to 'mem' so they are available @ BEGIN time # # 1.0.1 - add 0xa0 (non breaking space) to suppress NL # #}}} use utf8; our (@ISA, @EXPORT); # no sense to support iohandle w/Pe, as Pe is tied to stderr { no warnings "once"; *IO::Handle::P = \&P::P } use Types::Core; use mem(@EXPORT=qw(P Pe)); use Xporter; my $ignore=<<'IGN' #{{{ BEGIN { use constant EXPERIMENTAL=>0; if (EXPERIMENTAL) { sub rm_adjacent { my $c = 1; ($a, $c) = @$a if ref $a; $b //= "∄"; if ($a ne $b) { $c > 1 ? "$a × $c" : $a , $b } else { (undef, [$a, ++$c]) } } sub reduce(&@) { my (@final, $i) =((), 0); my ($f, $ar)=@_; for (my $i=0; $i < $#$ar; ++$i ) { ($a, $b) = ($ar->[$i], $ar->[$i+1]); my @r = &$f; push @final, $r[0] if $r[0]; $ar->[$i+1] = $r[1]; } @final; } } } IGN ||undef; #}}} use constant NoBrHr => 0x83; # Unicode codepoint="No Break Here" our %_dflts; our ($dflts, %mod_dflts, %types); BEGIN { %_dflts=( implicit_io => 0, depth => 3, ellipsis => '…', noquote => 1, maxstring => undef, seen => 'ðŸ”', undef => '∄', ); my $bool = sub { $_[0] ? 1 : 0 }; my $intnum = sub { $_[0] =~ m{^([0-9]+)$} ? 0 + $1 : 0 }; my $string = sub { length($_[0]) ? $_[0] : '' }; my $true = sub { 1 }; %types=( default => $true, depth => $intnum, ellipsis => $string, implicit_io => $bool, maxstring => $intnum, seen => $string, undef => $string, ); #global default copy $mod_dflts{""} = \%_dflts; $dflts = $mod_dflts{""}; } sub sw(*); sub Px { my ($p, $v) = (shift, shift); local (*sw); *sw = sub (*) {$dflts->{$_[0]}}; if (ref $v) { if ($p->{__P_seen}{$v}) { return "*". sw(seen) . ":" . $v . "*" } else {$p->{__P_seen}{$v} = 1} } my $lvl = scalar @_ ? $_[0] : 2; my $ro = scalar @_>1 ? $_[1]:0; return sw('undef') unless defined $v; my $ref = ref $v; if (1 > $lvl-- || !$ref) { my $fmt; # prototypes are documentary (rt#89053) my $given = [ sub ($$) { $_[0] =~ /^[-+]?[0-9]+\.?\z/ && q{%s} }, sub ($$) { $_[1] && qq{%s}}, sub ($$) { 1 == length($_[0]) && q{'%s'}}, sub ($$) { $_[0] =~ m{^(?:[+-]?(?:\.[0-9]+) | (?:[0-9]+\.[0-9]+))\z}x && q{%.2f}}, sub ($$) { substr($_[0],0,5) eq 'HASH(' && '{'.sw(ellipsis).'}'.q{%.0s} }, sub ($$) { substr($_[0],0,6) eq 'ARRAY(' && '['.sw(ellipsis).']'.q{%.0s} }, # sub ($$) { $mxstr && length ($_[0])>$mxstr # && qq("%.${mxstr}s")}, sub ($$) { 1 && q{"%s"}} ]; do { $fmt = $_->($v, $ro) and last } for @$given; return sprintf($fmt, $v); } else { my $pkg = ''; ($pkg, $ref) = ($1, $2) if 0 <= (index $v,'=') && $v=~m{([\w:]+)=(\w+)}; local * nonrefs_b4_refs ; * nonrefs_b4_refs = sub { ref $v->{$a} cmp ref $v->{$b} || $a cmp $b }; local (*IO_glob, *NIO_glob, *IO_io, *NIO_io); (*IO_glob, *NIO_glob, *IO_io, *NIO_io) = ( sub(){'<*'.<$v>.'>'}, sub(){'<*='.$p->Px($v, $lvl-1).'>'}, sub(){'<='.<$v>.'>'}, sub(){'<|'.$p->Px($v, $lvl-1).'|>'}, ); no strict 'refs'; my %actions = ( GLOB => ($p->{implicit_io}? *IO_glob: *NIO_glob), IO => ($p->{implicit_io}? *IO_io : *NIO_io), REF => sub(){ "\\" . $p->Px($$_, $lvl-1) . ' '}, SCALAR=> sub(){ $pkg.'\\' . $p->Px($$_, $lvl).' ' }, ARRAY => sub(){ $pkg."[". (join ', ', # not working: why? #reduce \&rm_adjacent, (commented out) map{ $p->Px($_, $lvl) } @$v ) ."]" }, HASH => sub(){ $pkg.'{' . ( join ', ', @{[ map {$p->Px($_, $lvl, 1) . '=>'. $p->Px($v->{$_}, $lvl,0)} sort nonrefs_b4_refs keys %$v]} ) . '}' },); if (my $act=$actions{$ref}) { &$act } else { return "$v" } } } sub get_dflts($) { my $p = shift; my $caller = $_[0]; return $p->{dflts} if exists $p->{dflts}; return exists $mod_dflts{$caller} ? $mod_dflts{$caller} : $mod_dflts{""}; } sub P(@) { # 'safen' to string or FH or STDOUT local *sw = sub (*) {$dflts->{$_[0]}}; my $p = ref $_[0] eq 'P' ? shift: bless {}; $p->{__P_seen}={} unless ref $p->{__P_seen}; local * unsee_ret = sub ($) { delete $p->{__P_seen} if exists $p->{__P_seen}; $_[0] }; my $v = $_[0]; my $rv = ref $v; $dflts = $p->get_dflts((caller)[0]); my ($depth, $noquote) = (sw(depth), sw(noquote)); if (HASH eq $rv) { my $params = $v; $v = shift; $rv = ref $v; $depth = $params->{depth} if exists $params->{depth}; } if (ARRAY eq $rv ) { $v = shift; @_=(@$v, @_); $v=$_[0]; $rv = ref $v } my ($fh, $f, $explicit_out); if ($rv eq GLOB || $rv eq IO) { ($fh, $explicit_out) = (shift, 1); $v = $_[0]; $rv = ref $v; } else { $fh =\*STDOUT } if (ARRAY eq $rv ) { $v = shift; @_=(@$v, @_); $v=$_[0]; $rv = ref $v } my ($fc, $fmt, @flds, $res)=(1, $_[0]); if ($fc) { $f = shift; no warnings; $res = sprintf $f, map {local $_ = $p->Px($_,$depth,$noquote) } @_ } else { $res = $p->Px(@_)} chomp $res; my ($nl, $ctx) = ("\n", defined wantarray ? 1 : 0); ($res, $nl, $ctx) = (substr($res, 0, -1 + length $res), "", 2) if ord(substr $res,-1) == NoBrHr; #"NO_BREAK_HERE" if (!$fh && !$ctx) { #internal consistancy check ($fh = \*STDERR) and P $fh "Invalid File Handle presented for output, using STDERR"; ($explicit_out, $nl) = (1, "\n") } else { return unsee_ret($res) if (!$explicit_out and $ctx==1) } no warnings 'utf8'; print $fh ($res . (!$ctx && (!$\ || $\ ne "\n") ? "\n" : "") ); unsee_ret($res); }; sub Pe(@) { my $p = shift if ref $_[0]; return '' unless @_; unshift @_, \*STDERR; unshift @_, $p if ref $p; goto &P } #Pe "_dflts=%s", \%_dflts; #Pe "mod_dflts{}=%s", $mod_dflts{""}; #Pe "mod_dflts=%s", \%mod_dflts; sub import { my ($modname, @args) = @_; if (@args) { my @others; my $caller = (caller)[0]; if (exists $mod_dflts{$caller}) { $dflts = $mod_dflts{$caller}; } else { $dflts = undef; # indicate no customization to dflts } my $default = 0; my @tags = grep { if (m{^:(.*)$}) { if ($1 eq 'default') { $default = 1; $_ = undef } else { $_ = $1 } } else { push @others, $_; undef } } @args; if (@tags) { if ($default) { # change global defaults (don't use copy) $dflts = $mod_dflts{""}; } else { # if dflts was undef start w/copy of glbl-dflts %{$mod_dflts{$caller}} = %{$mod_dflts{""}} unless exists $mod_dflts{$caller}; $dflts=$mod_dflts{$caller} } for (@tags) { my ($tag, $value) = m{^(\w+)(?:=(.+))?$} or die "Tag-format: missing :TAG=VALUE for tag '" . $_ . "'"; my $chk; {no warnings; no strict; $chk = eval $types{$tag}->($value) }; $dflts->{$tag} = $chk; } } $dflts = $mod_dflts{""} unless $dflts; # set to global if not set @_=($modname, @others); } goto &Xporter::import; } sub ops($) { my $p = shift; my $c=ref $p || $p; bless $p = {}, $c unless ref $p; my $args = $_[0]; my $ldflts = $p->get_dflts((caller)[0]); %{$p->{dflts}} = %$dflts unless ref $p->{dflts}; die "ops takes a hash to pass arguments" unless HASH $args; $ldflts = $p->{dflts}; foreach (sort keys %$args) { if (exists $ldflts->{$_}) { $ldflts->{$_} = $args->{$_} } else { warn "Unknown key \"$_\" passed to ops";} } $p } 1;} #value 1 placed at as w/most of my end-of-packages (rt#89054) TEST test(<<'TEST'); # MCHE/Mojolicious-Che-0.031/lib/Mojolicious/Che.pm package Mojolicious::Che; use Mojo::Base::Che 'Mojolicious'; use Mojo::Log::Che; use Mojo::Loader qw(load_class); ... sub хазы { # Хазы из конфига my $app = shift; my $conf = $app->config; my $h = $conf->{'mojo_has'} || $conf->{'mojo'}{'has'} || $conf->{'хазы'}; map { $app->log->debug("Make the app->has('$_')"); has $_ => $h->{$_}; } keys %$h; } TEST test(<<'TEST'); # MCHE/Mojolicious-Plugin-RoutesAuthDBI-0.785/lib/Mojolicious/Plugin/RoutesAuthDBI/OAuth2.pm package Mojolicious::Plugin::RoutesAuthDBI::OAuth2; use Mojo::Base 'Mojolicious::Controller'; use Mojolicious::Plugin::RoutesAuthDBI::Util qw(json_enc load_class); ... sub отÑоединить { my $c = shift; my $site_name = $c->stash('site'); my $site = $c->oauth2->providers->{$site_name} or die "No such oauth provider [$site_name]" ; my $curr_profile = $c->curr_profile; my $r = $c->_model->detach($site->{id}, $curr_profile->{id},); #~ $c->app->log->debug("Убрал авторизацию Ñайта [$site_name] Ð¿Ñ€Ð¾Ñ„Ð¸Ð»Ñ [$curr_profile->{id}]", $c->dumper($r)); $Init->plugin->model->{Refs}->del($r->{ref_id}, undef, undef); $c->redirect_to($c->param('redirect') || 'profile'); } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/data.t0000644000175100017510000000057314001101046022300 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::scan::Util; test(<<'TEST'); # PHILCROW/Bigtop-0.38/lib/Bigtop/Parser.pm sub build_lookup_hash { my $self = shift; return [ { __TYPE__ => 'schema', __DATA__ => [ $self->{__NAME__} => $self->{__IDENT__} ], } ]; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/syntax/0000755000175100017510000000000014422514733022545 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/scan/syntax/qs.t0000644000175100017510000000264014001101046023335 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../../"; use Test::More; use t::scan::Util; test(<<'END'); # CSSON/OpenGbg-0.1402/lib/OpenGbg/Service/AirQuality/Measurement.pm use syntax 'qs'; sub air_quality_to_text { my $self = shift; no warnings 'numeric'; return sprintf qs{ Total index: [ %4s ] [ %-16s ] Nitrogen dioxide: %7.2f %s [ %4s ] [ %-16s ] Nitrogen oxides: %7.2f %s [ %4s ] [ %-16s ] Sulfur dioxide: %7.2f %s [ %4s ] [ %-16s ] Carbon monoxide: %7.2f %s [ %4s ] [ %-16s ] Ground level ozone: %7.2f %s [ %4s ] [ %-16s ] <10mm particulates: %7.2f %s [ %4s ] [ %-16s ] <2.5mm particulates: %7.2f %s [ %4s ] [ %-16s ] }, $self->total_index, $self->total_levels, $self->no2, $self->no2_unit, $self->no2_index, $self->no2_levels, $self->so2, $self->so2_unit, $self->so2_index, $self->so2_levels, $self->o3, $self->o3_unit, $self->o3_index, $self->o3_levels, $self->pm10, $self->pm10_unit, $self->pm10_index, $self->pm10_levels, $self->co, $self->co_unit, $self->co_index, $self->co_levels, $self->nox, $self->nox_unit, $self->nox_index, $self->nox_levels, $self->pm2_5, $self->pm2_5_unit, $self->pm2_5_index, $self->pm2_5_levels, ; } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/elem.t0000644000175100017510000000310314001101046022301 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # MAKAROW/ARSObject-0.57/lib/ARSObject.pm sub cgitfrm { # table form layot # -form =>{form attrs}, -table=>{table attrs}, -tr=>{tr attrs}, -td=>{}, -th=>{} my ($s, %a) =$_[0]; my $i =1; while (ref($_[$i]) ne 'ARRAY') {$a{$_[$i]} =$_[$i+1]; $i +=2}; $s->cgi->start_form(-method=>'POST',-action=>'', $a{-form} ? %{$a{-form}} : ()) # ,-name=>'test' .$s->{-cgi}->table($a{-table} ? $a{-table} : (), "\n" .join('' , map { my $r =$_; $s->{-cgi}->Tr($a{-tr} ? $a{-tr} : (), "\n" .join('' , map { ($_ =~/^{-cgi}->td($a{-td} || {-align=>'left', -valign=>'top'}, $_) : $s->{-cgi}->th($a{-th} || $a{-td} || {-align=>'left', -valign=>'top'}, $_) ) ."\n" } @$r) ) ."\n" } @_[$i..$#_])) ."\n" .$s->cgi->end_form() } TEST test(<<'TEST'); # BRICAS/Games-NES-Emulator-0.03/lib/CPU/Emulator/6502/Op/DEY.pm sub dey { my $self = shift; my $reg = $self->registers; $reg->{ y } = ( $reg->{ y } - 1 ) & 0xff; $self->set_nz( $reg->{ y } ); } TEST test(<<'TEST'); # ANNO/Vi-QuickFix-1.134/lib/Vi/QuickFix.pm unless ( caller ) { # process <> if called as an executable exec_mode(1); # signal fact ( to END processing) require Getopt::Std; Getopt::Std::getopts( 'q:f:v', \ my %opt); print "$0 version $VERSION\n" and exit 0 if $opt{ v}; err_open( $opt{ q} || $opt{ f}); print && err_out( $_) while <>; exit; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/print.t0000644000175100017510000001504614001101046022524 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # DAMI/Alien-GvaScript-1.44/GvaScript_Builder.pm sub generate_js { # concatenates sources below into "GvaScript.js" my ($self) = @_; require "lib/Alien/GvaScript.pm"; my @sources = qw/protoExtensions event keyMap treeNavigator choiceList autoCompleter customButtons paginator grid repeat form/; my $dest = "lib/Alien/GvaScript/lib/GvaScript.js"; chmod 0777, $dest; open my $dest_fh, ">$dest" or die "open >$dest : $!"; print $dest_fh <<__EOJS__; /*-------------------------------------------------------------------------* * GvaScript - Javascript framework born in Geneva. * * Authors: Laurent Dami * Mona Remlawi * Jean-Christophe Durand * Sebastien Cuendet * LICENSE * This library is free software, you can redistribute it and/or modify * it under the same terms as Perl's artistic license. * *--------------------------------------------------------------------------*/ var GvaScript = { Version: '$Alien::GvaScript::VERSION', REQUIRED_PROTOTYPE: '1.7', load: function() { function convertVersionString(versionString) { var v = versionString.replace(/_.*|\\./g, ''); v = parseInt(v + '0'.times(4-v.length)); return versionString.indexOf('_') > -1 ? v-1 : v; } if((typeof Prototype=='undefined') || (typeof Element == 'undefined') || (typeof Element.Methods=='undefined') || (convertVersionString(Prototype.Version) < convertVersionString(GvaScript.REQUIRED_PROTOTYPE))) throw("GvaScript requires the Prototype JavaScript framework >= " + GvaScript.REQUIRED_PROTOTYPE); } }; GvaScript.load(); __EOJS__ foreach my $sourcefile (@sources) { open my $fh, "src/$sourcefile.js" or die $!; print $dest_fh "\n//----------$sourcefile.js\n", <$fh>; } } sub generate_html {# regenerate html doc from pod sources my ($self) = @_; require Pod::POM; require Pod::POM::View::HTML; my @podfiles = glob ("lib/Alien/GvaScript/*.pod"); my $parser = new Pod::POM; foreach my $podfile (@podfiles) { my $pom = $parser->parse($podfile) or die $parser->error; $podfile =~ m[^lib/Alien/GvaScript/(.*)\.pod]; my $htmlfile = "doc/html/$1.html"; print STDERR "converting $podfile ==> $htmlfile\n"; open my $fh, ">$htmlfile" or die "open >$htmlfile: $!"; print $fh Pod::POM::View::HTML::GvaScript->print($pom); close $fh; } return 1; } sub generate_googlewiki {# regenerate wiki doc from pod sources my ($self) = @_; require Pod::Simple::Wiki; require Pod::Simple::Wiki::Googlecode; # destination for wiki files my $dir = "blib/wiki"; -d $dir or mkdir $dir or die "mkdir $dir: $!"; # list of source files my @podfiles = glob ("lib/Alien/GvaScript/*.pod"); # convert each file foreach my $podfile (@podfiles) { my $parser = Pod::Simple::Wiki->new('googlecode'); $podfile =~ m[^lib/Alien/GvaScript/(.*)\.pod]; my $wikifile = "$dir/$1.wiki"; open my $fh, ">$wikifile" or die "open >$wikifile: $!"; print STDERR "converting $podfile ==> $wikifile\n"; $parser->output_fh($fh); $parser->parse_file($podfile); } return 1; } 1; #====================================================================== package Pod::POM::View::HTML::GvaScript; #====================================================================== use strict; use warnings; use base 'Pod::POM::View::HTML'; sub _title_to_id { my $title = shift; $title =~ s/<.*?>//g; # no tags $title =~ s/\W+/_/g; return $title; } sub view_pod { my ($self, $pod) = @_; my $doc_title = ($pod->head1)[0]->content->present($self); $doc_title =~ s/<.*?>//g; # no tags my ($name, $description) = split /\s+-\s+/, $doc_title; my $content = $pod->content->present($self); my $toc = $self->make_toc($pod, 0); return <<__EOHTML__

$name

$description

Table of contents

$toc
$content
__EOHTML__ } # installing same method for view_head1, view_head2, etc. BEGIN { for my $num (1..6) { no strict 'refs'; *{"view_head$num"} = sub { my ($self, $item) = @_; my $title = $item->title->present($self); my $id = _title_to_id($title); my $content = $item->content->present($self); my $h_num = $num + 1; return <<__EOHTML__
$title
$content
__EOHTML__ } } } sub make_toc_orig { my ($self, $item, $level) = @_; my @nodes; my $method = "head" . ($level + 1); my $sub_items = $item->$method; foreach my $sub_item (@$sub_items) { my $title = $sub_item->title->present($self); my $id = _title_to_id($title); my $node_html = qq{$title} . $self->make_toc($sub_item, $level + 1); push @nodes, $node_html; } my $html = join "", map {"
  • $_
    • "} @nodes; return $html ? "
      $html
    " : ""; } sub make_toc { my ($self, $item, $level) = @_; my @nodes; my $method = "head" . ($level + 1); my $sub_items = $item->$method; foreach my $sub_item (@$sub_items) { my $title = $sub_item->title->present($self); my $id = _title_to_id($title); my $node_content = $self->make_toc($sub_item, $level + 1); my $class = $node_content ? "TN_node" : "TN_leaf"; my $node_html = <<__EOHTML__;
    $title
    $node_content
    __EOHTML__ push @nodes, $node_html; } my $html = join "", @nodes; return $html; } 1; TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/moosex_declare/0000755000175100017510000000000014422514733024210 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/scan/moosex_declare/with_newline.t0000644000175100017510000000032614001101046027050 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../../"; use Test::More; use t::scan::Util; test(<<'END'); use MooseX::Declare; class dongs { } class mtfnpy extends dongs { } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/moosex_declare/attribute_issues.t0000644000175100017510000000060114001101046027746 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../../"; use Test::More; use t::scan::Util; test(<<'END'); use MooseX::Declare; class UnderTest { method pass_through (:$param?) { $param; } method pass_through2 (:name($value)?) { $value; } method pass_through3 ($value?) { $value || 'default'; } } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/moosex_declare/parameterized_role.t0000644000175100017510000000122314001101046030226 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../../"; use Test::More; use t::scan::Util; test(<<'END'); use MooseX::Declare; role Counter (Str :$name, Int :$charges = 1) { has $name => (is => 'rw', isa => 'Int', default => $charges); method "increment_${name}" { $self->$name($self->$name + 1); } method "reset_${name}" { $self->$name(0); } } class MyGame::Weapon { with Counter => { name => 'enchantment', charges => 5 }; } class MyGame::Wand { with Counter => { name => 'zapped', charges => 3 }; } class MyGame::Scroll { with Counter => { name => 'spelled' }; } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/comment.t0000644000175100017510000000031314001101046023021 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::scan::Util; test(do { my $code = <<'TEST'; chomp $code; $code }); # comment without eol TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/qr.t0000644000175100017510000000161514001101046022007 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # SPROUT/HTML-DOM-0.056/lib/HTML/DOM.pm sub base { my $doc = shift; if( my $base_elem = $doc->look_down(_tag => 'base', href => qr)(?:\))) ){ return ''.$base_elem->attr('href'); } else { no warnings 'uninitialized'; ''.base{$$doc{_HTML_DOM_response}||return$doc->URL} } } TEST test(<<'TEST'); # SPROUT/WWW-Scripter-0.031/lib/WWW/Scripter.pm if(!CORE::length $name and my $doc = document $self) { if(my $base_elem = $doc->look_down(_tag => 'base', target => qr)(?:\)))){ $name = $base_elem->attr('target'); } } TEST test(<<'TEST'); # SPROUT/WWW-Scripter-0.031/lib/WWW/Scripter.pm if(!CORE::length $name and my $doc = document $self) { if(my $base_elem = $doc->look_down(_tag => 'base', target => qr)(?:\)))){ $name = $base_elem->attr('target'); } } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/tt.t0000644000175100017510000000146514001101046022017 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::scan::Util; test(<<'TEST'); # NEKOKAK/DBIx-Class-StorageReadOnly-0.05/lib/DBIx/Class/StorageReadOnly/TT.pm package DBIx::Class::Storage::DBI; use tt (subs => [qw/insert update delete/]); [% FOR sub IN subs %] { no warnings 'redefine'; no strict 'refs'; ## no critic my $[%- sub -%]_code_org = DBIx::Class::Storage::DBI->can('[%- sub -%]'); *{"DBIx\::Class\::Storage\::DBI\::[%- sub -%]"} = sub { my $self = shift; if ($self->_search_readonly_info) { croak("This connection is read only. Can't [%- sub -%]."); } return $self->$[%- sub -%]_code_org(@_); }; } [% END %] no tt; TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/sub.t0000644000175100017510000002125714001101046022162 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # INGY/YAML-Full-0.0.1/lib/YAML/Full/Base.pm no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.::.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};use constant XXX_skip=>1;my$dm='YAML::XS';*{$M.'xxx::e'}=sub{my($P,$e)=@_;$e->{WWW}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::WWW(@_)};$e->{XXX}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::XXX(@_)};$e->{YYY}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::YYY(@_)};$e->{ZZZ}=sub{require XXX;local$XXX::DumpModule=$dm}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};*{$M.'nonlazy::e'}=sub{${shift.':N'}=1};@f=qw[build default builder xxx import nonlazy];use strict;use warnings; TEST test(<<'TEST'); # TYEMQ/Acme-ESP-1.002007/ESP.pm sub O'o { [ shift,oO( @_ ) ]->[!$[] } package Acme::ESP::Scanner; use overload( '.' => \&scan, nomethod => \&explode, ); TEST test(<<'TEST'); # YAPPO/Class-Component-0.17/t/MyClass/Plugin/ExtAttribute.pm sub args_0 :Method Dump {} sub args_1 :Method Dump('hoge') {} sub args_1_2 :Method Dump("hoge") {} sub args_2 :Method Dump('hoge1', 'hoge2') {} sub args_2_2 :Method Dump('hoge1', "hoge2") {} sub args_2_3 :Method Dump("hoge1", 'hoge2') {} sub args_2_4 :Method Dump("hoge1", "hoge2") {} sub args_2_5 :Method Dump(qw(hoge1 hoge2)) {} sub args_2_6 :Method Dump(qw/hoge1 hoge2/) {} sub ref_array_1 :Method Dump([1,2,3,4]) {} sub ref_array_2 :Method Dump([qw/1 2 3 4/]) {} sub ref_array_3 :Method Dump([qw(1 2 3 4)]) {} sub ref_array_4 :Method Dump(["1",'2','3',"4"]) {} sub ref_array_5 :Method Dump(['1', '2', '3', '4']) {} sub ref_array_6 :Method Dump(["1", "2", "3", "4"]) {} sub hash_1 :Method Dump(key=>'value') {} sub ref_hash_1 :Method Dump({ key => 'value' }) {} sub ref_hash_2 :Method Dump({ key => { key => 'value' } }) {} sub ref_hash_array :Method Dump({ key => [qw/ foo bar baz /] }) {} sub ref_array_hash_1 :Method Dump([ 'foo', { key => 'value' }, 'baz' ]); sub ref_array_hash_2 :Method Dump('foo', { key => 'value' }, 'baz'); sub ref_code_1 :Method Dump(sub { return 'code' }->()) {} sub ref_code_2 :Method Dump(sub { _code }->()) {} sub ref_code_3 :Method Dump(sub { _code2 4, 5 }->()) {} sub run_code_1 :Method DumpRun(sub { return 'code' }) {} sub run_code_2 :Method DumpRun(sub { _code }) {} sub run_code_3 :Method DumpRun(sub { _code2 4, 5 }) {} TEST test(<<'TEST'); # ZEFRAM/Debug-Show-0.000/lib/Debug/Show.pm sub debug_hide { } cv_set_call_checker(\&debug_hide, sub ($$$) { my($entersubop, undef, undef) = @_; # B::Generate doesn't offer a way to explicitly free ops. # We ought to be able to implicitly free $entersubop via constant # folding, by something like # # return B::LOGOP->new("and", 0, # B::SVOP->new("const", 0, !1), # $entersubop); # # but empirically that causes memory corruption and it's not # clear why. For the time being, leak $entersubop. return B::SVOP->new("const", 0, !1); }, \!1); TEST test(<<'TEST'); # STEVEB/Devel-Trace-Subs-0.22/lib/Devel/Trace/Subs.pm push @{$data->{stack}}, { in => (caller(1))[3] || '-', package => (caller(1))[0] || '-', sub => (caller(2))[3] || '-', filename => (caller(1))[1] || '-', line => (caller(1))[2] || '-', }; TEST test(<<'TEST'); # JRED/CIPP-2.50/lib/CIPP.pm sub Chunk_Out { # # INPUT: 1. Referenz auf Chunk # 2. Befindet Parser sich in einem PRINT Statement # 3. wie soll der Chunk ausgegeben werden: # 1 als print Befehl # 0 unver?ndert # -1 mit Escaping von } Zeichen (f?r Variablenzuweisung) # 4. Start-Zeilennummer des Chunks # 5. Ende-Zeilennummer des Chunks # # OUTPUT: - # my $self = shift; my ($chunk_ref, $in_print_statement, $gen_print, $from_line) = @_; my $output = $self->{output}; if ( $$chunk_ref ne '' && $$chunk_ref =~ /[^\r\n\s]/ ) { # Chunk ist nicht leer my $context = $self->{context_stack}-> [@{$self->{context_stack}}-1]; if ( $context eq 'html' or $context eq 'force_html' ) { if ( ($gen_print and $context eq 'html') or $context eq 'force_html' ) { # HTML-Context: es wird ein print qq[] Befehl # generiert # ggf. Debugging-Code erzeugen $output->Write ( "\n\n\n\n# cippline $from_line ".'"'. $self->{call_path}.'"'."\n" ); # Chunk muss via print ausgegeben werden $output->Write ("print qq["); $$chunk_ref =~ s/\[/\\\[/g; $$chunk_ref =~ s/\]/\\\]/g; $output->Write ($$chunk_ref); $output->Write ("];\n"); } } elsif ( $context eq 'perl' ) { # Context # Chunk wird unveraendert uebernommen $output->Write ($$chunk_ref); } elsif ( $context eq 'var' ) { # Context # Chunk wird mit escapten } uebernommen $$chunk_ref =~ s/\}/\\\}/g; $output->Write ($$chunk_ref); } elsif ( $context eq 'comment' ) { # Hier machen wir nix. } else { die "Unknown context '$context'"; } } } TEST test(<<'TEST'); # JWALT/Apache-AxKit-Plugin-Session-1/lib/AxKit/XSP/Auth.pm sub check_permission : XSP_attribOrChild(target,reason) XSP_childStruct($text(lang)) { return 'if (do {'.has_permission(@_).'}) { '.deny_permission(@_).' }'; } TEST test(<<'TEST'); # AWWAIID/Continuity-1.6/lib/Continuity.pm my $self = bless { docroot => '.', # default docroot mapper => undef, adapter => undef, debug_level => 1, debug_callback => sub { print STDERR "@_\n" }, reload => 1, # XXX callback => (exists &{caller()."::main"} ? \&{caller()."::main"} : undef), staticp => sub { $_[0]->url =~ m/\.(jpg|jpeg|gif|png|css|ico|js)$/ }, no_content_type => 0, reap_after => undef, allowed_methods => ['GET', 'POST'], @_, }, $class; TEST test(<<'TEST'); # TODDR/Net-Ident-1.24/Ident.pm print STDDBG "Net::Ident::newFromInAddr localaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } ->( sockaddr_in($localaddr) ), ", remoteaddr=", sub { inet_ntoa( $_[1] ) . ":$_[0]" } ->( sockaddr_in($remoteaddr) ), ", timeout=", defined $timeout ? $timeout : "", "\n" if $DEBUG > 1; TEST test(<<'TEST'); # MIK/CryptX-0.028/lib/Crypt/PRNG.pm { ### stolen from Bytes::Random::Secure # # Instantiate our random number generator(s) inside of a lexical closure, # limiting the scope of the RNG object so it can't be tampered with. my $RNG_object = undef; my $fetch_RNG = sub { # Lazily, instantiate the RNG object, but only once. $RNG_object = Crypt::PRNG->new unless defined $RNG_object && ref($RNG_object) ne 'SCALAR'; return $RNG_object; }; sub rand(;$) { return $fetch_RNG->()->double(@_) } sub irand() { return $fetch_RNG->()->int32() } sub random_bytes($) { return $fetch_RNG->()->bytes(@_) } sub random_bytes_hex($) { return $fetch_RNG->()->bytes_hex(@_) } sub random_bytes_b64($) { return $fetch_RNG->()->bytes_b64(@_) } sub random_bytes_b64u($) { return $fetch_RNG->()->bytes_b64u(@_) } sub random_string_from($;$) { return $fetch_RNG->()->string_from(@_) } sub random_string(;$) { return $fetch_RNG->()->string(@_) } } TEST test(<<'END'); # MIKER/Net-DNS-Dig-0.12/Dig.pm sub for($$$) { ... } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/if.t0000644000175100017510000000042414001101046021760 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # ETHER/Pod-Coverage-Moose-0.07/t/lib/TestOverload.pm use if !eval { require Moose; Moose->VERSION('2.1300') }, 'MooseX::Role::WithOverloading'; TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/keyword_declare.t0000644000175100017510000000434714001101046024535 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::scan::Util; test(<<'TEST'); # DCONWAY/Keyword-Declare-0.001009/dlib/Multilingual/Code.pm use Keyword::Declare; sub import { keytype Blocklike is / (?= \{ ) (?&PPR_quotelike_body) /; our $next_anon = 'ANON00000001'; keyword ANSI_C (Blocklike $block) { my ($c_params, $perl_args) = (q{}, q{}); my $anon_sub = $Multilingual::Code::next_anon++; my %seen; $block =~ s{\$(\w+)}{ if (!$seen{$1}++) { $c_params .= "char* $1,"; $perl_args .= "\$$1,"; } $1 }gexms; $c_params =~ s{,$}{}; return qq[ use Inline C => q{void $anon_sub ($c_params) $block}; $anon_sub($perl_args); ]; } keyword PYTHON (Blocklike $block) { use List::Util 'minstr'; my ($py_params, $perl_args) = (q{}, q{}); my $anon_sub = $Multilingual::Code::next_anon++; my %seen; $block =~ s{\A \{ | \} \Z}{}gx; my $prefix = minstr( grep {defined} $block =~ m{^(\h+)}gcxms ); $block =~ s{^$prefix}{}gm; $block =~ s{(? [\$\@] ) (? \w+ ) } { my %var = %+; if (!$seen{$var{name}}++) { $py_params .= "$var{name},"; $perl_args .= '\\' if $var{sigil} eq '@'; $perl_args .= "$var{sigil}$var{name},"; } $var{name} }gexms; $py_params =~ s{,$}{}; my ($defs, $execs) = (q{}, q{}); for my $construct (split m{^(?=\S)}xm, $block) { if ($construct =~ /\A\s*def\b/) { $defs .= $construct; } else { $execs .= $construct; } } $execs =~ s{^}{ }gm; return ($defs =~ /\S/ ? qq[ use Inline Python => q{$defs}; ] : q{}) . ($execs =~ /\S/ ? qq[ use Inline Python => q{def $anon_sub($py_params):\n$execs}; $anon_sub($perl_args); ] : q{}); } keyword LATIN (Blocklike $code) { use Lingua::Romana::Perligata (); local $_ = substr($code, 1, -2); Lingua::Romana::Perligata::filter(); return "{no strict; no warnings; $_}"; } } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/variable.t0000644000175100017510000000475114001101046023156 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # CHORNY/Win32API-File-0.1203/File.pm my $tied = !defined($^]) || $^] < 5.008 ? eval "tied *{$file}" : tied *{$file}; TEST test(<<'TEST'); # JV/mmds-1.902/MMDS/Common.pm sub ::loadpkg { my ($pkg, $package) = @_; $package ||= caller; $pkg = $package . "::" . $pkg unless $pkg =~ /::/; $pkg =~ s/::::/::/g; warn("Loading: $pkg\n") if $::trace; my $ok = eval("require $pkg"); die(@$) if @$; die("Error loading $pkg\n") unless $ok; } TEST test(<<'TEST'); # MSISK/Net-Nmsg-0.15/lib/Net/Nmsg/Layer.pm sub _fake_stat { my $self = shift; return unless $self->opened; return 1 unless wantarray; return ( undef, # dev undef, # ino 0666, # mode 1, # links $>, # uid $), # gid undef, # did 0, # size undef, # atime undef, # mtime undef, # ctime 0, # blksize 0, # blocks ); } TEST test(<<'TEST'); # sub next { my $self = shift; my @objects = @{${$self}[1]}; my @return; local @_h = @_; my $pre = $self->pre; if (defined($pre)) { @_h = &{$pre}($self, @_); } my $status = 1; my $obj; local @_s; OBJ:foreach $obj (@objects) { # sub-objects @return = $$obj->next(@_h); if (not $$obj->status) { $status = 0; last OBJ; } else { push(@_s, @return) if $#return >= 0; } } if ($status) { $self->status(1); my $post = $self->post; if (defined($post)) { &{$post}($self, @_s); } else { @_s; } } else { $self->status(0); (); } } TEST test(<<'TEST'); # SPROUT/CSS-DOM-0.16/lib/CSS/DOM/PropertyParser.pm my $list = shift @'_; my $sep = @$list <= 1 ? '' : do { my $range_start = $$list[0][4]; my $range_end = $$list[1][4] - length($$list[1][4]) - 1; my(undef,$stokens) = _space_out( substr($types, $range_start-1, $range_end-$range_start+3), [@$tokens[$range_start-1...$range_end+1]] ); join "", @$stokens[1...$#$stokens-1]; }; return $css, "CSS::DOM::Value::List", separator => $sep, css => $css, values => [ map { my @args = _make_arg_list( @$_[0...3] ); shift @args, shift @args; \@args } @$list ]; TEST test(<<'TEST'); # MAKAROW/Tk-TM-0.53/lib/Tk/TM/DataObject.pm foreach (my $i=@[; $i<=$colcount; $i++) { push(@$colspecs, ['','Entry']); } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/re.t0000644000175100017510000016254614001101046022006 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # ZDM/Pcore-v0.31.4/lib/Pcore/App/Controller/API.pm my $method_id = $tx->{action} ? q[/] . ( $tx->{action} =~ s[[.]][/]smgr ) . "/$tx->{method}" : $tx->{method}; TEST test(<<'TEST'); while ( $message =~ m{((!)?(?:https?:)(?://[^\s/?#]*)[^\s?#]*(?:\?[^\s#]*)?(?:#.*)?)}g ) { } TEST test(<<'TEST'); # FIVE/Mail-MsgStore-1.51/MsgStore.pm sub msgpath { local $_= shift; return '/' if m<^[@*/!?\\]$>; # convenience root return if /^[<|>].*[<|>]$/; # not a path sg; # clean path return $_ if -d "$mailroot/$_" or s<> or not m<^\W?(.*)/(mail[^/]+mail)$>i; return($1,$2); } TEST test(<<'TEST'); # AUTRIJUS/Pod-HtmlHelp-1.1/WinHtml.pm $rest =~ s{ \b # start at word boundary ( # begin $1 { $urls : # need resource and a colon [$any] +? # followed by on or more # of any valid character, but # be conservative and take only # what you need to.... ) # end $1 } (?= # look-ahead non-consumptive assertion [$punc]* # either 0 or more puntuation [^$any] # followed by a non-url char | # or else $ # then end of the string ) }{$1}igox; TEST test(<<'TEST'); # ROSSI/LaTeX-Authors-0.81/Authors.pm my @list_file_sdir = <*/*.tex>; my @list_file = (@list_file_dir,@list_file_sdir); my $nbr_file = @list_file; my $tex_file; if ($nbr_file == 1) { $tex_file = $list_file[0]; } elsif ($nbr_file > 1) { foreach (@list_file) { open(FILEGREP,"$_"); my $tempo_file = $_; while () { s/(^\s*|[^\\])%.*/$1/g; s/^\s*\n$//g; if ((/\\begin\{document\}/) || (/\\bye/) || (/\\documentstyle/) ) { $tex_file = $tempo_file; last; } } } } TEST test(<<'TEST'); # MICB/wing-0.9/Wing.pm my ($loc, $handler, $username, $url_session, $cmd, @args) = split(m(/), $r->path_info); TEST test(<<'TEST'); # DCONWAY/Perl6-Rules-0.03/Rules.pm our $charset = qr{ \[ \]? (?:\\[cCxX]\[ [^]]* \]|\\.|[^]])* \] }xs; TEST test(<<'TEST'); # DCONWAY/Perl6-Rules-0.03/Rules.pm our $codeblock = qr{ (?{$debug = 2 if $debug}) (\{) (?{mark($^N)}) (?> (?: ($i_scalar) (?{addscalar_internal $^N, 'rw'}) | ($e_scalar) (?{addscalar_external $^N, 'rw'}) | ($i_array) (?{addarray_internal $^N, 'rw'}) | ($e_array) (?{addarray_external $^N, 'rw'}) | ($i_hash) (?{addhash_internal $^N, 'rw'}) | ($e_hash) (?{addhash_external $^N, 'rw'}) | \$ (\d+) (?{add '$'.$^N, "\$Perl6::Rules::d0[$^N]"}) | ((?:\$\^\w+|[^{}\$]|\\[{}\$])+) (?{add $^N, $^N}) | (??{$nestedcodeblock}) )* ) (?{$debug = 1 if $debug}) (\}) (?{codeblock($^N)}) | (??{$debug=1 if $debug;'(?!)'}) }x; TEST test(<<'TEST'); # DCONWAY/Perl6-Rules-0.03/Rules.pm our $bspat = qr{ # Bracketed and Slashed patterns # Explicit whitespace (possibly repeated)... $ows ($ews) (?{add $^N, $ews{$^N}}) $stdrep $ows # Actual whitespace (insert :words spacing if in appropriate mode)... | $ws (?{wordspace}) # Backreference as literal (interpolated $1, $2, etc.)... | \$ (\d+) (?{add '$'.$^N, "(??{quotemeta \$Perl6::Rules::d0[$^N]})"}) $stdrep # Interpolated variable as literal... | ($i_scalar) (?{ addscalar_internal $^N, 'quotemeta' }) $stdrep | ($i_array) (?{ addarray_internal $^N, 'quotemeta' }) $stdrep | ($i_hash) (?{ addhash_internal $^N, 'quotemeta' }) $stdrep | ($e_scalar) (?{ addscalar_external $^N, 'quotemeta' }) $stdrep | ($e_array) (?{ addarray_external $^N, 'quotemeta' }) $stdrep | ($e_hash) (?{ addhash_external $^N, 'quotemeta' }) $stdrep | ($bad_var) (?{error("Can't use unqualified variable ($^N)")}) # Character class... | < (?: ([+-]?) (?{$^N||""}) ($charset) (?{mark ""; add "<$^R.$^N", transcharset($^N, $^R)}) | ([+-]?) (?{$^N||""}) < ([-!]? $ident) > (?{mark ""; add "<$^R.$^N", getprop($^N, $^R)}) ) (?: ([+-]?) (?{$^N||""}) ($charset) (?{add "$^R.$^N", transcharset($^N, $^R)}) | ([+-]?) (?{$^N||""}) < ([-!]? $ident) > (?{add "$^R.$^N", getprop($^N, $^R)}) )* > (?{make_charset}) $stdrep # <(...)> assertion block... | $assertblock # Backreference as pattern (interpolated <$1>, <$2>, etc.)... | <(\$ \d+)> (?{add "<$^N>", error("Cannot interpolate $^N as pattern")}) # Interpolate variable as pattern... | <($i_scalar)> (?{addscalar_internal $^N}) $stdrep | <($i_array)> (?{addarray_internal $^N}) $stdrep | <($i_hash)> (?{addhash_internal $^N}) $stdrep | <($e_scalar)> (?{addscalar_external $^N}) $stdrep | <($e_array)> (?{addarray_external $^N}) $stdrep | <($e_hash)> (?{addhash_external $^N}) $stdrep | <($bad_var)> (?{error("Can't use unqualified variable (<$^N>)")}) # Code block as action... | $codeblock # Code block as interpolated pattern... | <($braceblock)> (?{add $^N, "(??{Perl6::Rules::ispat do$^N})"}) # Literal in <'...'> format... | <' ( [^'\\]* (\\. [^'\\])* ) '> (?{add "<'$^N'>", "\Q$^N\E"}) # Match any Unicode character, regardless of :uN level... | (< \. >) (?{add $^N, '(?:\X)'}) # Match newline or anything-but-newline... | \\n (?{add '\n', $newline}) $stdrep | \\N (?{add '\N', $notnewline}) $stdrep # Quotemeta's literal (\Q[...])... | \\Q ( $squareblock ) (?{add "\\Q$^N", quotemeta substr($^N,1,-1)}) $stdrep # Named and numbered characters (\c[...], \C[...], \x[...], \0[...], etc)... | ( \\[cCxX0] $squareblock | \\[xX][0-9A-Fa-f]+ | \\0[0-7]+ ) (?{add $^N, transchars($^N)}) $stdrep | (\\[cCxX0] \[) (?{$^N}) ((?>.*)) (?{error "Untermimated $^R...] escape: $^R$^N"}) # Literal dot... | (\\.) (?{add $^N, $^N}) $stdrep # Backtracking limiter... | : (?=\s|\z) (?{nobacktrack}) # Lexical insensitivity... | :i (?{add ":i", '(?i)'}) # Continuation marker... | :c (?{add '\G'}) # Other lexical flags (NOT YET IMPLEMENTED)... | :(u0|u1|u2|u3|w|p5) (?{error "In-pattern :$^N not yet implemented"}) # Match any character... | \. (?{add '.', '[\s\S]'}) $stdrep # Start of line marker... | \^\^ (?{add '^^', '(?:(?<=\n)|(?<=\A))'}) # End of line marker... | \$\$ (?{add '$$', '(?:(?<=\n)|(?=\z))'}) # Start of string marker... | \^ (?{add '^', '\A'}) # End of string marker... | \$ (?{add '$', '\z'}) # Non-capturing subrule or property... | < ($callident) > (?{subrule($^N,"")}) $stdrep | < - ($callident) > (?{subrule($^N,"","","-")}) $stdrep | < ! ($callident) > (?{subrule($^N,"","","!")}) $stdrep # Capturing subrule... | < \? ($callident) > (?{$Perl6::Rules::srname=$^N}) $ows $rep (?{ subrule($Perl6::Rules::srname, $^N, "cap")}) | < \? ($callident) > (?{ subrule($^N, "", "cap")}) # Alternative marker... | \| (?{alternative}) # Comment... | $comment # Unattached repetition marker... | ($orep) (?{$^N&&badrep()}) }x; TEST test(<<'TEST'); # MLEHMANN/Games-Sokoban-1.01/Sokoban.pm for ($self->{data} = join "\n", @data) { s/#$//mg until /[^#]#$/m; # right s/^#//mg until /^#[^#]/m; # left } TEST test(<<'TEST'); # KARASIK/Prima-1.39/Prima/Edit.pm sub set_hilite_res { my ($self, $hi) = @_; if ( $hi) { push @{$hi}, cl::Fore if scalar @{$hi} / 2 != 0; $hi = [@{$hi}]; } $self-> {hiliteREs} = $hi; if ( $self-> {syntaxHilite}) { $self-> reset_syntaxer; $self-> repaint; } } sub set_insert_mode { my ( $self, $insert) = @_; my $oi = $self-> {insertMode}; $self-> {insertMode} = $insert; $self-> reset_cursor if $oi != $insert; $::application-> insertMode( $insert); $self-> push_group_undo_action( 'insertMode', $oi) if $oi != $insert; } sub set_offset { my ( $self, $offset) = @_; $offset = 0 if $offset < 0; $offset = 0 if $self-> {wordWrap}; return if $self-> {offset} == $offset; if ( $self-> {delayPanning}) { $self-> {delay_offset} = $offset; return; } my $dt = $offset - $self-> {offset}; $self-> push_group_undo_action( 'offset', $self-> {offset}); $self-> {offset} = $offset; if ( $self-> {hScroll} && $self-> {scrollTransaction} != 2) { $self-> {scrollTransaction} = 2; $self-> {hScrollBar}-> value( $offset); $self-> {scrollTransaction} = 0; } $self-> reset_cursor; $self-> scroll( -$dt, 0, clipRect => [ $self-> get_active_area]); } sub set_selection { my ( $self, $sx, $sy, $ex, $ey) = @_; my $maxY = $self-> {maxLine}; my ( $osx, $osy, $oex, $oey) = $self-> selection; my $onsel = ( $osx == $oex && $osy == $oey); if ( $maxY < 0) { $self-> {selStart} = [0,0]; $self-> {selEnd} = [0,0]; $self-> {selStartl} = [0,0]; $self-> {selEndl } = [0,0]; $self-> repaint unless $onsel; return; } $sy = $maxY if $sy < 0 || $sy > $maxY; $ey = $maxY if $ey < 0 || $ey > $maxY; ( $sy, $ey, $sx, $ex) = ( $ey, $sy, $ex, $sx) if $sy > $ey; $osx = $oex = $sx, $osy = $oey = $ey if $onsel; if ( $sx == $ex && $sy == $ey) { $osy = $maxY if $osy < 0 || $osy > $maxY; $oey = $maxY if $oey < 0 || $oey > $maxY; $sx = $ex = $osx; $sy = $ey = $osy; } my ($firstChunk, $lastChunk) = ( $self-> get_line( $sy), $self-> get_line( $ey)); my ($fcl, $lcl) = ( length( $firstChunk), length( $lastChunk)); my $bt = $self-> {blockType}; $sx = $fcl if ( $bt != bt::Vertical && $sx > $fcl) || ( $sx < 0); $ex = $lcl if ( $bt != bt::Vertical && $ex > $lcl) || ( $ex < 0); ( $sx, $ex) = ( $ex, $sx) if $sx > $ex && (( $sy == $ey && $bt == bt::CUA) || ( $bt == bt::Vertical)); my ( $lsx, $lsy) = $self-> make_logical( $sx, $sy); my ( $lex, $ley) = $self-> make_logical( $ex, $ey); ( $lsx, $lex) = ( $lex, $lsx) if $lsx > $lex && (( $lsy == $ley && $bt == bt::CUA) || ( $bt == bt::Vertical)); $sy = $ey if $sx == $ex and $bt == bt::Vertical; my ( $_osx, $_osy) = @{$self-> {selStartl}}; my ( $_oex, $_oey) = @{$self-> {selEndl}}; $self-> {selStart} = [ $sx, $sy]; $self-> {selStartl} = [ $lsx, $lsy]; $self-> {selEnd} = [ $ex, $ey]; $self-> {selEndl} = [ $lex, $ley]; return if $sx == $osx && $ex == $oex && $sy == $osy && $ey == $oey; return if $sx == $ex && $sy == $ey && $onsel; $self-> push_group_undo_action('selection', $osx, $osy, $oex, $oey); ( $osx, $osy, $oex, $oey) = ( $_osx, $_osy, $_oex, $_oey); ( $sx, $sy) = @{$self-> {selStartl}}; ( $ex, $ey) = @{$self-> {selEndl}}; $osx = $oex = $sx, $osy = $oey = $ey if $onsel; if (( $osy > $ey && $oey > $ey) || ( $oey < $sy && $oey < $sy)) { $self-> repaint; return; } # connective selection my ( $start, $end); if ( $bt == bt::CUA || ( $sx == $osx && $ex == $oex)) { if ( $sy == $osy) { if ( $ey == $oey) { if ( $sx == $osx) { $start = $end = $ey; } elsif ( $ex == $oex) { $start = $end = $sy; } else { ($start, $end) = ( $sy, $ey); } } else { ( $start, $end) = ( $ey < $oey) ? ( $ey, $oey) : ( $oey, $ey); } } elsif ( $ey == $oey) { ( $start, $end) = ( $sy < $osy) ? ( $sy, $osy) : ( $osy, $sy); } else { $start = ( $sy < $osy) ? $sy : $osy; $end = ( $ey > $oey) ? $ey : $oey; } } else { $start = ( $sy < $osy) ? $sy : $osy; $end = ( $ey > $oey) ? $ey : $oey; } my ( $ofs, $tl, $fh, $r, $yT) = ( $self-> {offset}, $self-> {topLine }, $self-> font-> height, $self-> {rows}, $self-> {yTail} ); my @a = $self-> get_active_area( 0); return if $end < $tl || $start >= $tl + $r + $yT; if ( $start == $end && $bt == bt::CUA) { # single connective line paint my $chunk; my ( $xstart, $xend); if ( $sx == $osx) { ( $xstart, $xend) = ( $ex < $oex) ? ( $ex, $oex) : ( $oex, $ex); } elsif ( $ex == $oex) { ( $xstart, $xend) = ( $sx < $osx) ? ( $sx, $osx) : ( $osx, $sx); } else { $xstart = ( $sx < $osx) ? $sx : $osx; $xend = ( $ex > $oex) ? $ex : $oex; } unless ( $self-> {wordWrap}) { if ( $start == $sy) { $chunk = $firstChunk; } elsif ( $start == $ey) { $chunk = $lastChunk; } else { $chunk = $self-> get_chunk( $start); } } else { $chunk = $self-> get_chunk( $start); } $self-> invalidate_rect( $a[0] - $ofs + $self-> get_chunk_width( $chunk, 0, $xstart) - 1, $a[3] - $fh * ( $start - $tl + 1), $a[0] - $ofs + $self-> get_chunk_width( $chunk, 0, $xend), $a[3] - $fh * ( $start - $tl) ); } else { # general connected lines paint $self-> invalidate_rect( $a[0], $a[3] - $fh * ( $end - $tl + 1), $a[2], $a[3] - $fh * ( $start - $tl), ); } } sub set_tab_indent { my ( $self, $ti) = @_; $ti = 0 if $ti < 0; $ti = 256 if $ti > 256; return if $ti == $self-> {tabIndent}; $self-> {tabIndent} = $ti; $self-> reset; $self-> repaint; } sub set_syntax_hilite { my ( $self, $sh) = @_; $sh = 0 if $self-> {wordWrap}; return if $sh == $self-> {syntaxHilite}; $self-> {syntaxHilite} = $sh; $self-> reset_syntaxer if $sh; $self-> reset_syntax; $self-> repaint; } sub set_word_wrap { my ( $self, $ww) = @_; return if $ww == $self-> {wordWrap}; $self-> {wordWrap} = $ww; $self-> syntaxHilite(0) if $ww; $self-> reset; $self-> reset_scrolls; $self-> repaint; } sub cut { my $self = $_[0]; return if $self-> {readOnly}; $self-> begin_undo_group; $self-> copy; $self-> delete_block; $self-> end_undo_group; } sub copy { my $self = $_[0]; my $text = $self-> get_selected_text; $::application-> Clipboard-> text($text) if defined $text; } sub get_selected_text { my $self = $_[0]; return undef unless $self-> has_selection; my @sel = $self-> selection; my $text = ''; my $bt = $self-> blockType; if ( $bt == bt::CUA) { if ( $sel[1] == $sel[3]) { $text = substr( $self-> get_line( $sel[1]), $sel[0], $sel[2] - $sel[0]); } else { my $c = $self-> get_line( $sel[1]); $text = substr( $c, $sel[0], length( $c) - $sel[0])."\n"; my $i; for ( $i = $sel[1] + 1; $i < $sel[3]; $i++) { $text .= $self-> get_line( $i)."\n"; } $c = $self-> get_line( $sel[3]); $text .= substr( $c, 0, $sel[2]); } } elsif ( $bt == bt::Horizontal) { my $i; for ( $i = $sel[1]; $i <= $sel[3]; $i++) { $text .= $self-> get_line( $i)."\n"; } } else { my $i; for ( $i = $sel[1]; $i <= $sel[3]; $i++) { my $c = $self-> get_line( $i); my $cl = $sel[2] - length( $c); $c .= ' 'x$cl if $cl > 0; $text .= substr($c, $sel[0], $sel[2] - $sel[0])."\n"; } chomp( $text); } return $text; } sub lock_change { my ( $self, $lock) = @_; $lock = $lock ? 1 : -1; $self-> {notifyChangeLock} += $lock; $self-> {notifyChangeLock} = 0 if $lock > 0 && $self-> {notifyChangeLock} < 0; $self-> notify(q(Change)) if $self-> {notifyChangeLock} == 0 && $lock < 0; } sub change_locked { my $self = $_[0]; return $self-> {notifyChangeLock} != 0; } sub insert_text { my ( $self, $s, $hilite) = @_; return if !defined($s) or length( $s) == 0; $self-> begin_undo_group; $self-> cancel_block unless $self-> {blockType} == bt::CUA; my @cs = $self-> cursor; my @ln = split( "\n", $s, -1); pop @ln unless length $ln[-1]; $s = $self-> get_line( $cs[1]); my $cl = $cs[0] - length( $s); $s .= ' 'x$cl if $cl > 0; $cl = 0 if $cl < 0; $self-> lock_change(1); if ( scalar @ln == 1) { substr( $s, $cs[0], 0) = $ln[0]; $self-> set_line( $cs[1], $s, q(add), $cs[0], $cl + length( $ln[0])); $self-> selection( $cs[0], $cs[1], $cs[0] + length( $ln[0]), $cs[1]) if $hilite && $self-> {blockType} == bt::CUA; } else { my $spl = substr( $s, $cs[0], length( $s) - $cs[0]); substr( $s, $cs[0], length( $s) - $cs[0]) = $ln[0]; $self-> lock; $self-> set_line( $cs[1], $s); shift @ln; $self-> insert_line( $cs[1] + 1, (@ln, $spl)); $self-> selection( $cs[0], $cs[1], length( $ln[-1]), $cs[1]+scalar(@ln)) if $hilite && $self-> {blockType} == bt::CUA; $self-> unlock; } $self-> lock_change(0); $self-> end_undo_group; } sub paste { my $self = $_[0]; return if $self-> {readOnly}; $self-> insert_text( $::application-> Clipboard-> text, 1); } sub make_logical { my ( $self, $x, $y) = @_; return (0,0) if $self-> {maxChunk} < 0; return $x, $y unless $self-> {wordWrap}; my $maxY = $self-> {maxLine}; $y = $maxY if $y > $maxY || $y < 0; $y = 0 if $y < 0; my $l = length( $self-> {lines}-> [$y]); $x = $l if $x < 0 || $x > $l; $x = 0 if $x < 0; my $cm = $self-> {chunkMap}; my $r; ( $l, $r) = ( 0, $self-> {maxChunk} + 1); my $i = int($r / 2); my $kk = 0; while (1) { my $acd = $$cm[$i * 3 + 2]; last if $acd == $y; $acd > $y ? $r : $l = $i; $i = int(( $l + $r) / 2); if ( $kk++ > 200) { print "bcs dump to $y\n"; ( $l, $r) = ( 0, $self-> {maxChunk} + 1); $i = int($r / 2); for ( $kk = 0; $kk < 7; $kk++) { my $acd = $$cm[$i * 3 + 2]; print "i:$i [$l $r] f() = $acd\n"; $acd > $y ? $r : $l = $i; $i = int(( $l + $r) / 2); } die; last; } } $y = $i; $i *= 3; $i-= 3, $y-- while $$cm[ $i] != 0; $i+= 3, $y++ while $x > $$cm[ $i] + $$cm[ $i + 1]; $x -= $$cm[ $i]; return $x, $y; } TEST test(<<'TEST'); # CHM/PDL-2.015/Doc/Doc.pm for (@funcs) { $sym->{$1}->{Module} = $this->{NAME} if m/\s*([^\s(]+)\s*/; $sym->{$1}->{Sig} = $2 if m/\s*([^\s(]+)\s*\(\s*(.+)\s*\)\s*$/; } TEST test(<<'TEST'); # BIGJ/Lingua-DE-ASCII-0.11/ASCII.pm {no warnings; s/((?:${prefix}|en)s)?(([tT])�n(de?|\b))(?!chen|lein|lich) /$1 ? "$1$2" : "$3uen$4"/xgeo;# Gro�tuende, but abst�nde, St�ndchen } s/($prefix s? t)�(r(ische?[mnrs]?| i?[ns](nen)?)?\b)/$1ue$2/gx; TEST test(<<'TEST'); # KARASIK/Prima-1.39/Prima/FileDialog.pm unless ( scalar @fs) { $self-> path('.'), return unless $p =~ tr{/\\}{} > 1; $self-> {path} =~ s{[/\\][^/\\]+[/\\]?$}{/}; $self-> path('.'), return if $p eq $self-> {path}; $self-> path($self-> {path}); return; } TEST test(<<'TEST'); # CINDY/Plack-Middleware-Session-SerializedCookie-1.03/t/Common.pm for( 0 .. int($#{$res->[1]}/2) ) { if( $res->[1][$_*2] =~ /^Set-Cookie$/i ) { $res->[1][$_*2+1] =~ /([^;]*)/; $cookie .= "$1;"; } } TEST test(<<'TEST'); # DUKKIE/FarmBalance-0.03/lib/FarmBalance.pm sub arrange_array { my ( $self, $arrayref) = @_; my $sum = $self->array_val_sum($arrayref); my $kei = $self->{'percent'} / $sum; my @nums_new = map { $_ * $kei } @{$arrayref}; return \@nums_new; } #- return standard deviation sub sd { my ( $self, $arrayref ) = @_; my $avg = $self->average($arrayref); my $ret = 0; for (@{$arrayref}) { $ret += ($_ - $avg)**2; } return ( $ret/($#$arrayref + 1)); } sub average { my ( $self, $arrayref) = @_; my $sum = $self->array_val_sum($arrayref); return ( $sum / ( $#$arrayref + 1) ); } TEST test(<<'TEST'); # SJCARBON/go-db-perl-0.04/GO/Tango.pm foreach my $k (@k) { print STDERR " key=$k\n"; next if $domainh->{$k} < 2; # bayes # p = (p(ipr|t) * p(t)) / p(ipr) my $prob = (($domainh->{$k} / scalar(@$pl)) * (scalar(@$pl) / scalar(@allids))) / ($dc{$k} / scalar(@allids)); printf "$neg [$prob] %s $k $got{$k} $domainh->{$k} / %d\n", $term->name, scalar @$pl; if ($prob > 0.8 && $domainh->{$k} > 4) { push(@rules, $term->acc." $k $prob $domainh->{$k}/".(scalar @$pl)); } $probh{$k} = $prob; } TEST test(<<'TEST'); # BURAK/Scalar-Util-Reftype-0.40/builder/Build.pm printf $W q/BEGIN { $INC{$_} = 1 for qw(%s); }/, join(' ', @inc_files); print $W "\n"; foreach my $name ( @packages ) { print $W qq/package $name;\nsub ________monolith {}\n/; } TEST test(<<'TEST'); # VLADO/AI-NaiveBayes1-2.006/NaiveBayes1.pm foreach my $label (keys(%{$self->{stat_labels}})) { $m->{labelprob}{$label} = $self->{stat_labels}{$label} / $self->{numof_instances} } $m->{condprob} = {}; $m->{condprobe} = {}; foreach my $att (keys(%{$self->{stat_attributes}})) { next if $self->{attribute_type}{$att} eq 'real'; $m->{condprob}{$att} = {}; $m->{condprobe}{$att} = {}; foreach my $label (keys(%{$self->{stat_labels}})) { my $total = 0; my @attvals = (); foreach my $attval (keys(%{$self->{stat_attributes}{$att}})) { next unless exists($self->{stat_attributes}{$att}{$attval}{$label}) and $self->{stat_attributes}{$att}{$attval}{$label} > 0; push @attvals, $attval; $m->{condprob}{$att}{$attval} = {} unless exists( $m->{condprob}{$att}{$attval} ); $m->{condprob}{$att}{$attval}{$label} = $self->{stat_attributes}{$att}{$attval}{$label}; $m->{condprobe}{$att}{$attval} = {} unless exists( $m->{condprob}{$att}{$attval} ); $m->{condprobe}{$att}{$attval}{$label} = $self->{stat_attributes}{$att}{$attval}{$label}; $total += $m->{condprob}{$att}{$attval}{$label}; } if (exists($self->{smoothing}{$att}) and $self->{smoothing}{$att} =~ /^unseen count=/) { my $uc = $'; $uc = 0.5 if $uc <= 0; if(! exists($m->{condprob}{$att}{'*'}) ) { $m->{condprob}{$att}{'*'} = {}; $m->{condprobe}{$att}{'*'} = {}; } $m->{condprob}{$att}{'*'}{$label} = $uc; $total += $uc; if (grep {$_ eq '*'} @attvals) { die } push @attvals, '*'; } foreach my $attval (@attvals) { $m->{condprobe}{$att}{$attval}{$label} = "(= $m->{condprob}{$att}{$attval}{$label} / $total)"; $m->{condprob}{$att}{$attval}{$label} /= $total; } } } TEST test(<<'TEST'); # AKSTE/Data-ShowTable-4.6/ShowTable.pm sub PlainText { local($_) = shift if $#_ >= 0; # set local $_ if there's an argument # skip unless there's a sequence return $_ unless m= ]+# # ....VALUE )# )?# # ..=VALUE is optional )*# # zero or more PARAM or PARAM=VALUE >}{}igx; # up to the closing '>' $_; # return the result } TEST test(<<'TEST'); # TEEJAY/Math-Curve-Hilbert-0.04/Hilbert.pm if ($args{clockwise}) { if ($args{max} == $this_level) { $$y -= $step; push (@$coords,{X=>$$x,Y=>$$y}); $self->{curve}{"$$x:$$y"} = $#$coords; $$x += $step; push (@$coords,{X=>$$x,Y=>$$y}); $self->{curve}{"$$x:$$y"} = $#$coords; $$y += $step; push (@$coords,{X=>$$x,Y=>$$y}); $self->{curve}{"$$x:$$y"} = $#$coords; } else { foreach (@{$self->right(X=>$x,Y=>$y,level=>$this_level,max=>$args{max})}) { push (@$coords,$_); $self->{curve}{"$_->{X}:$_->{Y}"} = $#$coords; } $$y -= $step; push (@$coords,{X=>$$x,Y=>$$y}); $self->{curve}{"$$x:$$y"} = $#$coords; foreach (@{$self->up(clockwise=>1,X=>$x,Y=>$y,level=>$this_level,max=>$args{max})}) { push (@$coords,$_); $self->{curve}{"$_->{X}:$_->{Y}"} = $#$coords; } $$x += $step; push (@$coords,{X=>$$x,Y=>$$y}); $self->{curve}{"$$x:$$y"} = $#$coords; foreach (@{$self->up(clockwise=>1,X=>$x,Y=>$y,level=>$this_level,max=>$args{max})}) { push (@$coords,$_); $self->{curve}{"$_->{X}:$_->{Y}"} = $#$coords; } $$y += $step; push (@$coords,{X=>$$x,Y=>$$y}); $self->{curve}{"$$x:$$y"} = $#$coords; foreach (@{$self->left(X=>$x,Y=>$y,level=>$this_level,max=>$args{max})}) { push (@$coords,$_); $self->{curve}{"$_->{X}:$_->{Y}"} = $#$coords; } } } TEST test(<<'TEST'); # TONYC/Imager-1.004/Imager.pm if (@$x < @$y) { $x = [ @$x, ($x->[-1]) x (@$y - @$x) ]; } elsif (@$y < @$x) { $y = [ @$y, ($y->[-1]) x (@$x - @$y) ]; } TEST test(<<'TEST'); # TMTM/CDDB-File-1.05/lib/CDDB/File.pm sub _highest_track_no { my $self = shift; $self->{_high} ||= pop @{[ map /^TTITLE(\d+)=/, $self->_data ]} } sub track_count { shift->_highest_track_no + 1 } # ==================================================================== # package CDDB::File::Track; use overload '""' => 'title'; sub cd { shift->{_cd} } sub extd { shift->{_extd} } sub length { shift->{_length}} sub number { shift->{_number}} sub offset { shift->{_offset}} sub _split_title { my $self = shift; if ($self->cd->artist eq "Various") { ($self->{_artist}, $self->{_title}) = split /\s+\/\s+/, $self->{_tline}, 2 } else { $self->{_title} = $self->{_tline}; $self->{_artist} = $self->cd->artist; } unless ($self->{_title}) { $self->{_title} = $self->{_artist}; $self->{_artist} = $self->cd->artist; } } TEST test(<<'TEST'); # MRDVT/Geo-Forward-0.14/lib/Geo/Forward.pm # CU=1./DSQRT(TU*TU+1.) my $CU=1./sqrt($TU*$TU+1.); # SU=TU*CU my $SU=$TU*$CU; # SA=CU*SF my $SA=$CU*$SF; # C2A=-SA*SA+1. my $C2A=-$SA*$SA+1.; # X=DSQRT((1./R/R-1.)*C2A+1.)+1. my $X=sqrt((1./$R/$R-1.)*$C2A+1.)+1.; # X=(X-2.)/X $X=($X-2.)/$X; # C=1.-X my $C=1.-$X; TEST test(<<'TEST'); # RBOW/Date-ICal-2.678/lib/Date/ICal.pm my @temp = $str =~ m{ ([\+\-])? (?# Sign) (P) (?# 'P' for period? This is our magic character) (?: (?:(\d+)Y)? (?# Years) (?:(\d+)M)? (?# Months) (?:(\d+)W)? (?# Weeks) (?:(\d+)D)? (?# Days) )? (?:T (?# Time prefix) (?:(\d+)H)? (?# Hours) (?:(\d+)M)? (?# Minutes) (?:(\d+)S)? (?# Seconds) )? }x; TEST test(<<'TEST'); # JMASON/Mail-SpamAssassin-2.64/t/SATest.pm sub start_spamd { my $sdargs = shift; return if (defined($spamd_pid) && $spamd_pid > 0); rmtree ("log/outputdir.tmp"); # some tests use this mkdir ("log/outputdir.tmp", 0755); if (defined $ENV{'SD_ARGS'}) { $sdargs = $ENV{'SD_ARGS'} . " ". $sdargs; } my $spamdargs; if($sdargs !~ /(?:-C\s*[^-]\S+)/) { $sdargs = "$spamd_cf_args $spamd_localrules_args $sdargs"; } if($sdargs !~ /(?:-p\s*[0-9]+|-o|--socketpath)/) { $spamdargs = "$spamd -D -p $spamdport $sdargs"; } else { $spamdargs = "$spamd -D $sdargs"; } $spamdargs =~ s!/!\\!g if ($^O =~ /^MS(DOS|Win)/i); if ($set_test_prefs) { warn "oops! SATest.pm: a test prefs file was created, but spamd isn't reading it\n"; } print ("\t$spamdargs > log/$testname.spamd 2>&1 &\n"); system ("$spamdargs > log/$testname.spamd 2>&1 &"); # now find the PID $spamd_pid = 0; # note that the wait period increases the longer it takes, # 20 retries works out to a total of 60 seconds my $retries = 20; my $wait = 0; while ($spamd_pid <= 0) { my $spamdlog = ''; if (open (IN, ") { /Address already in use/ and $retries = 0; /server pid: (\d+)/ and $spamd_pid = $1; $spamdlog .= $_; } close IN; last if ($spamd_pid); } sleep (int($wait++ / 4) + 1) if $retries > 0; if ($retries-- <= 0) { warn "spamd start failed: log: $spamdlog"; warn "\n\nMaybe you need to kill a running spamd process?\n\n"; return 0; } } 1; } sub stop_spamd { return 0 if defined($spamd_never_started); return 0 if defined($spamd_already_killed); $spamd_pid ||= 0; if ( $spamd_pid <= 1) { print ("Invalid spamd pid: $spamd_pid. Spamd not started/crashed?\n"); return 0; } else { my $killed = kill (15, $spamd_pid); print ("Killed $killed spamd instances\n"); # wait for it to exit, before returning. for my $waitfor (0 .. 5) { if (kill (0, $spamd_pid) == 0) { last; } print ("Waiting for spamd at pid $spamd_pid to exit...\n"); sleep 1; } $spamd_pid = 0; undef $spamd_never_started; $spamd_already_killed = 1; return $killed; } } TEST test(<<'TEST'); # JOSEF/Text-Glob-DWIW-0.01/lib/Text/Glob/DWIW.pm sub _dequ ($@) { my $o=shift; my $star=join '',map { $o&&$o->{star}=~/([$_])/ } qw'* ?'; my ($xa)=map {('^'x/[a\^]/).('^'x/[z\$]/)} $o->{rewrite}?'':$o->{anchors}; my $s=$star.($o->{minus}?'!':'').($o->{rewrite}?'':',{}').$xa; my $dequ=qr/(?<=^\\)[!]|[[\]$s-]/; # $o{star} (\\?) _map_r { s{$nobackslash\K\\($dequ)}{$1}gs; s/\\\\/\\/gs if $o->{last} } @_ }# \# &c. = done elsewhere TEST test(<<'TEST'); # WINTRU/Carrot-1.1.309/lib/Carrot/Modularity/Package/Source_Code.pm { sub add_begin_block_after_warnings # /type method # /effect "" # //parameters # //returns { my ($this) = @ARGUMENTS; unless ($$this =~ s # {use (warnings|strict)[^\015\012;]*;(?:\012|\015\012?)\K} {use warnings[^\015\012;]*;(?:\012|\015\012?)\K} {$begin_block}s) { die("Could not add a begin block.\n"); } return; } my $carrot_modularity_start = '#--8<-- carrot-modularity-start -->8--#'; my $carrot_modularity_end = '#--8<-- carrot-modularity-end -->8--#'; } TEST test(<<'TEST'); # WINTRU/Carrot-1.1.309/lib/Carrot/Modularity/Package/Source_Code.pm sub add_modularity_markers # /type method # /effect "" # //parameters # //returns { my ($this) = @ARGUMENTS; unless ($$this =~ s {((?:\012|\015\012?)\h+)my\h+\$expressiveness\h+=\h+Carrot::modularity(?:\(\))?;\K} {$1$carrot_modularity_start}saa) { die("Could not add carrot-modularity-start. $$this\n"); } unless ($$this =~ s {(((?:\012|\015\012?)\h+)\} \#BEGIN)} {$1$carrot_modularity_end$2}saa) { die("Could not add carrot-modularity-end.\n"); } return; } TEST test(<<'TEST'); # MONS/AnyEvent-SMTP-0.10/lib/AnyEvent/SMTP/Client.pm m{# trying to cheat with cpants game ;) use strict; use warnings; }x; TEST test(<<'TEST'); # CHILTS/SRS-EPP-Proxy-0.21/lib/SRS/EPP/Command.pm sub rebless_class { my $object = shift; our $map; if ( !$map ) { $map = { map { $_->can("match_class") ? ( $_->match_class => $_ ) : (); }# map { print "rebless_class checking plugin $_\n"; $_ } grep m{${\(__PACKAGE__)}::[^:]*$}, __PACKAGE__->plugins, }; } $map->{ref $object}; } TEST test(<<'TEST'); # AKXLIX/Sisimai-4.1.25/lib/Sisimai/ARF.pm my $RxARF0 = { 'content-type' => qr/report-type=["]?feedback-report["]?/, 'begin' => qr{\A(?> [Tt]his[ ]is[ ].+[ ]email[ ]abuse[ ]report |[Tt]his[ ]is[ ](?: an[ ]autogenerated[ ]email[ ]abuse[ ]complaint |an?[ ].+[ ]report[ ]for |a[ ].+[ ]authentication[ -]failure[ ]report[ ]for ) ) }x, 'rfc822' => qr!\AContent-Type: (:?message/rfc822|text/rfc822-headers)!, 'endof' => qr/\A__END_OF_EMAIL_MESSAGE__\z/, }; TEST test(<<'TEST'); # LBENDAVID/Net-Telnet-Brcd-1.13/lib/Net/Brcd.pm if (m{ ^\s* (\d+) : \s+ \w+ \s+ # Domain id + identifiant FC ${_brcd_wwn_re} \s+ # WWN switch (\d+\.\d+\.\d+\.\d+) \s+ # Adresse IP switch \d+\.\d+\.\d+\.\d+ \s+ # Adresse IP FC switch (FCIP) (>?)"([^"]+) # Master, nom du switch }msx) { my ($domain_id, $switch_ip, $switch_master, $switch_name) = ($1, $2, $3, $4); my $switch_host = gethostbyaddr(inet_aton($switch_ip), AF_INET); my @fields = qw(DOMAIN IP MASTER FABRIC NAME MASTER); foreach my $re ($domain_id, $switch_ip, $switch_master, $switch_host, $switch_name) { my $field = shift @fields; if ($re) { $domain{$domain_id}->{$field} = $re; $fabric{$switch_name}->{$field} = $re; } } $fabric{$switch_host} = $switch_name if $switch_host; } TEST test(<<'TEST'); # DCONWAY/Acme-Bleach-1.150/lib/Acme/DWIM.pm my @bits = split qr<(?!\s*\bx)($string|[\$\@%]\w+|[])}[({\w\s;/]+)>; TEST test(<<'TEST'); # EVO/Text-MicroMason-1.99/MicroMason/Embperl.pm sub lex_token { # Blocks in [-/+/! ... -/+/!] tags. /\G \[ (\-|\+|\!) \s* (.*?) \s* \1 \] /gcxs ? ( $block_types{$1} => $2 ) : # Blocks in [$ command ... $] tags. /\G \[ \$ \s* (\S+)\s*(.*?) \s* \$ \] /gcxs ? ( "ep_$1" => $2 ) : # Things that don't match the above /\G ( (?: [^\[] | \[(?![\-\+\!\$]) )+ ) /gcxs ? ( 'text' => $1 ) : () } TEST test(<<'TEST'); # DOMQ/Alien-Selenium-0.09/inc/Module/Load.pm sub _is_file { local $_ = shift; return /^\./ ? 1 : /[^\w:']/ ? 1 : undef #' silly bbedit.. } TEST test(<<'TEST'); # WOODY/Apache-Album-0.96/Album.pm my %params = split /=+/, $r->args; TEST test(<<'TEST'); # JONG/Bioinf_V2.0/Bioinf.pm sub rand_word { my($length) = $_[0]; my($word, $letter); srand(((time/$$)^($>*time))/(time/(time^$$))); foreach (1..$length){ $letter = pack("c", rand(128)); redo unless $letter =~ /[a-zA-Z]/; # I just don't like \w, okay? $word .= $letter; } return(\$word); } TEST test(<<'TEST'); # JOESUF/News-GnusFilter-0.55/GnusFilter.pm $count++ while /^\s*[^>#\%\$\@].{60,}\n[^>].{1,20}[^{}();|&]\n(?=[^>].{60})/gm; TEST test(<<'TEST'); # NWIGER/HTML-ActiveLink-1.02/ActiveLink.pm if ($path eq '/') { return $ifmatches if ($test =~ m#^/[^/]*$#); return $default; } TEST test(<<'TEST'); # CHORNY/Switch-2.17/Switch.pm elsif ($Perl5 && $source =~ m/\G\s*(([^\$\@{])[^\$\@{]*)(?=\s*{)/gc || $Perl6 && $source =~ m/\G\s*([^;{]*)()/gc) { my $code = filter_blocks($1,line(substr($source,0,pos $source),$line)); $text .= ' \\' if $2 eq '%'; $text .= " $code)"; } TEST test(<<'TEST'); # UGEN/IMAPGet.pm $self->{Opres} = "TIMEOUT"; while ($line = _getsock($sock)) { print "< $line" if $self->{Dump}; last if $line =~/$self->{Opid}\s(\w+)\s/ and $self->{Opres}=$1; } TEST test(<<'TEST'); # NEILB/Text-Autoformat-1.74/lib/Text/Autoformat.pm $eos = $str !~ /^($gen_abbrev)[^a-z]*\s/i && $str =~ /[a-z][^a-z]*$term([^a-z]*)\s/ && !($1=~/[])]/ && !$brsent); TEST test(<<'TEST'); # JANPAZ/DBD-XBase-1.05/lib/XBase/Index.pm if ($key =~ tr!,+*)('&%$#"!0123456789!) { $key = '-' . $key; } TEST test(<<'TEST'); # SPROUT/WWW-Scripter-0.031/lib/WWW/Scripter.pm sub request { for (my $foo) { # protect against tied $_ my $self = shift; return unless defined(my $request = shift); $request = $self->_modify_request( $request ); my $meth = $request->method; my $orig_uri = $request->uri; my $new_uri; if ((my $path = $orig_uri->path) =~ s-^(/*)/\.\./-$1||'/'-e) { 0while $path =~ s\\$1||'/'\e; ($new_uri = $orig_uri->clone)->path($path) } my $skip_fetch; if(defined($orig_uri->fragment)) { ($new_uri ||= $orig_uri->clone)->fragment(undef); # Skip fetching the URL if it is the same (and there is a fragment). # We don’t need to strip the fragment from $self->uri before compari- # son as that always contains the actual URL sent in the request. $meth eq "GET" and $new_uri->eq($self->uri) and ++$skip_fetch; } if ($new_uri) { $request->uri($new_uri); } my $response; if($skip_fetch) { $response = $self->response; } else { Scripter_REQUEST: { Scripter_ABORT: { $response = $self->_make_request( $request, @_ ); last Scripter_REQUEST; } return 1 } } if ( $meth eq 'GET' || $meth eq 'POST' ) { $self->get_event_listeners('unload') and $self->trigger_event('unload'), $self->{page_stack}->_delete_res; $self->{page_stack}->${\( $self->{Scripter_replace} ? '_replace' : '_add' )}($request, $response, $orig_uri); } return $self->_update_page($request, $response); } } TEST test(<<'TEST'); # DYLUNIO/Gwybodaeth-0.02/lib/Gwybodaeth/Parsers/N3.pm if ($token =~ m/\[ # matches [ /x) { if ($token =~ m/ \[\] # matches [] /x) { #logic specific to 'something' bracket operator next; } # logic while((my $tok=$self->_next_token($data,$indx)) =~ / # any character which is not # a right square brace [^\]] /x) { ++$indx; } $indx = $self->_parse_n3($data,$indx); next; } TEST test(<<'TEST'); # BRICAS/Image-TextMode-0.25/lib/Image/TextMode/Writer/ADF.pm my $default_pal = [ map { my @d = split( //s, sprintf( '%06b', $_ ) ); { [ oct( "0b$d[ 3 ]$d[ 0 ]" ) * 63, oct( "0b$d[ 4 ]$d[ 1 ]" ) * 63, oct( "0b$d[ 5 ]$d[ 2 ]" ) * 63, ] } } 0 .. 63 ]; TEST test(<<'TEST'); # AGENT/Test-Nginx-0.25/lib/Test/Nginx/Socket/Lua.pm unless ($config =~ s{(?{pipes} = [ map { my $class = load_module /::/ ? $_ : "Mojolicious::Plugin::AssetPack::Pipe::$_"; diag 'Loading pipe "%s".', $class if DEBUG; die qq(Unable to load "$_": $@) unless $class; my $pipe = $class->new(assetpack => $self); Scalar::Util::weaken($pipe->{assetpack}); $pipe; } @$names ]; } sub _process_from_def { my $self = shift; my $file = shift || 'assetpack.def'; my $asset = $self->store->file($file); my $topic = ''; my %process; die qq(Unable to load "$file".) unless $asset; diag qq(Loading asset definitions from "$file".) if DEBUG; for (split /\r?\n/, $asset->slurp) { s/\s*\#.*//; if (/^\<(\S*)\s+(.+)/) { my $asset = $self->store->asset($2); bless $asset, 'Mojolicious::Plugin::AssetPack::Asset::Null' if $1 eq '<'; push @{$process{$topic}}, $asset; } elsif (/^\!\s*(.+)/) { $topic = $1; } } $self->process($_ => @{$process{$_}}) for keys %process; $self; } TEST test(<<'TEST'); # CASIANO/Parse-Eyapp-1.182/lib/Parse/Eyapp/Cleaner.pm $$input=~/\G%{/gc and do { my($code); $$input=~/\G(.*?)%}/sgc or _SyntaxError(2,"Unmatched %{ opened line $lineno[0]",-1); $code=$1; $lineno[1]+= $code=~tr/\n//; return('HEADCODE',[ $code, $lineno[0] ]); }; TEST test(<<'TEST'); # MSERGEANT/XML-Handler-AxPoint-1.5/lib/XML/Handler/AxPoint.pm $phi_r = $phi * PI / 180.0; # Compute (x1, y1) $x1 = cos($phi_r) * $dx2 + sin($phi_r) * $dy2; $y1 = -sin($phi_r) * $dx2 + cos($phi_r) * $dy2; # Make sure radii are large enough $rx = abs($rx); $ry = abs($ry); $rx_sq = $rx * $rx; $ry_sq = $ry * $ry; $x1_sq = $x1 * $x1; $y1_sq = $y1 * $y1; my $radius_check = ($x1_sq / $rx_sq) + ($y1_sq / $ry_sq); TEST test(<<'TEST'); # AGENT/Test-Nginx-0.25/lib/Test/Nginx/Socket/Lua.pm Test::Nginx::Socket::set_http_config_filter(sub { my $config = shift; if ($config =~ /init_by_lua_file/) { return $config; } unless ($config =~ s{(?=10?$pos-10:0, $pos>=10?10:$pos); # my $post=substr($str, $pos, 10); # print "start at position ",pos,": $prev^$post\n"; # }) <([=:\043]) # [=:#] goes to $1 (\w*) # TAG to $2 ($re_tparam) # tag params go to $3 (?: (?> /> ) | (?> > ( # the section content goes to $4 (?: # we are looking for a character (?> [^<]+ ) # that is not the beginning of a TAG | # or (?> (??{$regexp}) # we are looking for something that is ) # described by $regexp | # or <(?! # is the beginning of a TAG but not followed (?> # by the rest of an opening or closing TAG \1\2 $re_tparam | /\1\2 )> ) )*? # and that many times ) # the closing TAG )) # (?{ # my $pos=pos; # my $prev=substr($str, $pos-10, 10); # my $post=substr($str, $pos, 10); # print "emitted at position ",pos,": $prev^$post\n"; # }) }xs; TEST test(<<'TEST'); # OPI/HTML-YaTmpl-1.8/lib/HTML/YaTmpl/_parse.pm my $re_nostr=qr{ (?: # between <: and /> can be written perl code [^\s\w/]> # but perl knows the -> operator. Originally | # this (?:...) was written simply as [^"<>] # and <:$p->{xxx}/> was matched as $1=':', # $2='', $3='$p-' and not as $3='$p->{xxx}' # as expected. Now a character other than \s, # \w or / acts like an escape character for a # subsequent >. /(?!>) | \\. | [^"<>/] # "]# kein string )* }xs; TEST test(<<'TEST'); # DHARD/FAST-1.0/lib/FAST/Bio/SearchIO/Writer/HTMLResultWriter.pm if ($sec =~ s/((?:gi\|(\d+)\|)? # optional GI (\w+)\|([A-Z\d\.\_]+) # main (\|[A-Z\d\_]+)?) # optional secondary ID//xms) { my ($name, $gi, $db, $acc) = ($1, $2, $3, $4); #$acc ||= ($rest) ? $rest : $gi; $acc =~ s/^\s+(\S+)/$1/; $acc =~ s/(\S+)\s+$/$1/; $url = length($self->remote_database_url($type)) > 0 ? sprintf('%s %s', sprintf($self->remote_database_url($type), $gi || $acc || $db), $name, $sec) : $sec; } else { $url = $sec; } TEST test(<<'TEST'); # REID/Games-Go-AGATourn-1.035/AGATourn.pm if ($line =~ s/\s*#\s*(.*?)\s*$//) { $comment = $1; } if ($line eq '') { return { comment => $comment, }; } if ($line =~ m/^\s*(\w+)(\d+)\s+(\w+)(\d+)\s+([bwBW\?])\s+(\d+)\s+(-?\d+)$/) { return { wcountry => uc($1), wagaNum => $2, bcountry => uc($3), bagaNum => $4, result => lc($5), handi => $6, komi => $7, comment => $comment, }; } TEST test(<<'TEST'); # PERLANCAR/PERLANCAR-JSON-Match-0.02/lib/PERLANCAR/JSON/Match.pm our $MATCH_JSON = qr{ (?&VALUE) (?{ $_ = $^R->[1] if 0 }) (?(DEFINE) (? #(?{ [$^R, {}] }) \{\s* (?: (?&KV) # [[$^R, {}], $k, $v] # (?{ # warn Dumper { obj1 => $^R }; # die "Duplicate key '$^R->[1]'" if exists $^R->[0][1]->{$^R->[1]}; # [$^R->[0][0], {$^R->[1] => $^R->[2]}] }) (?: \s*,\s* (?&KV) # [[$^R, {...}], $k, $v] # (?{ # warn Dumper { obj2 => $^R }; # die "Duplicate key '$^R->[1]'" if exists $^R->[0][1]->{$^R->[1]}; # [$^R->[0][0], {%{$^R->[0][1]}, $^R->[1] => $^R->[2]}] }) )* )? \s*\} ) (? (?&STRING) # [$^R, "string"] \s*:\s* (?&VALUE) # [[$^R, "string"], $value] #(?{ # warn Dumper { kv => $^R }; # [$^R->[0][0], $^R->[0][1], $^R->[1]] }) ) (? #(?{ [$^R, []] }) \[\s* (?: (?&VALUE) #(?{ [$^R->[0][0], [$^R->[1]]] }) (?: \s*,\s* (?&VALUE) #(?{ # warn Dumper { atwo => $^R }; #[$^R->[0][0], [@{$^R->[0][1]}, $^R->[1]]] }) )* )? \s*\] ) (? \s* ( (?&STRING) | (?&NUMBER) | (?&OBJECT) | (?&ARRAY) | true #(?{ [$^R, 1] }) | false #(?{ [$^R, 0] }) | null #(?{ [$^R, undef] }) ) \s* ) (? ( " (?: [^\\"]+ | \\ ["\\/bfnrt] # | # \\ u [0-9a-fA-f]{4} )* " ) #(?{ [$^R, eval $^N] }) ) (? ( -? (?: 0 | [1-9]\d* ) (?: \. \d+ )? (?: [eE] [-+]? \d+ )? ) #(?{ [$^R, eval $^N] }) ) ) }xms; TEST test(<<'TEST'); # MRDVT/List-NSect-0.06/lib/List/NSect.pm sub spart { my $parts = shift || 0; my @deck = (); #undef, 0 or empty array returns nothing as requested if ($parts > 0) { my $i = 0; @deck = part {int($i++ / $parts)} @_; #/#Each partition created is a reference to an array. } return wantarray ? @deck : \@deck; } TEST test(<<'TEST'); # GEHIC/ConfigFile.pm while () { # process a comment or blank line if (/^\s*[#;]/ || /^\s*$/) { print TMP $_; next }; # Is this a section header? /^\s*\[\s*(.+)\s*\].*$/ && do { $sect = $1; print TMP $_; next; }; # process definition /^\s*(.+)\s*=\s*(.+)\s*$/ && do { print TMP "$1 = $self->{Config}->{$sect}->{$1}\n"; delete $self->{Config}->{$sect}->{$1}; }; }; TEST test(<<'TEST'); # RHANDOM/Net-Server-2.008/lib/Net/Server/HTTP.pm $fmt =~ s{ % ([<>])? # 1 (!? \d\d\d (?:,\d\d\d)* )? # 2 (?: \{ ([^\}]+) \} )? # 3 ([aABDfhHmpqrsTuUvVhblPtIOCeinoPtX%]) # 4 }{ $info = $orig if $1 && $orig && $1 eq '<'; my $v = $2 && (substr($2,0,1) eq '!' ? index($2, $info->{'response_status'})!=-1 : index($2, $info->{'response_status'})==-1) ? '-' : $fmt_map{$4} ? $info->{$fmt_map{$4}} : $fmt_code{$4} ? do { my $m = $fmt_code{$4}; $self->$m($info, $3, $1, $4) } : $4 eq 'b' ? $info->{'response_size'} || '-' # B can be 0, b cannot : $4 eq 'I' ? $info->{'request_size'} + $info->{'request_header_size'} : $4 eq 'O' ? $info->{'response_size'} + $info->{'response_header_size'} : $4 eq 'T' ? sprintf('%d', $info->{'elapsed'}) : $4 eq 'D' ? sprintf('%d', $info->{'elapsed'}/.000_001) : $4 eq '%' ? '%' : '-'; $v = '-' if !defined($v) || !length($v);x $v =~ s/([^\ -\!\#-\[\]-\~])/$1 eq "\n" ? '\n' : $1 eq "\t" ? '\t' : sprintf('\x%02X', ord($1))/eg; # escape non-printable or " or \ $v; }gxe; TEST test(<<'TEST'); # MLEHMANN/AnyEvent-GDB-0.2/GDB.pm sub _parse_value { if (/\G"/gc) { # c-string &_parse_c_string } elsif (/\G\{/gc) { # tuple my $r = &_parse_results; /\G\}/gc or die "tuple does not end with '}'\n"; $r } elsif (/\G\[/gc) { # list my @r; until (/\G\]/gc) { # if GDB outputs "result" in lists, let me know and uncomment the following lines # # list might also contain key value pairs, but apparently # # those are supposed to be ordered, so we use an array in perl. # push @r, $1 # if /\G([^=,\[\]\{\}]+)=/gc; push @r, &_parse_value; /\G,/gc or last; } /\G\]/gc or die "list does not end with ']'\n"; \@r } else { die "value expected\n"; } } TEST test(<<'TEST'); # DCONWAY/Dios-0.000007/lib/Dios.pm sub import { my (undef, $opt) = @_; # What kind of accessors were requested in this scope??? $^H{'Dios accessor_type'} = $opt->{accessor} // $opt->{accessors} // $opt->{acc} // q{standard}; # How should the invocants be named in this scope??? my $invocant_name = $opt->{invocant} // $opt->{inv} // q{$self}; if ($invocant_name =~ m{\A (\$?) ([^\W\d]\w*+) \Z}xms) { $^H{'Dios invocant_name'} = ($1||'$').$2; } else { _error "Invalid invocant specification: '$invocant_name'\nin 'use Dios' statement"; } # Class definitions are translated to encapsulated packages using OIO... keyword class (QualIdent $class_name, /is \s* (\w*)/x @bases?, Block $block) {{{ { package <{$class_name}>; use Object::InsideOut <{ @bases ? qq{qw{@bases}} : q{} }>; <{ substr($block,1,-1) }> } }}} # How to recognize a set of sub attributes... keytype Attrs { /(?x: \s* : \s* (?: [^\W\d]\w* (?: \( .*? \) )? \s* )* )+/ } # Function definitions are translated to subroutines with extra argument-unpacking code... keyword func (QualIdent $sub_name = q{}, List $parameter_list?, Attrs $attrs = q{}, Block $block) { # Generate code that unpacks and tests arguments... $parameter_list = _translate_parameters($parameter_list, func => "$sub_name"); # Peel the curlies from the block (because we're interpolating its code)... $block = substr($block,1,-1); # Assemble and return the method definition... qq{sub $sub_name $attrs { $parameter_list; $block } } =~ s/;/;\n/gr; } # Method definitions are translated to subroutines with extra invocant-and-argument-unpacking code... keyword method (QualIdent $sub_name = q{}, List $parameter_list?, Attrs $attrs = q{}, Block $block) { # Which kind of aliasing do we need (to create local vars bound to the object's fields)??? my $use_aliasing = $] < 5.022 ? q{use Data::Alias} : q{use experimental 'refaliasing'}; my $attr_binding = $^H{'Dios attrs'} ? "$use_aliasing; $^H{'Dios attrs'}" : q{}; # Generate code that unpacks and tests arguments... $parameter_list = _translate_parameters($parameter_list, method => "$sub_name"); # Peel the curlies from the block (because we're interpolating its code)... $block = substr($block,1,-1); # Assemble and return the method definition... qq{sub $sub_name $attrs { $attr_binding $parameter_list; $block } }; } # Submethod definitions are translated like methods, but with special re-routing... keyword submethod (QualIdent $sub_name = q{}, List $parameter_list?, Attrs $attrs = q{}, Block $block) { # Which kind of aliasing do we need (to create local vars bound to the object's fields)??? my $use_aliasing = $] < 5.022 ? q{use Data::Alias} : q{use experimental 'refaliasing'}; my $attr_binding = $^H{'Dios attrs'} ? "$use_aliasing; $^H{'Dios attrs'}" : q{}; # Handle any special submethod names... my $init_args = q{}; if ($sub_name eq 'BUILD') { # Extract named args for :InitArgs hash (TODO: this should pull out type/required info too)... my @param_names = $parameter_list =~ m{ : [\$\@%]? (\w++) }gxms; # Tell OIO about this constructor args... $init_args = qq{ BEGIN{ my %$sub_name :InitArgs = map { \$_ => '' } qw{@param_names}; } }; # Mark the sub as an initializer $attrs .= ' :Private :Init'; # Repack the arguments from ($self, {attr=>val, et=>cetera}) to ($self, attr=>val, et=>cetera)... $attr_binding = q{@_ = ($_[0], %{$_[1]});} . $attr_binding; } elsif ($sub_name eq 'DESTROY') { # Parameter list will never be satisfied (which breaks cleanup), so don't allow it at all... return q{die 'submethod DESTROY cannot have a parameter list';} if $parameter_list && $parameter_list !~ /^\(\s*+\)$/; # Mark it as a destructor... $attrs .= ' :Private :Destroy'; # Rename it so as not to clash with OIO's DESTROY... $sub_name = '___DESTROY___'; } else { $attr_binding = qq{ if ((ref(\$_[0])||\$_[0]) ne __PACKAGE__) { return \$_[0]->SUPER::$sub_name(\@_[1..\$#_]); } } . $attr_binding; } # Generate the code to unpack and test arguments... $parameter_list = _translate_parameters($parameter_list, method => "$sub_name"); # Peel the curlies from the block (because we're interpolating its code)... $block = substr($block,1,-1); # Assemble and return the method definition... qq{$init_args sub $sub_name $attrs { $attr_binding $parameter_list; $block } }; } # What does an attribute variable look like??? keytype HasVar { / .*? (?= [:;=] | \/\/= ) /x } # An attribute definition is translated into an array with a :Field attribute... keyword has (HasVar $variable, Attrs $attrs = q{}, ...';' $init) { _compose_field("$variable $attrs", $init) } # What does a shared attribute variable look like??? keytype SharedVar { / .*? (?: is | (?= [;=] | \/\/= ) ) /x } # An attribute definition is translated into an my var with extra code for accessors... keyword shared (SharedVar $variable, /r[wo]/ $access = q{}, ...';' $init) { _compose_shared("$variable $access", $init) } # Subtypes are handled by Dios::Types... keyword subtype from Dios::Types; } TEST test(<<'TEST'); # STRCMP/Batch-Interpreter-0.01/lib/Batch/Interpreter/TestSupport.pm sub quote_argument { $_ = shift; s/([\\\"])/\\$1/gi; return /[\s\\\"]/ ? "\"$_\"" : $_; } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/scan/format.t0000644000175100017510000001174014001101046022655 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use t::scan::Util; test(<<'TEST'); # RANDERSON/HTTP-WebTest-1.02/WebTest.pm my ($nbytes, $max_bytes, $min_bytes, $terse, $report, $num_fail, $num_succeed) = @_; my ($report_text, $result); format WRITE_NBYTES = @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<< $report_text, $result . if ($nbytes < 0) { warn "Invalid value of nbytes ( = $nbytes )"; return 0; } TEST test(<<'TEST'); # CNATION/Monkeywrench-1.0/lib/HTTP/Monkeywrench.pm if (($click->{'sendcookie'}) && ($self->settings->{'show_cookies'})) { my $cookie_to_print = $self->cookie_jar->as_string; $~ = "COOKIES"; write; format COOKIES = Cookie: ~~ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< $cookie_to_print . } my $failed = 0; my $success = 0; $content .= ' Code: ' . $res->code . ' ' . $res->message . "\n"; if ($res->is_redirect || $res->is_success) { $content .= " Match Res:\n" if ($click->{'success_res'}); foreach my $sr (@{ $click->{'success_res'} }) { my $result; if ($res->content =~ $sr) { $result = "PASS" if ($self->settings->{'match_detail'}); } else { $result = "FAIL"; $failed++; $totalerrs++; } pipe (RFH,WFH); format WFH = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>> $sr, $result . write WFH if ($result); close WFH; local $/ = undef; $content .= ; } $content .= " Match Error:\n" if ($click->{'error_res'}); foreach my $er (@{ $click->{'error_res'} }) { my $result; if ($res->content =~ $er) { $result = "FAIL"; $failed++; $totalerrs++; } else { $result = "PASS" if ($self->settings->{'match_detail'}); } pipe (ERR_RFH,ERR_WFH); format ERR_WFH = ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @>>>>>>>>>> $er, $result . write ERR_WFH if ($result); close ERR_WFH; local $/ = undef; $content .= ; } } else { $content .= " *** Request Failed ***\n"; #. $res->error_as_HTML; } TEST test(<<'TEST'); # MLEHMANN/Games-Sokoban-1.01/Sokoban.pm sub new_from_file { my ($class, $path, $format) = @_; open my $fh, "<:perlio", $path or Carp::croak "$path: $!"; local $/; $class->new (data => (scalar <$fh>), format => $format) } sub detect_format($) { my ($data) = @_; return "text" if $data =~ /^[ #\@\*\$\.\+\015\012\-_]+$/; return "rle" if $data =~ /^[ #\@\*\$\.\+\015\012\-_|1-9]+$/; my ($a, $b) = unpack "ww", $data; return "binpack" if defined $a && defined $b; Carp::croak "unable to autodetect sokoban level format"; } =item $level->data ([$new_data, [$new_data_format]]) Sets the level from the given data. =cut sub data { if (@_ > 1) { my ($self, $data, $format) = @_; $format ||= detect_format $data; if ($format eq "text" or $format eq "rle") { $data =~ y/-_|/ \n/; $data =~ s/(\d)(.)/$2 x $1/ge; my @lines = split /[\015\012]+/, $data; my $w = List::Util::max map length, @lines; $_ .= " " x ($w - length) for @lines; $self->{data} = join "\n", @lines; } elsif ($format eq "binpack") { (my ($w, $s), $data) = unpack "wwB*", $data; my @enc = ('#', '$', '.', ' ', ' ', '###', '*', '# '); $data = join "", map $enc[$_], unpack "C*", pack "(b*)*", unpack "(a3)*", $data; # clip extra chars (max. 2) my $extra = (length $data) % $w; substr $data, -$extra, $extra, "" if $extra; (substr $data, $s, 1) =~ y/ ./@+/; $self->{data} = join "\n", map "#$_#", "#" x $w, (unpack "(a$w)*", $data), "#" x $w; } else { Carp::croak "$format: unsupported sokoban level format requested"; } $self->{format} = $format; $self->update; } $_[0]{data} } TEST done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/00_load.t0000644000175100017510000000011514001101046021651 0ustar ishigakiishigakiuse strict; use warnings; use Test::UseAllModules; BEGIN { all_uses_ok(); } Perl-PrereqScanner-NotQuiteLite-0.9917/t/mojo_base.t0000644000175100017510000000125014001101046022372 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; # JHTHORSEN/Mandel-0.29/lib/Mandel/Model.pm test('basic', <<'END', {'Mojo::Base' => 0, 'Mandel::Document' => 0}); use Mojo::Base 'Mandel::Document'; END # JHTHORSEN/Mandel-0.29/lib/Mandel.pm test('Mojo::Base itself', <<'END', {'Mojo::Base' => 0}); use Mojo::Base 'Mojo::Base'; END test('-base', <<'END', {'Mojo::Base' => 0}); use Mojo::Base -base; END test('-strict', <<'END', {'Mojo::Base' => 0}); use Mojo::Base '-strict'; END test('package with a single quote', <<'END', {'Mojo::Base' => 0, 'Mojo::BaseTestTest' => 0}); use Mojo::Base "Mojo'BaseTestTest"; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/minimum_version.t0000644000175100017510000001605114001101046023661 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/.."; use Test::More; BEGIN { $ENV{PERL_PSNQL_MINVER} = 1 } use t::Util; test('say', <<'END', {perl => '5.010'}); say "hello"; END test('yada yada yada', <<'END', {perl => '5.012'}); ... END test('package PACKAGE VERSION', <<'END', {perl => '5.012'}); package Foo 3.14; END test('package PACKAGE { }', <<'END', {perl => '5.014'}); package Foo { } END test('package PACKAGE { }', <<'END', {perl => '5.014'}); package Foo { foo(); } END test('package PACKAGE VERSION { }', <<'END', {perl => '5.014'}); package Foo 3.14 { } END test('package PACKAGE VERSION { }', <<'END', {perl => '5.014'}); package Foo 3.14 { foo(); } END test('package PACKAGE VERSION { }', <<'END', {perl => '5.014'}); package Foo v0.0.1 { } END test('package PACKAGE VERSION { }', <<'END', {perl => '5.014'}); package Foo v0.0.1 { foo() } END test('use feature', <<'END', {perl => '5.010', feature => 0}); use feature; END test('use feature unicode_strings', <<'END', {perl => '5.012', feature => 0}); use feature "unicode_strings"; END test('use feature unicode_eval', <<'END', {perl => '5.016', feature => 0}); use feature "unicode_eval"; END test('use feature current_sub', <<'END', {perl => '5.016', feature => 0}); use feature "current_sub"; END test('use feature fc', <<'END', {perl => '5.016', feature => 0}); use feature "fc"; END test('use feature lexical_subs', <<'END', {perl => '5.018', feature => 0}); use feature "lexical_subs"; END test('use feature :5.14', <<'END', {perl => '5.014', feature => 0}); use feature ":5.14"; END test('use feature :5.16', <<'END', {perl => '5.016', feature => 0}); use feature ":5.16"; END test('use feature :5.18', <<'END', {perl => '5.018', feature => 0}); use feature ":5.18"; END test('defined_or', <<'END', {perl => '5.010'}); 1 // 2; END test('defined_or', <<'END', {perl => '5.010'}); $x //= 2; END test('smartmatch', <<'END', {perl => '5.010'}); 1 ~~ 2; END test('%+', <<'END', {perl => '5.010'}); %+; END test('$+{}', <<'END', {perl => '5.010'}); $+{"a"}; END test('@+{}', <<'END', {perl => '5.010'}); @+{"a"}; END test('%-', <<'END', {perl => '5.010'}); %-; END test('$-{}', <<'END', {perl => '5.010'}); $-{"a"}; END test('@-{}', <<'END', {perl => '5.010'}); @-{"a"}; END test('when', <<'END', {perl => '5.010'}); when (1) { } END test('when', <<'END', {perl => '5.010'}); when ([1,2,3]) { } END # TODO: sideff when is actually since 5.012 todo_test('sideff when', <<'END', {perl => '5.012'}); print "$_," when [1,2,3]; END test('when', <<'END', {perl => '5.010'}); warn; when (1) { foo(); } END test('split //', <<'END', {}); split // => 3; END test('split //', <<'END', {}); split //, 3; END test('split //', <<'END', {}); split //; END test('split //', <<'END', {}); (split //); END test('split //', <<'END', {}); {split //}; END test('split //', <<'END', {}); {split(//)}; END test('if //', <<'END', {}); if (//) { }; END test('map //', <<'END', {}); map //, 3; END test('grep //', <<'END', {}); grep //, 3; END test('time // time', <<'END', {perl => '5.010'}); time // time; END test('->$*', <<'END', {perl => '5.020'}); $sref->$*; END test('->@*', <<'END', {perl => '5.020'}); $aref->@*; END test('->%*', <<'END', {perl => '5.020'}); $href->%*; END test('->&*', <<'END', {perl => '5.020'}); $cref->&*; END test('->**', <<'END', {perl => '5.020'}); $gref->**; END test('->$#*', <<'END', {perl => '5.020'}); $aref->$#*; END test('->*{}', <<'END', {perl => '5.020'}); $gref->*{ $slot }; END test('->@[]', <<'END', {perl => '5.020'}); $aref->@[ ... ]; END test('->@[]', <<'END', {perl => '5.020'}); $aref->@[ foo() ]; END test('->@{}', <<'END', {perl => '5.020'}); $href->@{ ... }; END test('->@{}', <<'END', {perl => '5.020'}); $href->@{ foo() }; END test('->%[]', <<'END', {perl => '5.020'}); $aref->%[ ... ]; END test('->%[]', <<'END', {perl => '5.020'}); $aref->%[ foo() ]; END test('->%{}', <<'END', {perl => '5.020'}); $href->%{ ... }; END test('->%{}', <<'END', {perl => '5.020'}); $href->%{ foo() }; END test('proto', <<'END', {}); sub mylink ($$) { foo(); } sub myvec ($$$) { foo(); } sub myindex ($$;$) { foo(); } sub mysyswrite ($$$;$) { foo(); } sub myreverse (@) { foo(); } sub myjoin ($@) { foo(); } sub mypop (\@) { foo(); } sub mysplice (\@$$@) { foo(); } sub mykeys (\[%@]) { foo(); } sub myopen (*;$) { foo(); } sub mypipe (**) { foo(); } sub mygrep (&@) { foo(); } sub myrand (;$) { foo(); } sub mytime () { foo(); } END test('Catalyst controllers', <<'END', {}); sub my_handles : Path('handles') { ... } sub my_handles : Local { ... } sub my_handles : Regex('^handles') { ... } sub index :Path :Args(0) { ... } sub root : Chained('/') PathPart('/cd') CaptureArgs(1) { my ($self, $c, $cd_id) = @_; $c->stash->{cd_id} = $cd_id; $c->stash->{cd} = $self->model('CD')->find_by_id($cd_id); } END test('signatures', <<'END', {perl => '5.020'}); sub foo :lvalue ($a, $b = 1, @c) { .... } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($left, $right) { return $left + $right; } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($first, $, $third) { return "first=$first, third=$third"; } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($left, $right = 0) { return $left + $right; } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($first_name, $surname, $nickname = $first_name) { print "$first_name $surname is known as \"$nickname\""; } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($thing, $=) { print $thing; } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($filter, @inputs) { print $filter->($_) foreach @inputs; } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($thing, @) { print $thing; } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($filter, %inputs) { print $filter->($_, $inputs{$_}) foreach sort keys %inputs; } END test('signatures', <<'END', {perl => '5.020'}); sub foo ($thing, %) { print $thing; } END test(':prototype', <<'END', {perl => '5.020'}); sub foo :prototype($) { $_[0] } END test(':prototype', <<'END', {perl => '5.020'}); sub foo :prototype($$) ($left, $right) { return $left + $right; } END test('bitwise op', <<'END', {perl => '5.022'}); $a &. $b END test('bitwise op', <<'END', {perl => '5.022'}); $a |. $b END test('bitwise op', <<'END', {perl => '5.022'}); $a ^. $b END test('bitwise op', <<'END', {perl => '5.022'}); $a ~. $b END test('bitwise op', <<'END', {perl => '5.022'}); $a &.= $b END test('bitwise op', <<'END', {perl => '5.022'}); $a |.= $b END test('bitwise op', <<'END', {perl => '5.022'}); $a ^.= $b END test('<>', <<'END', {perl => '5.022'}); while(<>) { ... } END test('<<~', <<'END', {perl => '5.026'}); $var =<<~"HERE"; foo HERE END test('${^CAPTURE}', <<'END', {perl => '5.026'}); @{^CAPTURE}[0] END test('@{^CAPTURE}', <<'END', {perl => '5.026'}); @{^CAPTURE} END test('%{^CAPTURE}', <<'END', {perl => '5.026'}); %{^CAPTURE} END test('%{^CAPTURE_ALL}', <<'END', {perl => '5.026'}); %{^CAPTURE_ALL} END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/only.t0000644000175100017510000000160514001101046021421 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; # taken from only.pm SYNOPSIS test('only bare => version', <<'END', {only => 0, MyModule => '0.30'}); use only MyModule => 0.30; END test('only bare => version spec', <<'END', {only => 0, MyModule => 0}); use only MyModule => '0.30-0.50 !0.36 0.55-', qw(:all); END test('only bare => version spec', <<'END', {only => 0, MyModule => 0}); use only MyModule => [ '0.20-0.27', qw(f1 f2 f3 f4) ], [ '0.30-', qw(:all) ]; END test('only {}, module => version', <<'END', {only => 0, MyModule => '0.33'}); use only {versionlib => '/home/ingy/perlmods'}, MyModule => 0.33; END test('only {}', <<'END', {only => 0}); use only {versionlib => '/home/ingy/perlmods'}; END test('only qw/bare version/', <<'END', {only => 0, 'Test::More' => 0.88}); use only qw/Test::More 0.88/; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/prefork.t0000644000175100017510000000032014001101046022101 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('use prefork', <<'END', {prefork => 0, 'Test::More' => 0}); use prefork 'Test::More'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/15_eval.t0000644000175100017510000000660014001101046021674 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('if (eval)', <<'END', {}, {'Test::More' => 0}); if ( eval "require 'Test/More.pm';" ) { } END test('eval()', <<'END', {}, {'Test::More' => 0}); eval('use Test::More'); END test('eval{"string"}', <<'END', {}, {}); eval{'use Test::More'}; END test('eval heredoc', <<'END', {}, {'Test::More' => 0}); eval <<'EOF'; require Test::More; EOF END # adapted from NWELLNHOF/Lucy-0.6.1/buildlib/Lucy/Build/Binding/Misc.pm test('eval $VARIABLE (should not rescan the inside of the following heredoc)', <<'END', {strict => 0, warnings => 0}, {}); package Lucy::Build::Binding::Misc; use strict; use warnings; our $VERSION = '0.006001'; $VERSION = eval $VERSION; # (snip) sub bind_simple { my @hand_rolled = qw( Add_Doc ); $pod_spec->set_synopsis($synopsis); $pod_spec->add_constructor( sample => $constructor ); # Override is necessary because there's no standard way to explain # hash/hashref across multiple host languages. $pod_spec->add_method( method => 'Add_Doc', alias => 'add_doc', pod => $add_doc_pod, ); my $xs_code = <<'END_XS_CODE'; MODULE = Lucy PACKAGE = Lucy::Simple void add_doc(self, doc_sv) lucy_Simple *self; SV *doc_sv; PPCODE: { lucy_Doc *doc = NULL; // Either get a Doc or use the stock doc. if (sv_isobject(doc_sv) && sv_derived_from(doc_sv, "Lucy::Document::Doc") ) { IV tmp = SvIV(SvRV(doc_sv)); doc = INT2PTR(lucy_Doc*, tmp); } else if (XSBind_sv_defined(aTHX_ doc_sv) && SvROK(doc_sv)) { HV *maybe_fields = (HV*)SvRV(doc_sv); if (SvTYPE((SV*)maybe_fields) == SVt_PVHV) { lucy_Indexer *indexer = LUCY_Simple_Get_Indexer(self); doc = LUCY_Indexer_Get_Stock_Doc(indexer); LUCY_Doc_Set_Fields(doc, maybe_fields); } } if (!doc) { THROW(CFISH_ERR, "Need either a hashref or a %o", CFISH_Class_Get_Name(LUCY_DOC)); } LUCY_Simple_Add_Doc(self, doc); } END_XS_CODE my $binding = Clownfish::CFC::Binding::Perl::Class->new( parcel => "Lucy", class_name => "Lucy::Simple", ); $binding->exclude_method($_) for @hand_rolled; $binding->append_xs($xs_code); $binding->set_pod_spec($pod_spec); Clownfish::CFC::Binding::Perl::Class->register($binding); } END test('eval()', <<'END', {}, {'GD::Simple' => 0}); my $load_this_package=eval("require GD::Simple;"); END # TONYC/Imager-1.006/Imager.pm test('eval ()', <<'END', {}, {'Affix::Infix2Postfix' => 0}); sub transform { my $self=shift; my %opts=@_; my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre); # print Dumper(\%opts); # xopcopdes $self->_valid_image("transform") or return; if ( $opts{'xexpr'} and $opts{'yexpr'} ) { if (!$I2P) { { local @INC = @INC; pop @INC if $INC[-1] eq '.'; eval ("use Affix::Infix2Postfix;"); } } } } END test('use after eval $VERSION', <<'END', {strict => 0, Carp => 0}); use strict; our $VERSION = '7.24'; $VERSION = eval $VERSION; use Carp; END test('eval (shortcut)', <<'END', {strict => 0, Carp => 0}); use strict; our $VERSION = '7.24'; $VERSION = eval($VERSION); use Carp; END test('eval {shortcut}', <<'END', {strict => 0, Carp => 0}); use strict; our $VERSION = '7.24'; $VERSION = eval{$VERSION}; use Carp; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/class_autouse.t0000644000175100017510000000053414001101046023312 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('as a pragma', <<'END', {'Class::Autouse' => 0}, {}, {'CGI' => 0}); use Class::Autouse qw{CGI}; END test('method call', <<'END', {'Class::Autouse' => 0}, {}, {'CGI' => 0}); use Class::Autouse; Class::Autouse->autouse('CGI'); END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/Util.pm0000644000175100017510000001020414001101046021521 0ustar ishigakiishigakipackage t::Util; use strict; use warnings; use Test::More; use Perl::PrereqScanner::NotQuiteLite; use Perl::PrereqScanner::NotQuiteLite::App; use Exporter qw/import/; use File::Temp qw/tempdir/; use File::Basename qw/dirname/; use File::Path qw/mkpath rmtree/; use if (-d ".git" and !$ENV{PERL_PSNQL_DEBUG}), "Test::FailWarnings"; our @EXPORT = qw/ test todo_test used test_app test_file test_cpanfile test_bin /; our $EVAL; our $PARSERS; sub todo_test { SKIP: { local $TODO = "FIXME"; test(@_); } } sub test { my ($description, $string, $expected_requires, $expected_suggests, $expected_recommends, $expected_noes) = @_; subtest $description => sub { my $scanner = Perl::PrereqScanner::NotQuiteLite->new( parsers => $PARSERS || [qw/:bundled/], suggests => $expected_suggests ? 1 : 0, perl_minimum_version => ($ENV{PERL_PSNQL_MINVER} || 0), ); ok my $context = $scanner->scan_string($string); if ($expected_requires) { my $requires = $context->requires; my $requires_hash = $requires ? $requires->as_string_hash : {}; is_deeply $requires_hash => $expected_requires, "requires ok"; note explain $requires_hash; } if ($expected_suggests) { my $suggests = $context->suggests; my $suggests_hash = $suggests ? $suggests->as_string_hash : {}; is_deeply $suggests_hash => $expected_suggests, "suggests ok"; note explain $suggests_hash; } if ($expected_recommends) { my $recommends = $context->recommends; my $recommends_hash = $recommends ? $recommends->as_string_hash : {}; is_deeply $recommends_hash => $expected_recommends, "recommends ok"; note explain $recommends_hash; } if ($expected_noes) { my $noes = $context->noes; my $noes_hash = $noes ? $noes->as_string_hash : {}; is_deeply $noes_hash => $expected_noes, "noes ok"; note explain $noes_hash; } if ($EVAL) { eval "no strict; $string"; ok !$@, "no eval error"; note $@ if $@; } ok !@{$context->{errors} || []}, 'no errors' or note explain $context->{errors}; }; } sub used { return {map {$_ => 0} @_} } sub test_app { my ($description, $setup, $args, $expected) = @_; note $description; my $tmpdir = tempdir( 'PerlPrereqScannerNQLite_XXXX', CLEANUP => 1, TMPDIR => 1, ); $setup->($tmpdir); my $prereqs = Perl::PrereqScanner::NotQuiteLite::App->new( parsers => [':bundled'], base_dir => $tmpdir, recommends => 1, suggests => 1, %{$args || {}}, )->run->as_string_hash; for my $phase (sort keys %$expected) { for my $type (sort keys %{$expected->{$phase}}) { is_deeply $prereqs->{$phase}{$type} => $expected->{$phase}{$type}, "$phase $type ok"; } } note explain $prereqs; rmtree($tmpdir); } sub test_file { my ($file, $body) = @_; my $dir = dirname($file); mkpath($dir) unless -d $dir; open my $fh, '>', $file or die "$file: $!"; print $fh $body; } sub test_cpanfile { my ($description, $setup, $args, $expected) = @_; note $description; my $tmpdir = tempdir( 'PerlPrereqScannerNQLite_XXXX', CLEANUP => 1, TMPDIR => 1, ); $setup->($tmpdir); my $prereqs = Perl::PrereqScanner::NotQuiteLite::App->new( parsers => [':bundled'], base_dir => $tmpdir, recommends => 1, suggests => 1, save_cpanfile => 1, %{$args || {}}, )->run; my $file = "$tmpdir/cpanfile"; if (ok -f $file, "cpanfile exists") { my $got = do { open my $fh, '<', $file; local $/; <$fh> }; is $got => $expected; } rmtree($tmpdir); } sub test_bin { my ($description, $setup, $args, $expected) = @_; note $description; my $tmpdir = tempdir( 'PerlPrereqScannerNQLite_XXXX', CLEANUP => 1, TMPDIR => 1, ); $setup->($tmpdir); my $opt = join ' ', @{$args || []}; my $bin = "bin/scan-perl-prereqs-nqlite"; SKIP: { skip "bin not found", 1 unless -e $bin; # note "$^X $bin --base-dir $tmpdir --cpanfile $opt"; my $got = `$^X $bin --base-dir $tmpdir --cpanfile $opt`; $got =~ s/(?:\015\012|\015|\012)/\n/g; $got =~ s/\n+$//s; $expected =~ s/\n+$//s; is $got => $expected; } rmtree($tmpdir); } 1; Perl-PrereqScanner-NotQuiteLite-0.9917/t/moosex_declare.t0000644000175100017510000000561714001101046023440 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('Foo in t/lib/Foo.pm', <<'END', {'MooseX::Declare' => 0}); use MooseX::Declare; class Foo { has 'affe' => ( is => 'ro', isa => 'Str', ); method foo ($x) { $x } method inner { 23 } method bar ($moo) { "outer(${moo})-" . inner() } class ::Bar is mutable { method bar { blessed($_[0]) ? 0 : 1 } } class ::Baz { method baz {} } } END test('Role in t/lib/Foo.pm', <<'END', {'MooseX::Declare' => 0}); use MooseX::Declare; role Role { requires 'required_thing'; method role_method {} } END test('Moo::Kooh in t/lib/Foo.pm', <<'END', {'MooseX::Declare' => 0, Foo => 0, Role => 0}); use MooseX::Declare; class Moo::Kooh { extends 'Foo'; around foo ($x) { $x + 1 } augment bar ($moo) { "inner(${moo})" } method kooh {} method required_thing {} with 'Role'; } END test('Corge in t/lib/Foo.pm', <<'END', {'MooseX::Declare' => 0, 'Foo::Baz' => 0, Role => 0}); use MooseX::Declare; class Corge extends Foo::Baz with Role { method corge {} method required_thing {} } END test('Quux in t/lib/Foo.pm', <<'END', {'MooseX::Declare' => 0, 'Corge' => 0}); use MooseX::Declare; class Quux extends Corge { has 'x' => ( is => 'ro', isa => 'Int', ); method quux {} } END test('SecondRole in t/lib/Foo.pm', <<'END', {'MooseX::Declare' => 0}); use MooseX::Declare; role SecondRole {} END test('SecondRole in t/lib/Foo.pm', <<'END', {'MooseX::Declare' => 0, 'Role' => 0, 'SecondRole' => 0}); use MooseX::Declare; class MultiRole with Role with SecondRole { method required_thing {} } END test('SecondRole in t/lib/Foo.pm', <<'END', {'MooseX::Declare' => 0, 'Role' => 0, 'SecondRole' => 0}); use MooseX::Declare; class MultiRole2 with (Role, SecondRole) { method required_thing {} } END test('manual namespace', <<'END', {'MooseX::Declare' => 0, 'Foo::Bar::Baz' => 0, 'Foo::Bar::Fnording' => 0}); use MooseX::Declare; namespace Foo::Bar; sub base { __PACKAGE__ } class ::Baz { sub TestPackage::baz { __PACKAGE__ } } role ::Fnording { sub TestPackage::fnord { __PACKAGE__ } } class ::Qux extends ::Baz with ::Fnording { sub TestPackage::qux { __PACKAGE__ } } END test('manual namespace', <<'END', {'MooseX::Declare' => 0, 'Foo::Z' => 0, 'Foo::A' => 0, 'Foo::B' => 0, 'Foo::C' => 0}); use MooseX::Declare; namespace Foo; role ::Z { method foo (Int $x) { $x } } role ::C { with '::Z'; around foo (Int $x) { $self->$orig(int($x / 3)) } } role ::B { with '::C'; around foo (Int $x) { $self->$orig($x + 2) } } role ::A { with '::B'; around foo (Int $x) { $self->$orig($x * 2) } } class TEST { with '::A'; around foo (Int $x) { $self->$orig($x + 2) } } class AnotherTest { with '::Z'; around foo (Int $x) { $self->$orig($x * 2) } } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/package_variant.t0000644000175100017510000000343714001101046023564 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/.."; use Test::More; use t::Util; test('', <<'END', {'Package::Variant' => 0}); # MAT/DBIx-Class-Helper-ResultSet-EnumMethods-0.01/lib/DBIx/Class/Helper/ResultSet/EnumMethods.pm use Package::Variant 'install' => 1, 'importing' => ['Moo::Role']; END test('no importing', <<'END', {'Package::Variant' => 0}); # MSTROUT/Package-Variant-1.003002/t/01simple.t use Package::Variant (); END test('importing with a scalar', <<'END', {'Package::Variant' => 0, 'TestImportableA' => 0}); # MSTROUT/Package-Variant-1.003002/t/01simple.t use Package::Variant importing => 'TestImportableA'; END test('importing with an arrayref', <<'END', {'Package::Variant' => 0, 'Data::Record::Serialize::Role::Base' => 0, 'Moo' => 0}); # DJERIUS/Data-Record-Serialize-0.07/lib/Data/Record/Serialize.pm use Package::Variant importing => ['Moo'], subs => [qw( with has )]; ... with 'Data::Record::Serialize::Role::Base'; END test('importing with extra arg', <<'END', {'Package::Variant' => 0, 'MooX::Role' => 0}); # SHLOMIF/XML-GrammarBase-0.2.6/lib/XML/GrammarBase/Role/XSLT.pm use Package::Variant importing => [ 'MooX::Role' => ['late'], ], subs => [qw(has with)]; END test('importing with a hashref', <<'END', {'Package::Variant' => 0, 'Moo::Role' => 0}); # ILMARI/SQL-Translator-0.11024/lib/SQL/Translator/Role/ListAttr.pm use Package::Variant ( importing => { 'Moo::Role' => [], }, subs => [qw(has around)], ); END test('version and importing', <<'END', {'Package::Variant' => '1.002000', 'Moo' => 0, 'MooX::StrictConstructor' => 0}); # RJBS/HTTP-Throwable-0.026/lib/HTTP/Throwable/Variant.pm use Package::Variant 1.002000 importing => ['Moo', 'MooX::StrictConstructor'], subs => [ qw(extends with) ]; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/plack.t0000644000175100017510000000320114001101046021524 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('enable', <<'END', {'Plack::Builder' => 0, 'Plack::Middleware::Foo' => 0}); use Plack::Builder; builder { enable 'Foo'; }; END test('enable plus', <<'END', {'Plack::Builder' => 0, 'Foo' => 0}); use Plack::Builder; builder { enable '+Foo'; }; END test('enable full', <<'END', {'Plack::Builder' => 0, 'Plack::Middleware::Foo' => 0}); use Plack::Builder; builder { enable 'Plack::Middleware::Foo'; } END test('enable_if', <<'END', {'Plack::Builder' => 0, 'Plack::Middleware::Foo' => 0}); use Plack::Builder; builder { enable_if { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' } 'Foo'; }; END test('enable_if plus', <<'END', {'Plack::Builder' => 0, 'Foo' => 0}); use Plack::Builder; builder { enable_if { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' } '+Foo'; }; END test('enable_if full', <<'END', {'Plack::Builder' => 0, 'Plack::Middleware::Foo' => 0}); use Plack::Builder; builder { enable_if { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' } 'Plack::Middleware::Foo'; }; END test('enable_if, sub', <<'END', {'Plack::Builder' => 0, 'Plack::Middleware::Foo' => 0}); use Plack::Builder; builder { enable_if sub { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' }, 'Foo'; }; END test('enable_if plus, sub', <<'END', {'Plack::Builder' => 0, 'Foo' => 0}); use Plack::Builder; builder { enable_if sub { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' }, '+Foo'; }; END test('enable_if full, sub', <<'END', {'Plack::Builder' => 0, 'Plack::Middleware::Foo' => 0}); use Plack::Builder; builder { enable_if sub { $_[0]->{REMOTE_ADDR} eq '127.0.0.1' }, 'Plack::Middleware::Foo'; }; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/class_load.t0000644000175100017510000000406214001101046022544 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('load_class', <<'END', {'Class::Load' => 0, 'Test::More' => 0}); use Class::Load 'load_class'; load_class('Test::More'); END test('conditional load_class', <<'END', {'Class::Load' => 0}, {}, {'Test::More' => 0}); use Class::Load 'load_class'; if (1) { load_class('Test::More'); } END test('load_class in a sub', <<'END', {'Class::Load' => 0}, {}, {'Test::More' => 0}); use Class::Load 'load_class'; sub foo { load_class('Test::More'); } END test('load_class in BEGIN', <<'END', {'Class::Load' => 0, 'Test::More' => 0}); use Class::Load 'load_class'; BEGIN { load_class('Test::More'); } END test('load_class with -version', <<'END', {'Class::Load' => 0, 'Test::More' => '0.01'}); use Class::Load ':all'; load_class('Test::More', {-version => '0.01'}); END test('try_load_class', <<'END', {'Class::Load' => 0}, {'Test::More' => 0}); use Class::Load 'try_load_class'; try_load_class('Test::More'); END test('try_load_class with -version', <<'END', {'Class::Load' => 0}, {'Test::More' => '0.01'}); use Class::Load ':all'; try_load_class('Test::More', {-version => '0.01'}); END test('load_first_existing_class', <<'END', {'Class::Load' => 0}, {strict => 0, warnings => 0}); use Class::Load 'load_first_existing_class'; load_first_existing_class('strict', 'warnings'); END test('load_first_existing_class with -version', <<'END', {'Class::Load' => 0}, {'strict' => '0.01', warnings => 0, 'Test::More' => '0.02'}); use Class::Load ':all'; load_first_existing_class('strict', {-version => '0.01'}, 'warnings', 'Test::More', {-version => '0.02'}); END test('Class::Load::load_class', <<'END', {'Class::Load' => 0, 'Test::More' => 0}); use Class::Load; Class::Load::load_class('Test::More'); END # ALEXBIO/App-gist-0.16/lib/App/gist.pm test('try_load_class with if', <<'END', {'Class::Load' => 0}, {'Config::Identity::GitHub' => 0}); use Class::Load 'try_load_class'; my %identity = Config::Identity::GitHub -> load if try_load_class('Config::Identity::GitHub'); END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/object_pad.t0000644000175100017510000001726714117442452022566 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('basic class', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Foo; END test('basic class version', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Foo 1.00; END test('basic role', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo; END test('basic role version', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo 1.00; END # simple isa/does test('basic class isa', <<'END', {'Object::Pad' => 0, 'Bar' => 0}); use Object::Pad; class Foo isa Bar; END test('basic class version isa', <<'END', {'Object::Pad' => 0, 'Bar' => 0}); use Object::Pad; class Foo 1.00 isa Bar; END test('basic class isa base version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00'}); use Object::Pad; class Foo isa Bar 2.00; END test('basic class version isa base version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00'}); use Object::Pad; class Foo 1.00 isa Bar 2.00; END test('basic class does', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => 0}); use Object::Pad; class Foo does Bar, Baz; END test('basic class version does', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => 0}); use Object::Pad; class Foo 1.00 does Bar, Baz; END test('basic class does role version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00'}); use Object::Pad; class Foo does Bar 2.00, Baz 3.00; END test('basic class version does role version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00'}); use Object::Pad; class Foo 1.00 does Bar 2.00, Baz 3.00; END test('basic class does role, role version', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => '3.00'}); use Object::Pad; class Foo does Bar Baz 3.00; END test('basic class version does role, role version', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => '3.00'}); use Object::Pad; class Foo 1.00 does Bar, Baz 3.00; END # both isa and does test('basic class does role version isa base', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo does Bar 2.00, Baz 3.00 isa Quux 4.00; END test('basic class version does role version isa base', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo 1.00 does Bar 2.00, Baz 3.00 isa Quux 4.00; END test('basic class isa base does role version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo isa Quux 4.00 does Bar 2.00, Baz 3.00; END test('basic class version isa base does role version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo 1.00 isa Quux 4.00 does Bar 2.00, Baz 3.00; END # class/role attributes test('basic class does role version isa base :attr', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo does Bar 2.00, Baz 3.00 isa Quux 4.00 :repr(native), :repr(default), :strict(params); END test('basic class version does role version isa base :attr', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo 1.00 does Bar 2.00, Baz 3.00 isa Quux 4.00 :repr(native), :repr(default), :strict(params) END test('basic role :attr', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo :compat(invokable); END test('basic role version :attr', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo 1.00 :compat(invokable); END # internal classes/roles test('basic class version isa internal class', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Bar; class Foo 1.00 isa Bar; END test('basic class isa internal class version', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Bar; class Foo isa Bar 2.00; END test('basic class version isa internal class version', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Bar; class Foo 1.00 isa Bar 2.00; END test('basic class version does internal role', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Bar; class Foo 1.00 does Bar; END test('basic class does internal role version', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Bar; class Foo does Bar 2.00; END test('basic class version does internal role version', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Bar; class Foo 1.00 does Bar 2.00; END # class/role blocks #### test('basic class {}', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Foo { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version {}', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Foo 1.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic role {}', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic role version {}', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo 1.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END # simple isa/does test('basic class isa {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0}); use Object::Pad; class Foo isa Bar { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version isa {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0}); use Object::Pad; class Foo 1.00 isa Bar { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class isa base version {}', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00'}); use Object::Pad; class Foo isa Bar 2.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version isa base version {}', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00'}); use Object::Pad; class Foo 1.00 isa Bar 2.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class does {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => 0}); use Object::Pad; class Foo does Bar, Baz { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version does {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => 0}); use Object::Pad; class Foo 1.00 does Bar, Baz { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class does role version {}', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00'}); use Object::Pad; class Foo does Bar 2.00, Baz 3.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version does role version {}', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00'}); use Object::Pad; class Foo 1.00 does Bar 2.00, Baz 3.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class does role, role version {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => '3.00'}); use Object::Pad; class Foo does Bar Baz 3.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version does role, role version {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => '3.00'}); use Object::Pad; class Foo 1.00 does Bar, Baz 3.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/moose/0000755000175100017510000000000014422514733021415 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/moose/moose.t0000644000175100017510000000167314001101046022711 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test('both extends and with', <<'END', {'Moose' => 0, 'Test::More' => 0, 'Exporter' => 0}); use Moose; extends 'Test::More'; with 'Exporter'; END test('with', <<'END', {'Moo::Role' => 0, 'Test::More' => 0}); use Moo::Role; with 'Test::More'; END test('extends', <<'END', {'Mo' => 0, 'Test::More' => 0}); use Mo; extends 'Test::More'; END test('Moose-like module that does not have Moose in its name', <<'END', {'Moxie' => 0, 'Test::More' => 0, 'Exporter' => 0}); use Moxie; extends 'Test::More'; with 'Exporter'; END test('Moose::Role-like module that does not have Role in its name', <<'END', {'Test::Routine' => 0, 'Test::More' => 0}); use Test::Routine; with 'Test::More'; END test('Mo-like module that does not have Moose in its name', <<'END', {'Pegex::Base' => 0, 'Test::More' => 0}); use Pegex::Base; extends 'Test::More'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/moose/no_moose.t0000644000175100017510000000040714001101046023377 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test('no moose', <<'END', {Moose => 0, Foo => 0}); use Moose; extends qw/Foo/; no Moose; extends qw/Bar/; # this should be from something else END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/moose/class_accessor.t0000644000175100017510000000066214001101046024553 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test('class accessor with antlers', <<'END', {'Class::Accessor' => 0, 'Test::More' => 0}); use Class::Accessor 'antlers'; extends 'Test::More'; END test('class accessor moose-like with version', <<'END', {'Class::Accessor' => 0.34, 'Test::More' => 0}); use Class::Accessor 0.34 'mooselike'; extends 'Test::More'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/moose/todo.t0000644000175100017510000000065514117442452022554 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; plan skip_all => 'TODO'; test('too early extends', <<'END', {Moose => 0, 'UNIVERSAL::require' => 0, 'Test::Run::CmdLine' => 0, 'Test::Run::Base' => 0}); # SHLOMIF/Test-Run-CmdLine-0.0131/lib/Test/Run/CmdLine/Iface.pm extends ('Test::Run::Base'); use UNIVERSAL::require; use Test::Run::CmdLine; use Moose; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/moose/extends_inner_package.t0000644000175100017510000000067614001101046026111 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test('exclude inner package', <<'END', {'Moose' => 0, 'Exporter' => 0}); package Foo; package main; use Moose; extends 'Foo'; with 'Exporter'; END test('exclude inner package with comment', <<'END', {'Moose' => 0, 'Exporter' => 0}); package # hide from PAUSE Foo; package main; use Moose; extends 'Foo'; with 'Exporter'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/moose/any_moose.t0000644000175100017510000000266414001101046023561 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test('with names that look like a part of a module, and imports', <<'END', {'Any::Moose' => 0}, {}, {'Mouse::Util' => 0, 'Mouse::Util::TypeConstraints' => 0}); use Any::Moose ( '::Util::TypeConstraints' => ['subtype'], '::Util' => ['does_role'], ); END test('only with names that look like a part of a module', <<'END', {'Any::Moose' => 0}, {}, {'Mouse::Util' => 0, 'Mouse::Util::TypeConstraints' => 0}); use Any::Moose qw( ::Util::TypeConstraints ::Util ); END test('with a name that looks like a module', <<'END', {'Any::Moose' => 0}, {}, {'MouseX::Types' => 0}); use Any::Moose 'X::Types'; END test('both extends and with', <<'END', {'Any::Moose' => 0, 'Test::More' => 0, 'Exporter' => 0}); use Any::Moose; extends 'Test::More'; with 'Exporter'; END test('extends with any_moose with a name that looks like a part of a module', <<'END', {'Any::Moose' => 0}, {}, {'Mouse::Meta::Class' => 0}); use Any::Moose; extends any_moose('::Meta::Class'); END test('extends with any_moose with a name that looks like a module', <<'END', {'Any::Moose' => 0}, {}, {'MouseX::Types' => 0}); use Any::Moose; extends any_moose(qw/X::Types/); END test('extends with any_moose without ()', <<'END', {'Any::Moose' => 0}, {}, {'Mouse::Meta::Class' => 0, 'Mouse::Util' => 0}); use Any::Moose; extends any_moose '::Meta::Class', '::Util'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/moose/with_variable.t0000644000175100017510000000055414001101046024404 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test('with variable', <<'END', {Mouse => 0}); use Mouse; sub load_plugin { my ($self, $plugin) = @_; my $plug = 'TheEye::Plugin::'.$plugin; print STDERR "Loading $plugin Plugin\n" if $self->is_debug; with($plug); return; } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/catalyst.t0000644000175100017510000000175514001101046022272 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; # from Catalyst's pod test('qw', <<'END', {Catalyst => 0, 'Catalyst::Plugin::My::Module' => 0, 'Fully::Qualified::Plugin::Name' => 0}); use Catalyst qw/ My::Module +Fully::Qualified::Plugin::Name /; END # GSHANK/HTML-FormHandler-Model-DBIC-0.29/t/lib/BookDB.pm test('-debug', <<'END', {Catalyst => 0, 'Catalyst::Plugin::Static::Simple' => 0}); use Catalyst ('-Debug', 'Static::Simple', ); END # FLORA/Catalyst-Engine-Apache-1.16/t/lib/PluginTestApp.pm # TestApp::Plugin::ParameterizedRole is ignored for now test('eval', <<'END', {Catalyst => 0, 'Catalyst::Plugin::Test::Plugin' => 0, 'TestApp::Plugin::FullyQualified' => 0}); use Catalyst ( 'Test::Plugin', '+TestApp::Plugin::FullyQualified', (eval { require MooseX::Role::Parameterized; 1 } ? ('+TestApp::Plugin::ParameterizedRole' => { method_name => 'affe' }) : ()), ); END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/inline.t0000644000175100017510000000311014001101046021707 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; # DAVECROSS/Ogg-Vorbis-Header-0.05/Header.pm test('Inline C', <<'END', {Inline => 0, 'Inline::C' => 0}); use Inline C => 'DATA', LIBS => '-logg -lvorbis -lvorbisfile', INC => '-I/inc', AUTO_INCLUDE => '#include "inc/vcedit.h"', AUTO_INCLUDE => '#include "inc/vcedit.c"', VERSION => '0.05', NAME => 'Ogg::Vorbis::Header'; END # MIKFIRE/Tivoli-AccessManager-Admin-1.11/Admin.pm test('Inline C with parenthesis', <<'END', {Inline => 0, 'Inline::C' => 0}); use Inline( C => 'DATA', NAME => 'Tivoli::AccessManager::Admin', VERSION => '1.11' ); END # STURM/Tibco-Rv-1.15/Rv.pm test('with option', <<'END', {Inline => 0, 'Inline::C' => 0, 'Tibco::Rv::Inline' => 0}); use Inline with => 'Tibco::Rv::Inline'; use Inline C => 'DATA', NAME => __PACKAGE__, VERSION => $Tibco::Rv::Inline::VERSION; END # PATL/Inline-Java-0.53/Java/PerlInterpreter/PerlInterpreter.pm test('Inline::Java without VERSION', <<'END', {Inline => 0, 'Inline::Java' => 0}); use Inline ( Java => 'STUDY', EMBEDDED_JNI => 1, STUDY => [], NAME => 'Inline::Java::PerlInterpreter', ) ; END # INGY/Inline-0.80/example/modules/Boo-2.01/lib/Boo/Far.pm test('with Config', <<'END', {Inline => 0, 'Inline::C' => 0}); use Inline Config => NAME => 'Boo::Far' => VERSION => '2.01'; use Inline C => <<'EOC'; SV * boofar() { return(newSVpv("Hello from Boo::Far", 0)); } EOC END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/12_no.t0000644000175100017510000000221014001101046021347 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('no pragma', <<'END', undef, undef, undef, {strict => 0, warnings => 0}); no strict; no warnings; END test('no Module', <<'END', undef, undef, undef, {'FindBin' => 0, 'Time::Local' => 0}); no FindBin; no Time::Local; END test('no Module Version', <<'END', undef, undef, undef, {'FindBin' => 0.01, 'Time::Local' => '0.02'}); no FindBin 0.01; no Time::Local 0.02; END test('no v-string', <<'END', undef, undef, undef, {perl => 'v5.20.1'}); no v5.20.1; END test('no version_number', <<'END', undef, undef, undef, {perl => '5.008001'}); no 5.008001; END test('no Module ()', <<'END', undef, undef, undef, {'Time::Local' => 0}); no Time::Local (); END test('no Module version ()', <<'END', undef, undef, undef, {'Time::Local' => 0.01}); no Time::Local 0.01 (); END test('no Module qw(args)', <<'END', undef, undef, undef, {'Time::Local' => 0}); no Time::Local qw(timelocal); END test('no lib', <<'END', undef, undef, undef, {lib => 0, constant => 0, FindBin => 0}); no FindBin; no lib "$FindBin::Bin/../lib"; no constant FOO => 'BAR'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/aliased.t0000644000175100017510000000063514001101046022044 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('with a string', <<'END', {aliased => 0, 'DateTime' => 0}); use aliased 'DateTime' => 'DT'; END test('with bare name', <<'END', {aliased => 0, 'DateTime' => 0}); use aliased DateTime => 'DT'; END test('with qw', <<'END', {aliased => 0, 'DateTime' => 0}); use aliased qw/DateTime/ => 'DT'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/compat/0000755000175100017510000000000014422514733021556 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/compat/perl_prereqscanner/0000755000175100017510000000000014422514733025450 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/compat/perl_prereqscanner/autoprereq.t0000644000175100017510000003124514001101046030007 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../../"; use Test::More; use t::Util; our $TEST_SEPARATE_VERSION = 0; our $TEST_NOREQUIRE = 0; test('empty string', '', {}); test("line ".__LINE__, 'use Use::NoVersion;', { 'Use::NoVersion' => 0 }); test("line ".__LINE__, 'use Use::Version 0.50;', { 'Use::Version' => '0.50' }); test("line ".__LINE__, 'use Errno 0.50;', { 'Errno' => '0.50' }); test("line ".__LINE__, 'require Require;', { Require => 0 }); test("line ".__LINE__, 'use Use::Version 0.50; use Use::Version 1.00;', { 'Use::Version' => '1.00', }, ); test("line ".__LINE__, 'use Use::Version 1.00; use Use::Version 0.50;', { 'Use::Version' => '1.00', }, ); test("line ".__LINE__, 'use Import::IgnoreAPI require => 1;', { 'Import::IgnoreAPI' => 0 }, ); test("line ".__LINE__, 'no Import::IgnoreAPI require => 1;', undef, undef, undef, { 'Import::IgnoreAPI' => 0 }, ); test("line ".__LINE__, 'require Require; Require->VERSION(0.50);', { Require => '0.50' }); test("line ".__LINE__, 'use Require; Require->VERSION(0.50);', { Require => '0.50' }); test("line ".__LINE__, 'require Require; Require->VERSION(+0.50);', { Require => 0 }); test("line ".__LINE__, 'require Require; foo(); Require->VERSION(1.00);', { Require => 0 }) if $TEST_SEPARATE_VERSION; test("line ".__LINE__, 'require Require; Require->VERSION(v1.0.50);', { Require => 'v1.0.50' } ); test("line ".__LINE__, q{require Require; Require->VERSION('v1.0.50');}, { Require => 'v1.0.50' } ); test("line ".__LINE__, 'require Require; Require->VERSION(q[1.00]);', { Require => '1.00' } ); test("line ".__LINE__, 'require Require; Require::Other->VERSION(1.00);', { Require => 0 } ); test('require with comment', <<'END REQUIRE WITH COMMENT', require Require::This; # this comment shouldn't matter Require::This->VERSION(0.450); END REQUIRE WITH COMMENT { 'Require::This' => '0.450' } ); test("line ".__LINE__, 'require Require; Require->VERSION(0.450) if some_condition; ', { 'Require' => 0 } ); # Moose features # (added 'use Moose;' to everything to trigger Moose parsers) test("line ".__LINE__, 'use Moose; extends "Foo::Bar";', { 'Moose' => 0, 'Foo::Bar' => 0, }, ); test("line ".__LINE__, 'use Moose; extends "Foo::Bar"; extends "Foo::Baz";', { 'Moose' => 0, 'Foo::Bar' => 0, 'Foo::Baz' => 0, }, ); test("line ".__LINE__, "use Moose; with 'With::Single';", { 'Moose' => 0, 'With::Single' => 0 }); test("line ".__LINE__, "use Moose; extends 'Extends::List1', 'Extends::List2';", { 'Moose' => 0, 'Extends::List1' => 0, 'Extends::List2' => 0, }, ); test("line ".__LINE__, "use Moose; within('With::Single');", { Moose => 0 }); test("line ".__LINE__, "use Moose; with 'With::Single', 'With::Double';", { 'Moose' => 0, 'With::Single' => 0, 'With::Double' => 0, }, ); test("line ".__LINE__, "use Moose; with 'With::Single' => { -excludes => 'method'}, 'With::Double';", { 'Moose' => 0, 'With::Single' => 0, 'With::Double' => 0, }, ); test("line ".__LINE__, 'use Moose; with ("With::QW1", "With::QW2");', { 'Moose' => 0, 'With::QW1' => 0, 'With::QW2' => 0, }, ); test("line ".__LINE__, "use Moose; with('Paren::Role');", { 'Moose' => 0, 'Paren::Role' => 0, }, ); test("line ".__LINE__, 'use Moose; with("With::QW1", "With::QW2");', { 'Moose' => 0, 'With::QW1' => 0, 'With::QW2' => 0, }, ); test("line ".__LINE__, 'use Moose; with qw(With::QW1 With::QW2);', { 'Moose' => 0, 'With::QW1' => 0, 'With::QW2' => 0, }, ); test("line ".__LINE__, 'use Moose; with "::Foo"', { Moose => 0 }, ); test("line ".__LINE__, 'use Moose; extends qw(Extends::QW1 Extends::QW2);', { 'Moose' => 0, 'Extends::QW1' => 0, 'Extends::QW2' => 0, }, ); test("line ".__LINE__, 'use base "Base::QQ1";', { 'Base::QQ1' => 0, base => 0, }, ); test("line ".__LINE__, 'use base 10 "Base::QQ1";', { 'Base::QQ1' => 0, base => 10, }, ); test("line ".__LINE__, 'use base qw{ Base::QW1 Base::QW2 };', { 'Base::QW1' => 0, 'Base::QW2' => 0, base => 0 }, ); test("line ".__LINE__, 'use parent "Parent::QQ1";', { 'Parent::QQ1' => 0, parent => 0, }, ); test("line ".__LINE__, 'use parent 10 "Parent::QQ1";', { 'Parent::QQ1' => 0, parent => 10, }, ); test("line ".__LINE__, 'use parent 2 "Parent::QQ1"; use parent 2 "Parent::QQ2"', { 'Parent::QQ1' => 0, 'Parent::QQ2' => 0, parent => 2, }, ); test("line ".__LINE__, 'use parent 2 "Parent::QQ1"; use parent 1 "Parent::QQ2"', { 'Parent::QQ1' => 0, 'Parent::QQ2' => 0, parent => 2, }, ); test("line ".__LINE__, 'use parent qw{ Parent::QW1 Parent::QW2 };', { 'Parent::QW1' => 0, 'Parent::QW2' => 0, parent => 0, }, ); # test case for #55713: support for use parent -norequire # ...but is this ok??? test("line ".__LINE__, 'use parent -norequire, qw{ Parent::QW1 Parent::QW2 };', { 'Parent::QW1' => 0, 'Parent::QW2' => 0, parent => 0, }, ) if $TEST_NOREQUIRE; test("line ".__LINE__, 'use superclass "superclass::QQ1";', { 'superclass::QQ1' => 0, superclass => 0, }, ); test("line ".__LINE__, 'use superclass 10 "superclass::QQ1", 1.23;', { 'superclass::QQ1' => 1.23, superclass => 10, }, ); test("line ".__LINE__, 'use superclass 2 "superclass::QQ1"; use superclass 2 "superclass::QQ2"', { 'superclass::QQ1' => 0, 'superclass::QQ2' => 0, superclass => 2, }, ); test("line ".__LINE__, 'use superclass 2 "superclass::QQ1", "v1.2.3"; use superclass 1 "superclass::QQ1", "v1.2.4"', { 'superclass::QQ1' => "v1.2.4", superclass => 2, }, ); test("line ".__LINE__, 'use superclass qw{ superclass::QW1 1.23 };', { 'superclass::QW1' => 1.23, superclass => 0, }, ); # test case for #55713: support for use superclass -norequire test("line ".__LINE__, 'use superclass -norequire, qw{ superclass::QW1 superclass::QW2 };', { 'superclass::QW1' => 0, 'superclass::QW2' => 0, superclass => 0, }, ) if $TEST_NOREQUIRE; test("line ".__LINE__, 'use superclass -norequire, "superclass::QW1" => 1.23, "superclass::QW2";', { 'superclass::QW1' => 1.23, 'superclass::QW2' => 0, superclass => 0, }, ) if $TEST_NOREQUIRE; # test case for #55851: require $foo test("line ".__LINE__, 'my $foo = "Carp"; require $foo', {}, ); test("line ".__LINE__, q{use strict; use warnings; use lib '.'; use feature ':5.10';}, { strict => 0, warnings => 0, lib => 0, feature => 0 }, ); test("line ".__LINE__, q{use Test::More; is 0, 1; done_testing}, { 'Test::More' => '0.88', }, ); # test cases for Moose 1.03 -version extension test("line ".__LINE__, 'use Moose; extends "Foo::Bar"=>{-version=>"1.1"};', { 'Moose' => 0, 'Foo::Bar' => '1.1', }, ); test("line ".__LINE__, 'use Moose; extends "Foo::Bar" => { -version => \'1.1\' };', { 'Moose' => 0, 'Foo::Bar' => '1.1', }, ); test("line ".__LINE__, 'use Moose; extends "Foo::Bar" => { -version => 13.3 };', { 'Moose' => 0, 'Foo::Bar' => '13.3', }, ); test("line ".__LINE__, 'use Moose; extends "Foo::Bar" => { -version => \'1.1\' }; extends "Foo::Baz" => { -version => 5 };', { 'Moose' => 0, 'Foo::Bar' => '1.1', 'Foo::Baz' => 5, }, ); test("line ".__LINE__, 'use Moose; extends "Foo::Bar"=>{-version=>1},"Foo::Baz"=>{-version=>2};', { 'Moose' => 0, 'Foo::Bar' => 1, 'Foo::Baz' => 2, }, ); test("line ".__LINE__, 'use Moose; extends "Foo::Bar" => { -version => "4.3.2" }, "Foo::Baz" => { -version => 2.44894 };', { 'Moose' => 0, 'Foo::Bar' => 'v4.3.2', 'Foo::Baz' => 2.44894, }, ); test("line ".__LINE__, 'use Moose; with "With::Single" => { -excludes => "method", -version => "1.1.1" }, "With::Double";', { 'Moose' => 0, 'With::Single' => 'v1.1.1', 'With::Double' => 0, }, ); test("line ".__LINE__, 'use Moose; with "With::Single" => { -wow => { -wow => { a => b } }, -version => "1.1.1" }, "With::Double";', { 'Moose' => 0, 'With::Single' => 'v1.1.1', 'With::Double' => 0, }, ); test("line ".__LINE__, 'use Moose; with "With::Single" => { -exclude => "method", -version => "1.1.1" }, "With::Double" => { -exclude => "foo" };', { 'Moose' => 0, 'With::Single' => 'v1.1.1', 'With::Double' => 0, }, ); test("line ".__LINE__, 'use Moose; with("Foo::Bar");', { 'Moose' => 0, 'Foo::Bar' => 0, }, ); test("line ".__LINE__, 'use Moose; with( "Foo::Bar" );', { 'Moose' => 0, 'Foo::Bar' => 0, }, ); test("line ".__LINE__, 'use Moose; with( "Foo::Bar", "Bar::Baz" );', { 'Moose' => 0, 'Foo::Bar' => 0, 'Bar::Baz' => 0, } ); test("line ".__LINE__, 'use Moose; with( "Foo::Bar" => { -version => "1.1" }, "Bar::Baz" );', { 'Moose' => 0, 'Foo::Bar' => '1.1', 'Bar::Baz' => 0, } ); test("line ".__LINE__, 'use Moose; with( "Blam::Blam", "Foo::Bar" => { -version => "1.1" }, "Bar::Baz" );', { 'Moose' => 0, 'Blam::Blam' => 0, 'Foo::Bar' => '1.1', 'Bar::Baz' => 0, } ); test("line ".__LINE__, 'use Moose; with("Blam::Blam","Foo::Bar"=>{-version=>"1.1"}, "Bar::Baz" );', { 'Moose' => 0, 'Blam::Blam' => 0, 'Foo::Bar' => '1.1', 'Bar::Baz' => 0, } ); test("line ".__LINE__, 'use Moose; with("Blam::Blam","Foo::Bar"=>{-version=>"1.1"}, "Bar::Baz", "Hoopla" => { -version => 1 } );', { 'Moose' => 0, 'Blam::Blam' => 0, 'Foo::Bar' => '1.1', 'Bar::Baz' => 0, 'Hoopla' => 1, } ); test("line ".__LINE__, 'use Moose; extends("Foo::Bar");', { 'Moose' => 0, 'Foo::Bar' => 0, }, ); test("line ".__LINE__, 'use Moose; extends( "Foo::Bar" );', { 'Moose' => 0, 'Foo::Bar' => 0, }, ); test("line ".__LINE__, 'use Moose; extends( "Foo::Bar", "Bar::Baz" );', { 'Moose' => 0, 'Foo::Bar' => 0, 'Bar::Baz' => 0, } ); test("line ".__LINE__, 'use Moose; extends( "Foo::Bar" => { -version => "1.1" }, "Bar::Baz" );', { 'Moose' => 0, 'Foo::Bar' => '1.1', 'Bar::Baz' => 0, } ); test("line ".__LINE__, 'use Moose; extends( "Blam::Blam", "Foo::Bar" => { -version => "1.1" }, "Bar::Baz" );', { 'Moose' => 0, 'Blam::Blam' => 0, 'Foo::Bar' => '1.1', 'Bar::Baz' => 0, } ); test("line ".__LINE__, 'use Moose; extends("Blam::Blam","Foo::Bar"=>{-version=>"1.1"}, "Bar::Baz" );', { 'Moose' => 0, 'Blam::Blam' => 0, 'Foo::Bar' => '1.1', 'Bar::Baz' => 0, } ); test("line ".__LINE__, 'use Moose; extends("Blam::Blam","Foo::Bar"=>{-version=>"1.1"}, "Bar::Baz", "Hoopla" => { -version => 1 } );', { 'Moose' => 0, 'Blam::Blam' => 0, 'Foo::Bar' => '1.1', 'Bar::Baz' => 0, 'Hoopla' => 1, } ); test("line ".__LINE__, 'use Moose ;with( \'AAA\' => { -version => \'1\' }, \'BBB\' => { -version => \'2.1\' }, \'CCC\' => { -version => \'4.012345\', default_finders => [ \':InstallModules\', \':ExecFiles\' ], }, );', { 'Moose' => 0, 'AAA' => 1, 'BBB' => '2.1', 'CCC' => '4.012345', }, ); test("line ".__LINE__, 'use Moose; with( "AAA" => { -version => 1 }, );', { 'Moose' => 0, 'AAA' => 1, }, ); test("line ".__LINE__, 'use Moose; with "AAA" => { -version => 1 };', { 'Moose' => 0, 'AAA' => 1, }, ); test("line ".__LINE__, 'use Moose; with( "Bar" );', { 'Moose' => 0, 'Bar' => 0, }, ); test("line ".__LINE__, 'use Moose; with \'Bar\' ;', { 'Moose' => 0, 'Bar' => 0, }, ); # invalid code tests test("line ".__LINE__, 'use Moose; with;', {Moose => 0}, ); test("line ".__LINE__, 'use Moose; with foo;', {Moose => 0} ); # test cases for aliased.pm test("line ".__LINE__, q{use aliased 'Long::Custom::Class::Name'}, { 'aliased' => 0, 'Long::Custom::Class::Name' => 0, }, ); test("line ".__LINE__, q{use aliased 0.30 'Long::Custom::Class::Name'}, { 'aliased' => '0.30', 'Long::Custom::Class::Name' => 0, }, ); test("line ".__LINE__, q{use aliased 'Long::Custom::Class::Name' => 'Name'}, { 'aliased' => 0, 'Long::Custom::Class::Name' => 0, }, ); test("line ".__LINE__, q{use aliased;}, { 'aliased' => 0, }, ); # rolsky says this is a problem case test("line ".__LINE__, q{use Test::Requires 'Foo'}, { 'Test::Requires' => 0, }, ); # test cases for POE test("line ".__LINE__, q{use POE 'Component::IRC'}, { 'POE' => 0, 'POE::Component::IRC' => 0, }, ); test("line ".__LINE__, q{use POE qw/Component::IRC Component::Server::NNTP/}, { 'POE' => 0, 'POE::Component::IRC' => 0, 'POE::Component::Server::NNTP' => 0, }, ); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/compat/module_extractuse/0000755000175100017510000000000014422514733025312 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/compat/module_extractuse/10_basic.t0000644000175100017510000001545114001101046027044 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../../"; use Test::More; use t::Util; # compatibility test with Module::ExtractUse test('useSome::Module', <<'END', used()); useSome::Module1; END test('use Some::Module2', <<'END', used(qw/Some::Module2/)); use Some::Module2; END test('useless stuff', <<'END', used(qw/Some::Module3/)); yadda yadda useless stuff; use Some::Module3 qw/$VERSION @EXPORT @EXPORT_OK/; END # base is not listed in as of M::EU 0.33 test('use base', <<'END', used(qw/base Class::DBI4 Foo::Bar5/)); use base qw(Class::DBI4 Foo::Bar5); END test('use in if block', <<'END', used(qw/Foo::Bar6/)); if ($foo) { use Foo::Bar6; } END test('use constant', <<'END', used(qw/constant/)); use constant dl_ext => $Config{dlext}; END test('use strict', <<'END', used(qw/strict/)); use strict; END test('use Foo args', <<'END', used(qw/Foo8/)); use Foo8 qw/asdfsdf/; END test('$use', <<'END', used()); $use=stuff; END test('abuse', <<'END', used()); abuse Stuff; END test('package', <<'END', used()); package Module::ScanDeps; END # XXX: incompatibility # M::EU 0.33 returns Bar7 test('require in if block', <<'END', used()); if ($foo) { require "Bar7"; } END test('require file', <<'END', used()); require "some/stuff.pl"; END # XXX: incompatibility # M::EU 0.33 returns Foo::Bar9, which seems a bug, but it may be (or # may not be) nice to have Foo/Bar.pm => Foo::Bar conversion here. test('require .pm file', <<'END', used()); require "Foo/Bar.pm9"; END test('require namespace', <<'END', used(qw/Foo10/)); require Foo10; END test('two uses in a line', <<'END', used(qw/Some::Module11 Some::Other::Module12/)); use Some::Module11;use Some::Other::Module12; END test('two uses', <<'END', used(qw/Some::Module Some::Other::Module/)); use Some::Module; use Some::Other::Module; END test('use vars', <<'END', used(qw/vars/)); use vars qw/$VERSION @EXPORT @EXPORT_OK/; END test('use in comment', <<'END', used()); unless ref $obj; # use ref as $obj END test('use in string', <<'END', used()); $self->_carp("$name trigger deprecated: use before_$name or after_$name instead"); END test('use base', <<'END', used(qw/base Exporter1/)); use base 'Exporter1'; END test('use base with parentheses', <<'END', used(qw/base Class::DBI2/)); use base ("Class::DBI2"); END test('use base with string', <<'END', used(qw/base Class::DBI3/)); use base "Class::DBI3"; END test('use base with qw', <<'END', used(qw/base Class::DBI4 Foo::Bar5/)); use base qw/Class::DBI4 Foo::Bar5/; END test('use base with parentheses (2)', <<'END', used(qw/base Class::DBI6 Foo::Bar7/)); use base ("Class::DBI6","Foo::Bar7"); END test('use base with strings', <<'END', used(qw/base Class::DBI8 Foo::Bar9/)); use base "Class::DBI8","Foo::Bar9"; END test('use parent', <<'END', used(qw/parent Exporter1/)); use parent 'Exporter1'; END test('use parent with parentheses', <<'END', used(qw/parent Class::DBI2/)); use parent ("Class::DBI2"); END test('use parent with string', <<'END', used(qw/parent Class::DBI3/)); use parent "Class::DBI3"; END test('use parent with qw', <<'END', used(qw/parent Class::DBI4 Foo::Bar5/)); use parent qw/Class::DBI4 Foo::Bar5/; END test('use parent with parentheses (2)', <<'END', used(qw/parent Class::DBI6 Foo::Bar7/)); use parent ("Class::DBI6","Foo::Bar7"); END test('use parent with strings', <<'END', used(qw/parent Class::DBI8 Foo::Bar9/)); use parent "Class::DBI8","Foo::Bar9"; END test('use parent -norequire string', <<'END', used(qw/parent/)); use parent -norequire, 'Exporter1'; END test('use parent -norequire in parentheses', <<'END', used(qw/parent/)); use parent (-norequire, "Class::DBI2"); END test('use parent "-norequire" string', <<'END', used(qw/parent/)); use parent "-norequire", "Class::DBI3"; END test('use parent -norequire in qw', <<'END', used(qw/parent/)); use parent qw/-norequire Class::DBI4 Foo::Bar5/; END test('use parent -norequire in parentheses', <<'END', used(qw/parent/)); use parent (-norequire,"Class::DBI6","Foo::Bar7"); END test('use parent -norequire strings', <<'END', used(qw/parent/)); use parent -norequire,"Class::DBI8","Foo::Bar9"; END test('use in eval', <<'END', used(), {'Test::Pod' => 1.06}); eval "use Test::Pod 1.06"; END test('uses in two evals', <<'END', used(qw/strict Test::More/), {'Test::Pod' => 1.06, 'Test::Pod::Coverage' => 1.06}); #!/usr/bin/perl -w use strict; use Test::More; eval "use Test::Pod 1.06"; eval 'use Test::Pod::Coverage 1.06;'; plan skip_all => "Test::Pod 1.06 required for testing POD" if $@; all_pod_files_ok(); END test('use base with qw and whitespaces', <<'END', used(qw/base Data::Phrasebook::Loader::Base Data::Phrasebook::Debug/)); use base qw( Data::Phrasebook::Loader::Base Data::Phrasebook::Debug ); END test('RT #83569', <<'END', used(qw/warnings strict Test::More lib DBIx::Class DBICTest Test::Pod/)); use warnings; use strict; use Test::More; use lib qw(t/lib); use DBICTest; require DBIx::Class; unless ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_pod') ) { my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('test_pod'); $ENV{RELEASE_TESTING} ? die ("Failed to load release-testing module requirements: $missing") : plan skip_all => "Test needs: $missing" } # this has already been required but leave it here for CPANTS static analysis require Test::Pod; my $generated_pod_dir = 'maint/.Generated_Pod'; Test::Pod::all_pod_files_ok( 'lib', -d $generated_pod_dir ? $generated_pod_dir : () ); END test('require in string', <<'END', used(qw/Foo/)); use Foo;say "Failed to load the release-testing modules we require: Bar;" END test('require in string', <<'END', used(qw/Foo/)); use Foo;say "Failed to load the release-testing modules we require: Bar"; END # dup test('require in string', <<'END', used(qw/Foo/)); use Foo;say "Failed to load the release-testing modules we require: Bar;" END test('use Data::Section -setup', <<'END', used(qw/Data::Section/)); use Data::Section -setup; END test('use Data::Section with hashref', <<'END', used(qw/Data::Section/)); use Data::Section { installer => method_installer }, -setup; END test('use Data::Section -setup hashref', <<'END', used(qw/Data::Section/)); use Data::Section -setup => { header_re => qr/^\@\@\s*(\S+)/ }; END test('use Module ()', <<'END', used(qw/Foo::Bar29/)); use Foo::Bar29 (); END test('use Module version ()', <<'END', {'Min::Version30' => 1.2}); use Min::Version30 1.2 (); END test('use MooseX::Types -declare', <<'END', used(qw/MooseX::Types/)); use MooseX::Types -declare => [qw(BorderStyle Component Container)]; END test('require in eval block', <<'END', {}, used(qw/Foo::Bar32/)); eval { require Foo::Bar32 }; END test('use in do block', <<'END', used(qw/Foo::Bar33/)); do { use Foo::Bar33 }; END test('use version', <<'END', used(qw/version/)); use version; END test('use version VERSION', <<'END', {version => '0.77'}); use version 0.77; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/compat/module_extractuse/22_eval.t0000644000175100017510000000274714001101046026721 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../../"; use Test::More; use t::Util; test('eval string with a semicolon', <<'END', {}, {'Test::Pod' => '1.00'}); eval "use Test::Pod 1.00;"; END test('eval string without a semicolon', <<'END', {}, {'Test::Pod' => '1.00'}); eval 'use Test::Pod 1.00'; END test('eval in qq{}', <<'END', {}, {'Test::Pod' => '1.00'}); eval qq{use Test::Pod 1.00} END test('eval in qq++', <<'END', {}, {'Test::Pod' => 0}); eval qq+use Test::Pod+ END test('eval in qq()', <<'END', {}, {'Test::Pod' => 0}); eval qq(use Test::Pod) END test('eval in q<>', <<'END', {}, {'Test::Pod' => 0}); eval q< use Test::Pod> END test('eval in q//', <<'END', {}, {'Test::Pod' => 0}); eval q/use Test::Pod/ END test('RT #19302', <<'END', {}, {'Test::Pod' => 0}); my $ver=1.22; eval "use Test::Pod $ver;" END test('ditto', <<'END', {}, {'Test::Pod' => 0}); my $ver=1.22; eval 'use Test::Pod $ver'; END test('no space between eval and string', <<'END', {}, {'Test::Pod' => '1.00'}); eval"use Test::Pod 1.00;"; END test('ditto', <<'END', {}, {'Test::Pod' => '1.00'}); eval'use Test::Pod 1.00'; END test('eval block', <<'END', {}, {'Test::Pod' => 0}); eval { use Test::Pod } END test('block in eval block', <<'END', {}, used(qw/Test::Pod Test::Pod::Coverage/)); eval { use Test::Pod; { use Test::Pod::Coverage; } } END test('block in eval block', <<'END', {}, used(qw/Test::Pod Test::Pod::Coverage/)); eval { { use Test::Pod; } use Test::Pod::Coverage } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/compat/module_extractuse/21_comment.t0000644000175100017510000000217514001101046027426 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../../"; use Test::More; use t::Util; test('use in comment', <<'END', {}, {}, used(qw/Apache::DBI/)); BEGIN { # Only use Apache::DBI on dev. if (-f '/var/run/httpd-dev01') { # Must be loaded before DBI. require Apache::DBI; Apache::DBI->import(); } } END test('require in comment', <<'END', used(qw/Apache::DBI/)); # require Apache::DBI require Apache::DBI END test('everything is in comment', <<'END', used()); # require Apache::DBI # require Apache::DBI END test('irrelevant comment', <<'END', used(qw/Apache::DBI/)); # foo require Apache::DBI END test('use in comment', <<'END', used(qw/Apache::DBI/)); # use some Apache::DBI, yo require Apache::DBI END test('use in comment', <<'END', used(qw/Apache::DBI/)); # require Apache::DBI use Apache::DBI END test('use in comment', <<'END', used(qw/Apache::DBI/)); # yo, require Apache::DBI require Apache::DBI END test('trailing comments', <<'END', {perl => '5.008', strict => 0, warnings => 0}); use 5.008; # Because we want to # Another comment use strict; use warnings; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/unless.t0000644000175100017510000000043514001101046021751 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('unless', <<'END', {unless => 0}, {}, {'POE::Kernel' => 0}); use unless ( $^O =~ /^(?:linux|MSWin32|darwin)$/ ), 'POE::Kernel', { loop => 'POE::XS::Loop::Poll' }; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/test_more.t0000644000175100017510000000227014001101046022440 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('skip_all out of BEGIN', <<'END', {'Test::More' => 0, 'strict' => 0}); use Test::More; plan skip_all => 'foo'; use strict; END test('skip_all inside BEGIN', <<'END', {'Test::More' => 0}, {}, {'strict' => 0}); use Test::More; BEGIN { plan skip_all => 'foo'; } use strict; END test('skip_all inside sub BEGIN', <<'END', {'Test::More' => 0}, {}, {'strict' => 0}); use Test::More; sub BEGIN { plan skip_all => 'foo'; } use strict; END test('skip_all inside BEGIN if', <<'END', {'Test::More' => 0}, {}, {'strict' => 0}); use Test::More; sub BEGIN { plan skip_all => 'foo' if $^O eq 'MSWin32'; } use strict; END test('"skip_all"', <<'END', {'Test::More' => 0}, {}, {'strict' => 0}); use Test::More; sub BEGIN { plan 'skip_all' => 'foo' if $^O eq 'MSWin32'; } use strict; END test('plan(skip_all => ...)', <<'END', {}, {}, {'strict' => 0, 'Test::More' => 0}); # INGY/perl5-0.21/t/release-pod-syntax.t BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/universal_version.t0000644000175100017510000000232614001101046024216 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; # ITUB/Chemistry-Mol-0.37/Mol.pm test('VERSION < number', <<'END', {Storable => 0}); use Storable; sub clone { my ($self) = @_; my $clone = dclone $self; $clone->_weaken if Storable->VERSION < 2.14; $clone; } END test('in the main package', <<'END', {'Test::More' => 0.98}, {}, {}); require Test::More; Test::More->VERSION('0.98'); END test('if block', <<'END', {}, {}, {'Test::More' => 0.98}); if (1) { require Test::More; Test::More->VERSION('0.98'); } END # PEVANS/Scalar-List-Utils-1.49/lib/Scalar/Util.pm test('variable', <<'END', {'List::Util' => 0}); use List::Util; List::Util->VERSION( $VERSION ); END # CJM/HTML-Tree-5.03/lib/HTML/TreeBuilder.pm test('numerical version', <<'END', {'LWP::UserAgent' => '5.815'}); use LWP::UserAgent; LWP::UserAgent->VERSION( 5.815 ); END # LEONT/Dist-Zilla-Plugin-PPPort-0.007/lib/Dist/Zilla/Plugin/PPPort.pm test('return value', <<'END', {'Devel::PPPort' => 0}); use Devel::PPPort; Devel::PPPort->VERSION($self->version); END test('eval block or die', <<'END', {}, {'Test::More' => 0.98}); eval { require Test::More; Test::More->VERSION('0.98') } or die; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/core/0000755000175100017510000000000014422514733021223 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/core/parent.t0000644000175100017510000000203614001101046022660 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; local $t::Util::EVAL = 1; test('parent singlequotes', <<'END', {parent => 0, Exporter => 0}); use parent 'Exporter'; END test('parent doublequotes', <<'END', {parent => 0, Exporter => 0}); use parent "Exporter"; END test('parent qw()', <<'END', {parent => 0, Exporter => 0}); use parent qw(Exporter); END test('parent multilined qw()', <<'END', {parent => 0, Exporter => 0}); use parent qw( Exporter ); END test('parent bareword (only works without strict)', <<'END', {parent => 0, Exporter => 0}); use parent Exporter; END test('parent + function', <<'END', {parent => 0}); sub function {} use parent function(); END test('parent + ()', <<'END', {parent => 0}); use parent (); END test('parent + (bareword)', <<'END', {parent => 0, Carp => 0}); use parent (Carp); END # incompatible with Perl::PrereqScanner, which counts Test::More as well test('-norequire', <<'END', {parent => 0}); use parent -norequire, 'Test::More'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/core/if.t0000644000175100017510000000226514001101046021771 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; local $t::Util::EVAL = 1; test('if cond => namespace', <<'END', {if => 0}, {}, {Exporter => 0}); use if $] => Exporter; END test('if cond => string', <<'END', {if => 0}, {}, {Exporter => 0}); use if $] => "Exporter"; END test('if cond => namespace', <<'END', {if => 0}, {}, {'Test::More' => 0}); use if $] => Test::More; END test('if cond => string', <<'END', {if => 0}, {}, {'Test::More' => 0}); use if $] => "Test::More"; END test('cond may have commas', <<'END', {if => 0}, {}, {'Test::More' => 0}); use if [1, 2 => 3] => "Test::More"; END test('cond may have commas', <<'END', {if => 0}, {}, {'Test::More' => 0}); use if [1, 2 => qw/foo/] => "Test::More"; END local $t::Util::EVAL = 0; test('with open pragma', <<'END', {if => 0}, {}, {open => 0}); # AUDREYT/OurNet-BBS-1.67/lib/OurNet/BBS/ScalarFile.pm use if ($^O eq 'MSWin32'), open => (IN => ':bytes', OUT => ':bytes'); END test('with open pragma', <<'END', {if => 0}, {}, {open => 0}); # AUDREYT/OurNet-BBS-1.67/lib/OurNet/BBS/ScalarFile.pm use if $OurNet::BBS::Encoding, open => ":encoding($OurNet::BBS::Encoding)"; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/core/base.t0000644000175100017510000000151714001101046022304 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; local $t::Util::EVAL = 1; test('base singlequotes', <<'END', {base => 0, Exporter => 0}); use base 'Exporter'; END test('base doublequotes', <<'END', {base => 0, Exporter => 0}); use base "Exporter"; END test('base qw()', <<'END', {base => 0, Exporter => 0}); use base qw(Exporter); END test('base multilined qw()', <<'END', {base => 0, Exporter => 0}); use base qw( Exporter ); END test('base bareword (only works without strict)', <<'END', {base => 0, Exporter => 0}); use base Exporter; END test('base + function', <<'END', {base => 0}); sub function {} use base function(); END test('base + ()', <<'END', {base => 0}); use base (); END test('base + (bareword)', <<'END', {base => 0, Carp => 0}); use base (Carp); END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/bin/0000755000175100017510000000000014422514733021043 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/bin/parser.t0000644000175100017510000000206014001101046022500 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_bin(':bundled', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use base 'Foo'; use Moo; with 'Bar'; END }, [qw/--parser :bundled/], <<'CPANFILE'); requires 'Bar'; requires 'Foo'; requires 'Moo'; requires 'base'; requires 'strict'; requires 'warnings'; CPANFILE test_bin('Core only', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use base 'Foo'; use Moo; with 'Bar'; END }, [qw/--parser Core/], <<'CPANFILE'); requires 'Foo'; requires 'Moo'; requires 'base'; requires 'strict'; requires 'warnings'; CPANFILE test_bin('multiple parsers', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use base 'Foo'; use Moo; with 'Bar'; END }, [qw/--parser Core --parser Moose/], <<'CPANFILE'); requires 'Bar'; requires 'Foo'; requires 'Moo'; requires 'base'; requires 'strict'; requires 'warnings'; CPANFILE done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/bin/scan_also.t0000644000175100017510000000267314001101046023160 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_bin('also scan extlib', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/extlib/MyTest2.pm", <<'END'); use strict; use warnings; use Bar; END }, [qw/--scan-also extlib/], <<'CPANFILE'); requires 'Bar'; requires 'Foo'; requires 'strict'; requires 'warnings'; CPANFILE test_bin('also and local', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; # --scan-also makes this a local module END test_file("$tmpdir/extlib/Foo.pm", <<'END'); use strict; use warnings; use Bar; END }, [qw/--also extlib/], <<'CPANFILE'); requires 'Bar'; requires 'strict'; requires 'warnings'; CPANFILE test_bin('also and test files', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; # t/Foo.pm is not a local file END test_file("$tmpdir/extlib/Foo/t/load.t", <<'END'); use strict; use warnings; use Test::More; END # this is not used from .t files and thus ignored test_file("$tmpdir/extlib/Foo/t/Foo.pm", <<'END'); use strict; use warnings; use Bar; END }, [qw/--scan-also extlib/], <<'CPANFILE'); requires 'Foo'; requires 'strict'; requires 'warnings'; on test => sub { requires 'Test::More'; requires 'strict'; requires 'warnings'; }; CPANFILE done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/bin/basic.t0000644000175100017510000000047014001101046022270 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_bin('no options', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END }, [], <<'CPANFILE'); requires 'strict'; requires 'warnings'; CPANFILE done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/20_parsers.t0000644000175100017510000000172114001101046022417 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; $t::Util::PARSERS = [qw/:default/]; test('default', <<'END', {Moose => 0, Foo => 0, 'Test::More' => 0}); use Test::More; use Moose; extends qw/Foo/; done_testing; END $t::Util::PARSERS = [qw/:default -Moose/]; test('exclude with minus', <<'END', {Moose => 0}); use Moose; extends qw/Foo/; # this should not be recognized END $t::Util::PARSERS = [qw/:default TestMore/]; test('extra parser', <<'END', {'Test::More' => 0.88}); use Test::More; done_testing; END $t::Util::PARSERS = [qw/:default Perl::PrereqScanner::NotQuiteLite::Parser::TestMore/]; test('full qualified extra parser', <<'END', {'Test::More' => 0.88}); use Test::More; done_testing; END $t::Util::PARSERS = [qw/:default +Perl::PrereqScanner::NotQuiteLite::Parser::TestMore/]; test('full qualified extra parser with plus', <<'END', {'Test::More' => 0.88}); use Test::More; done_testing; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/test_class_most.t0000644000175100017510000000155314001101046023650 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; # taken from Test::Class::Most pod test('parent with a package', <<'END', {'Test::Class::Most' => 0, 'Tests::For::Foo' => 0}); package Tests::For::Foo::Child; use Test::Class::Most parent => 'Tests::For::Foo'; END test('parent with packages', <<'END', {'Test::Class::Most' => 0, 'Tests::For::Foo' => 0, 'Tests::For::Bar' => 0, 'Some::Other::Class::For::Increased::Stupidity' => 0}); package Tests::For::ISuckAtOO; use Test::Class::Most parent => [qw/ Tests::For::Foo Tests::For::Bar Some::Other::Class::For::Increased::Stupidity /]; END test('with other options', <<'END', {'Test::Class::Most' => 0, 'My::Test::Class' => 0}); use Test::Class::Most parent => 'My::Test::Class', attributes => [qw/customer items/], is_abstract => 1; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/begin_exit.t0000644000175100017510000000154114001101046022554 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('exit out of BEGIN', <<'END', {'strict' => 0}, {}, {}); exit; # evaluate after use use strict; END test('exit out of BEGIN, conditional', <<'END', {'strict' => 0}, {}, {}); exit if $^O eq 'MSWin32'; use strict; END test('exit inside BEGIN', <<'END', {}, {}, {}); BEGIN { # comment to avoid shortcut exit; } use strict; END test('exit inside sub BEGIN', <<'END', {}, {}, {}); sub BEGIN { # comment to avoid shortcut exit; } use strict; END test('exit inside BEGIN if', <<'END', {}, {}, {'strict' => 0}); sub BEGIN { exit if $^O eq 'MSWin32'; } use strict; END test('exit inside BEGIN if block', <<'END', {}, {}, {'strict' => 0}); BEGIN { if ($^O eq 'MSWin32') { # comment to avoid shortcut exit } } use strict; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/autouse.t0000644000175100017510000000050214001101046022120 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('with qw', <<'END', {'autouse' => 0}, {}, {'Carp' => 0}); use autouse 'Carp' => qw(carp croak); END test('with qw', <<'END', {'autouse' => 0}, {}, {'Data::Dumper' => 0}); use autouse 'Data::Dumper'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/syntax_collector.t0000644000175100017510000000122614001101046024033 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('spec follows', <<'END', {'Syntax::Collector' => 0, strict => 0, warnings => 0, 'Scalar::Util' => 0}); use Syntax::Collector q/ use strict 0; use warnings 0 FATAL => 'all'; use Scalar::Util 0 qw(blessed); /; END test('-collect', <<'END', {'Syntax::Collector' => 0, strict => 0, warnings => 0, 'Scalar::Util' => 0}); use Syntax::Collector -collect => q/ use strict 0; use warnings 0 FATAL => 'all'; use Scalar::Util 0 qw(blessed); /; END test('no spec', <<'END', {'Syntax::Collector' => 0}); use Syntax::Collector; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/object_pad_attr.t0000644000175100017510000001763514422514456023622 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('basic class', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Foo; END test('basic class version', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Foo 1.00; END test('basic role', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo; END test('basic role version', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo 1.00; END # simple :isa/:does test('basic class :isa', <<'END', {'Object::Pad' => 0, 'Bar' => 0}); use Object::Pad; class Foo :isa(Bar); END test('basic class version :isa', <<'END', {'Object::Pad' => 0, 'Bar' => 0}); use Object::Pad; class Foo 1.00 :isa(Bar); END test('basic class :isa base version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00'}); use Object::Pad; class Foo :isa(Bar 2.00); END test('basic class version :isa base version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00'}); use Object::Pad; class Foo 1.00 :isa(Bar 2.00); END test('basic class :does', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => 0}); use Object::Pad; class Foo :does(Bar) :does(Baz); END test('basic class version :does', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => 0}); use Object::Pad; class Foo 1.00 :does(Bar) :does(Baz); END test('basic class :does role version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00'}); use Object::Pad; class Foo :does(Bar 2.00) :does(Baz 3.00); END test('basic class version :does role version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00'}); use Object::Pad; class Foo 1.00 :does(Bar 2.00) :does(Baz 3.00); END test('basic class :does role, role version', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => '3.00'}); use Object::Pad; class Foo :does(Bar) :does(Baz 3.00); END test('basic class version :does role, role version', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => '3.00'}); use Object::Pad; class Foo 1.00 :does(Bar) :does(Baz 3.00); END # both :isa and :does test('basic class :does role version :isa base', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo :does(Bar 2.00) :does(Baz 3.00) :isa(Quux 4.00); END test('basic class version :does role version :isa base', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo 1.00 :does(Bar 2.00) :does(Baz 3.00) :isa(Quux 4.00); END test('basic class :isa base :does role version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo :isa(Quux 4.00) :does(Bar 2.00) :does(Baz 3.00); END test('basic class version :isa base :does role version', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo 1.00 :isa(Quux 4.00) :does(Bar 2.00) :does(Baz 3.00); END # class/role attributes test('basic class :does role version :isa base :attr', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo :does(Bar 2.00) :does(Baz 3.00) :isa(Quux 4.00) :repr(native), :repr(default), :strict(params); END test('basic class version :does role version :isa base :attr', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00', 'Quux' => '4.00'}); use Object::Pad; class Foo 1.00 :does(Bar 2.00) :does(Baz 3.00) :isa(Quux 4.00) :repr(native), :repr(default), :strict(params) END test('basic role :attr', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo :compat(invokable); END test('basic role version :attr', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo 1.00 :compat(invokable); END # internal classes/roles test('basic class version :isa internal class', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Bar; class Foo 1.00 :isa(Bar); END test('basic class :isa internal class version', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Bar; class Foo :isa(Bar 2.00); END test('basic class version :isa internal class version', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Bar; class Foo 1.00 :isa(Bar 2.00); END test('basic class version :does internal role', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Bar; class Foo 1.00 :does(Bar); END test('basic class :does internal role version', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Bar; class Foo :does(Bar 2.00); END test('basic class version :does internal role version', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Bar; class Foo 1.00 :does(Bar 2.00); END # class/role blocks #### test('basic class {}', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Foo { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version {}', <<'END', {'Object::Pad' => 0}); use Object::Pad; class Foo 1.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic role {}', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic role version {}', <<'END', {'Object::Pad' => 0}); use Object::Pad; role Foo 1.00 { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END # simple :isa/:does test('basic class :isa {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0}); use Object::Pad; class Foo :isa(Bar) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version :isa {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0}); use Object::Pad; class Foo 1.00 :isa(Bar) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class :isa base version {}', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00'}); use Object::Pad; class Foo :isa(Bar 2.00) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version :isa base version {}', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00'}); use Object::Pad; class Foo 1.00 :isa(Bar 2.00) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class :does {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => 0}); use Object::Pad; class Foo :does(Bar) :does(Baz) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version :does {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => 0}); use Object::Pad; class Foo 1.00 :does(Bar) :does(Baz) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class :does role version {}', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00'}); use Object::Pad; class Foo :does(Bar 2.00) :does(Baz 3.00) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version :does role version {}', <<'END', {'Object::Pad' => 0, 'Bar' => '2.00', 'Baz' => '3.00'}); use Object::Pad; class Foo 1.00 :does(Bar 2.00) :does(Baz 3.00) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class :does role, role version {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => '3.00'}); use Object::Pad; class Foo :does(Bar) :does(Baz 3.00) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END test('basic class version :does role, role version {}', <<'END', {'Object::Pad' => 0, 'Bar' => 0, 'Baz' => '3.00'}); use Object::Pad; class Foo 1.00 :does(Bar) :does(Baz 3.00) { has $x :param = 0; has $y :param = 0; method move ($dX, $dY) { $x += $dX; $y += $dY; } } END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/10_use.t0000644000175100017510000000474714001101046021546 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; local $t::Util::EVAL = 1; test('use pragma', <<'END', {strict => 0, warnings => 0}); use strict; use warnings; END test('use Module', <<'END', {'FindBin' => 0, 'Time::Local' => 0}); use FindBin; use Time::Local; END test('use Module Version', <<'END', {'FindBin' => 0.01, 'Time::Local' => '0.02'}); use FindBin 0.01; use Time::Local 0.02; END test('use v-string', <<'END', {perl => 'v5.8.1'}); use v5.8.1; END test('use version_number', <<'END', {perl => '5.008001'}); use 5.008001; END test('use Module ()', <<'END', {'Time::Local' => 0}); use Time::Local (); END test('use Module version ()', <<'END', {'Time::Local' => 0.01}); use Time::Local 0.01 (); END test('use Module qw(args)', <<'END', {'Time::Local' => 0}); use Time::Local qw(timelocal); END test('use lib', <<'END', {lib => 0, constant => 0, FindBin => 0}); use FindBin; use lib "$FindBin::Bin/../lib"; use constant FOO => 'BAR'; END test('use in a block', <<'END', {'Test::More' => 0}); {use Test::More} END local $t::Util::EVAL = 0; test('use method', <<'END', {}); __PACKAGE__->use("Test::More"); END # NKH/Text-Editor-Vip-0.08.1/lib/Text/Editor/Vip/Color/Color.pm test('pod', <<'END', {}); =TODO tests do not use print for output but some Vip error or login func =cut END test('overload', <<'END', {overload => 0}); # TRIZEN/Math-BigNum-0.20/lib/Math/BigNum/Nan.pm use overload q{""} => \&stringify, q{0+} => \&numify, bool => \&boolify, '=' => \©, # Some shortcuts for speed '+=' => \&_self, '-=' => \&_self, '*=' => \&_self, '/=' => \&_self, '%=' => \&_self, '^=' => \&_self, '&=' => \&_self, '|=' => \&_self, '**=' => \&_self, '<<=' => \&_self, '>>=' => \&_self, '+' => \&nan, '*' => \&nan, '&' => \&nan, '|' => \&nan, '^' => \&nan, '~' => \&nan, '>>' => \&nan, '<<' => \&nan, '++' => \&_self, '--' => \&_self, eq => sub { "$_[0]" eq "$_[1]" }, ne => sub { "$_[0]" ne "$_[1]" }, cmp => sub { $_[2] ? "$_[1]" cmp $_[0]->stringify : $_[0]->stringify cmp "$_[1]"; }, '!=' => sub { 1 }, '==' => sub { 0 }, '>' => sub { 0 }, '>=' => sub { 0 }, '<' => sub { 0 }, '<=' => sub { 0 }, '<=>' => sub { 0 }, '**' => \&nan, '-' => \&nan, '/' => \&nan, '%' => \&nan, atan2 => \&nan, sin => \&nan, cos => \&nan, exp => \&nan, log => \&nan, int => \&nan, abs => \&nan, sqrt => \&nan; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/mixin.t0000644000175100017510000000031414001101046021560 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('base singlequotes', <<'END', {mixin => 0, Exporter => 0}); use mixin 'Exporter'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/0000755000175100017510000000000014422514733021053 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/t/app/cpanfile.t0000644000175100017510000001032514001101046023000 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_cpanfile('no cpanfile', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END }, {}, <<'CPANFILE'); requires 'strict'; requires 'warnings'; CPANFILE test_cpanfile('existing cpanfile', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END test_file("$tmpdir/cpanfile", <<'END'); requires 'strict'; requires 'warnings'; END }, {}, <<'CPANFILE'); requires 'strict'; requires 'warnings'; CPANFILE test_cpanfile('cpanfile with extra requirements', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END test_file("$tmpdir/cpanfile", <<'END'); requires 'strict'; requires 'warnings'; requires 'Something::Else'; END }, {}, <<'CPANFILE'); requires 'Something::Else'; requires 'strict'; requires 'warnings'; CPANFILE test_cpanfile('cpanfile with features', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END test_file("$tmpdir/cpanfile", <<'END'); requires 'strict'; requires 'warnings'; feature 'foo', 'foo', sub { requires 'Something::Else'; }; END }, {}, <<'CPANFILE'); requires 'strict'; requires 'warnings'; feature 'foo', 'foo' => sub { requires 'Something::Else'; }; CPANFILE test_cpanfile('new feature', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END }, {features => 'foo:foo:MyTest.pm'}, <<'CPANFILE'); feature 'foo', 'foo' => sub { requires 'strict'; requires 'warnings'; }; CPANFILE test_cpanfile('merge feature', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END test_file("$tmpdir/cpanfile", <<'END'); feature 'foo', 'foo', sub { requires 'Something::Else'; }; END }, {features => 'foo:foo:MyTest.pm'}, <<'CPANFILE'); feature 'foo', 'foo' => sub { requires 'Something::Else'; requires 'strict'; requires 'warnings'; }; CPANFILE test_cpanfile('dedupe feature', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/MyTest2.pm", <<'END'); use strict; use warnings; use Bar; END }, {features => 'foo:foo:MyTest2.pm'}, <<'CPANFILE'); requires 'Foo'; requires 'strict'; requires 'warnings'; feature 'foo', 'foo' => sub { requires 'Bar'; }; CPANFILE test_cpanfile('exclude_core and feature', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/MyTest2.pm", <<'END'); use strict; use warnings; use Test::More; use Bar; END }, {features => 'foo:foo:MyTest2.pm', exclude_core => 1}, <<'CPANFILE'); requires 'Foo'; feature 'foo', 'foo' => sub { requires 'Bar'; }; CPANFILE test_cpanfile('empty feature because of exclude_core', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/MyTest2.pm", <<'END'); use strict; use warnings; use Test::More; END }, {features => 'foo:foo:MyTest2.pm', exclude_core => 1}, <<'CPANFILE'); requires 'Foo'; CPANFILE test_cpanfile('empty feature because of unmatching path', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END }, {features => 'foo:foo:MyTest3.pm', exclude_core => 1}, <<'CPANFILE'); requires 'Foo'; CPANFILE test_cpanfile('x_phase', sub { my $tmpdir = shift; my $tmpfile = "$tmpdir/MyTest.pm"; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END test_file("$tmpdir/cpanfile", <<'END'); on "x_phase" => sub { requires 'Xtra'; }; feature 'foo', 'foo', sub { requires 'Something::Else'; }; END }, {features => 'foo:foo:MyTest.pm'}, <<'CPANFILE'); on x_phase => sub { requires 'Xtra'; }; feature 'foo', 'foo' => sub { requires 'Something::Else'; requires 'strict'; requires 'warnings'; }; CPANFILE test_cpanfile('keep version', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use Foo; END test_file("$tmpdir/cpanfile", <<'END'); requires 'Foo', '1.05'; END }, {}, <<'CPANFILE'); requires 'Foo', '1.05'; CPANFILE done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/features.t0000644000175100017510000000322514001101046023036 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_cpanfile('no features', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/FeatureA/Bar.pm", <<'END'); use strict; use warnings; use Bar; END test_file("$tmpdir/lib/MyTest/FeatureB/Baz.pm", <<'END'); use strict; use warnings; use Baz; END }, {}, <<'CPANFILE'); requires 'Bar'; requires 'Baz'; requires 'Foo'; requires 'strict'; requires 'warnings'; CPANFILE test_cpanfile('feature', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/FeatureA/Bar.pm", <<'END'); use strict; use warnings; use Bar; END test_file("$tmpdir/lib/MyTest/FeatureB/Baz.pm", <<'END'); use strict; use warnings; use Baz; END }, {features => [qw!A:A:lib/MyTest/FeatureA!]}, <<'CPANFILE'); requires 'Baz'; requires 'Foo'; requires 'strict'; requires 'warnings'; feature 'A', 'A' => sub { requires 'Bar'; }; CPANFILE test_cpanfile('features glob', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/FeatureA/Bar.pm", <<'END'); use strict; use warnings; use Bar; END test_file("$tmpdir/lib/MyTest/FeatureB/Baz.pm", <<'END'); use strict; use warnings; use Baz; END }, {features => [qw!features:features:lib/MyTest/Feature*!]}, <<'CPANFILE'); requires 'Foo'; requires 'strict'; requires 'warnings'; feature 'features', 'features' => sub { requires 'Bar'; requires 'Baz'; }; CPANFILE done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/optional.t0000644000175100017510000000234114221572253023063 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_app('optional file', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/Win32.pm", <<'END'); use strict; use warnings; use Win32; END END }, {optional => [qw!lib/MyTest/Win32.pm!]}, { runtime => { requires => { Foo => 0, strict => 0, warnings => 0 }, suggests => { Win32 => 0 }}}); test_app('optional dir', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/Win32.pm", <<'END'); use strict; use warnings; use Win32; END END }, {optional => [qw!lib/MyTest/!]}, { runtime => { requires => { Foo => 0, strict => 0, warnings => 0}, suggests => { Win32 => 0 }}}); test_app('optional_re', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/Win32.pm", <<'END'); use strict; use warnings; use Win32; END END }, {optional_re => 'lib/MyTest/'}, { runtime => { requires => { Foo => 0, strict => 0, warnings => 0 }, suggests => { Win32 => 0 }}}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/ignore.t0000644000175100017510000000220614001101046022501 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_app('ignore a file', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/Win32.pm", <<'END'); use strict; use warnings; use Win32; END END }, {ignore => [qw!lib/MyTest/Win32.pm!]}, { runtime => { requires => { Foo => 0, strict => 0, warnings => 0 }}}); test_app('ignore a dir', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/Win32.pm", <<'END'); use strict; use warnings; use Win32; END END }, {ignore => [qw!lib/MyTest/!]}, { runtime => { requires => { Foo => 0, strict => 0, warnings => 0 }}}); test_app('ignore_re', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/Win32.pm", <<'END'); use strict; use warnings; use Win32; END END }, {ignore_re => 'lib/MyTest/'}, { runtime => { requires => { Foo => 0, strict => 0, warnings => 0 }}}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/use_index.t0000644000175100017510000000433314001101046023204 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; plan skip_all => "requires \$ENV{PERL_PRNQL_TEST_NETWORK} to test" unless $ENV{PERL_PRNQL_TEST_NETWORK}; plan skip_all => "requires CPAN::Common::Index" unless eval "require CPAN::Common::Index"; test_app('exclude submodules', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Acme::CPANAuthors; use Acme::CPANAuthors::Utils; END }, {use_index => "Mirror"}, { runtime => { requires => { strict => 0, warnings => 0, 'Acme::CPANAuthors' => 0 }}}); test_app('modules under different namespaces that belong to the same distribution', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use Mojo::Base; END test_file("$tmpdir/MyTest2.pm", <<'END'); use Mojolicious; END }, {use_index => "Mirror"}, { runtime => { requires => { 'Mojolicious' => 0 }}}); test_app('modules under different namespaces that belong to the same distribution without a main module', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use LWP::UserAgent; END test_file("$tmpdir/MyTest2.pm", <<'END'); use LWP::Simple; END }, {use_index => "Mirror"}, { runtime => { requires => { 'LWP::Simple' => 0 }}}); test_app('modules under different namespaces (same depth) that belong to the same distribution', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use Mojo::Base; END test_file("$tmpdir/MyTest2.pm", <<'END'); use Mojolicious::Lite; END }, {use_index => "Mirror"}, { runtime => { requires => { 'Mojolicious' => 0 }}}); test_app('versioned modules', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use Mojo::Base 7.00; END test_file("$tmpdir/MyTest2.pm", <<'END'); use Mojolicious::Lite 8.00; END }, {use_index => "Mirror"}, { runtime => { requires => { 'Mojo::Base' => '7.00', 'Mojolicious::Lite' => '8.00' }}}); test_app('versioned module plus unversioned', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use Mojo::Base; END test_file("$tmpdir/MyTest2.pm", <<'END'); use Mojolicious::Lite 8.00; END }, {use_index => "Mirror"}, { runtime => { requires => { 'Mojolicious::Lite' => '8.00' }}}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/dedupe.t0000644000175100017510000000361414001101046022470 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_app('dedupe requires from recommends/suggests', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END test_file("$tmpdir/MyTest2.pm", <<'END'); if (eval { require warnings }) { require strict; } END }, {}, { runtime => { requires => { strict => 0, warnings => 0 }}}); test_app('dedupe requires from feature requires/recommends/suggests', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END test_file("$tmpdir/MyTest2.pm", <<'END'); if (eval { require warnings }) { require strict; } END }, {features => 'foo:foo:MyTest2.pm'}, { runtime => { requires => { strict => 0, warnings => 0 }}}); test_app('dedupe recommends from recommends/suggests', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); { require strict; require warnings; } END test_file("$tmpdir/MyTest2.pm", <<'END'); if (eval { require warnings }) { require strict; } END }, {}, { runtime => { recommends => { strict => 0, warnings => 0 }}}); test_app('dedupe recommends from feature recommends/suggests', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); { require strict; require warnings; } END test_file("$tmpdir/MyTest2.pm", <<'END'); if (eval { require warnings }) { require strict; } END }, {features => 'foo:foo:MyTest2.pm'}, { runtime => { recommends => { strict => 0, warnings => 0 }}}); test_app('dedupe suggests from feature suggests', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; eval { use warnings }; END test_file("$tmpdir/MyTest2.pm", <<'END'); if (eval { require warnings }) { require strict; } END }, {features => 'foo:foo:MyTest2.pm'}, { runtime => { requires => { strict => 0}, suggests => { warnings => 0 }}}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/scan_also.t0000644000175100017510000000300214001101046023153 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_app('modules under unknown directories are ignored by default', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/extlib/DistA/lib/MyTest/Bar.pm", <<'END'); use strict; use warnings; use Bar; END test_file("$tmpdir/extlib/DistB/lib/MyTest/Baz.pm", <<'END'); use strict; use warnings; use Baz; END }, {}, { runtime => { requires => { Foo => 0, strict => 0, warnings => 0 }}}); test_app('scan_also', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/extlib/DistA/lib/MyTest/Bar.pm", <<'END'); use strict; use warnings; use Bar; END test_file("$tmpdir/extlib/DistB/lib/MyTest/Baz.pm", <<'END'); use strict; use warnings; use Baz; END }, {scan_also => [qw!extlib/DistA/lib!]}, { runtime => { requires => { Foo => 0, Bar => 0, strict => 0, warnings => 0 }}}); test_app('scan_also glob', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/extlib/DistA/lib/MyTest/Bar.pm", <<'END'); use strict; use warnings; use Bar; END test_file("$tmpdir/extlib/DistB/lib/MyTest/Baz.pm", <<'END'); use strict; use warnings; use Baz; END }, {scan_also => [qw!extlib/*/lib!]}, { runtime => { requires => { Foo => 0, Bar => 0, Baz => 0, strict => 0, warnings => 0 }}}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/basic.t0000644000175100017510000000231514001101046022300 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_app('.pm file in the root', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END }, {}, { runtime => { requires => { strict => 0, warnings => 0 }}}); test_app('.pm file under lib', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; END }, {}, { runtime => { requires => { strict => 0, warnings => 0 }}}); test_app('inc', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo::Bar; END test_file("$tmpdir/inc/Foo/Bar.pm", <<'END'); package Foo::Bar; 1; END }, {}, { runtime => { requires => { strict => 0, warnings => 0 }}}); test_app('ignore local file', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; END test_file("$tmpdir/MyTest2.pm", <<'END'); use MyTest; END }, {}, { runtime => { requires => { strict => 0, warnings => 0 }}}); test_app('ignore Makefile.PL under t', sub { my $tmpdir = shift; test_file("$tmpdir/t/Makefile.PL", <<'END'); use strict; use warnings; use Foo; END }, {}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/exclude_core.t0000644000175100017510000000214414223744630023702 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_app('ignore core modules', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END }, {exclude_core => 1}, { runtime => { requires => { Foo => 0 }}}); test_app('do not ignore better core modules', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Exporter 5.57; END }, {exclude_core => 1}, { runtime => { requires => { Exporter => '5.57' }}}); test_app('ignore core modules for higher perl version', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use 5.020; use strict; use warnings; use experimental qw/signatures/; use Foo; END }, {exclude_core => 1}, { runtime => { requires => { Foo => 0, perl => '5.020' }}}); test_app('ignore core modules with undef version', sub { my $tmpdir = shift; test_file("$tmpdir/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END }, {exclude_core => 1, perl_version => 5.006}, { runtime => { requires => { Foo => 0 }}}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/private.t0000644000175100017510000000153614001101046022675 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_app('ignore a private module', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/Win32.pm", <<'END'); use strict; use warnings; use Bar; use My::Win32; END }, {private => [qw!My::Win32!]}, { runtime => { requires => { Foo => 0, Bar => 0, strict => 0, warnings => 0 }}}); test_app('private_re', sub { my $tmpdir = shift; test_file("$tmpdir/lib/MyTest.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/lib/MyTest/Win32.pm", <<'END'); use strict; use warnings; use Bar; use My::Win32; use My::Unix; END }, {private_re => '^My::'}, { runtime => { requires => { Foo => 0, Bar => 0, strict => 0, warnings => 0 }}}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/app/allow_test_pms.t0000644000175100017510000000273414001101046024260 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../../"; use Test::More; use t::Util; test_app('ignore .pm files under t unless they are used in .t files', sub { my $tmpdir = shift; test_file("$tmpdir/t/test.t", <<'END'); use strict; use warnings; use t::lib::Util; END test_file("$tmpdir/t/lib/Util.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/t/lib/Corpus.pm", <<'END'); use strict; use warnings; use Bar; END }, {}, { test => { requires => { strict => 0, warnings => 0, Foo => 0 }}}); test_app('respect .pm files under t if allow-test-pms is set', sub { my $tmpdir = shift; test_file("$tmpdir/t/test.t", <<'END'); use strict; use warnings; use t::lib::Util; END test_file("$tmpdir/t/lib/Util.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/t/lib/Corpus.pm", <<'END'); use strict; use warnings; use Bar; END }, {allow_test_pms => 1}, { test => { requires => { strict => 0, warnings => 0, Foo => 0, Bar => 0}}}); test_app('respect .pm files under t if Test::Class is used', sub { my $tmpdir = shift; test_file("$tmpdir/t/test.t", <<'END'); use strict; use warnings; use Test::Class; use t::lib::Util; END test_file("$tmpdir/t/lib/Util.pm", <<'END'); use strict; use warnings; use Foo; END test_file("$tmpdir/t/lib/Corpus.pm", <<'END'); use strict; use warnings; use Bar; END }, {}, { test => { requires => { strict => 0, warnings => 0, 'Test::Class' => 0, Foo => 0, Bar => 0 }}}); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/11_require.t0000644000175100017510000000271114001101046022414 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('require pragma', <<'END', {strict => 0, warnings => 0}); require strict; require warnings; END test('require Module', <<'END', {'Test' => 0, 'Test::More' => 0}); require Test; require Test::More; END test('require v-string', <<'END', {perl => 'v5.10.1'}); require v5.10.1; END test('require version_number', <<'END', {perl => '5.010001'}); require 5.010001; END test('require file', <<'END', {'Test::More' => 0}); my $file = "Test/More.pm"; require "Test/More.pm"; require "cgi-lib.pl"; require $file; END test('require Module in if', <<'END', {}, {}, {'Test::More' => 0}); if (1) { require Test::More; } END test('require Module in sub', <<'END', {}, {}, {'Test::More' => 0}); sub foo { require Test::More; } END test('require Module in sub without explicit semicolon', <<'END', {}, {}, {'Test::More' => 0}); sub foo { require Test::More } END test('require Module in sub', <<'END', {'Test::More' => 0}); BEGIN { require Test::More; } END test('require Module in sub', <<'END', {'Test::More' => 0}); sub BEGIN { require Test::More; } END test('sub require', <<'END', {'vars' => 0}); # EVO/Term-ShellKit-1.002/ShellKit/Dev.pm sub require { die "No module name provided" unless ( scalar @_ ); map { Term::ShellKit::require_package( $_ ) } @_; } ###################################################################### use vars '%LibLastLoaded'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/test_requires.t0000644000175100017510000000157014001101046023337 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('with a hashref', <<'END', {'Test::Requires' => 0}, {}, {'HTTP::MobileAttribute' => '0.01'}); use Test::Requires { 'HTTP::MobileAttribute' => 0.01, # skip all if HTTP::MobileAttribute doesn't installed }; END test('qw', <<'END', {'Test::More' => 0, 'Test::Requires' => 0}, {}, {'HTTP::MobileAttribute' => 0}); use Test::More tests => 10; use Test::Requires qw( HTTP::MobileAttribute ); END test('empty ()', <<'END', {'Test::More' => 0, 'Test::Requires' => 0}, {}, {}); use Test::More tests => 10; use Test::Requires (); END test('function', <<'END', {'Test::More' => 0, 'Test::Requires' => 0}, {}, {'Some::Optional::Test::Required::Modules' => 0}); use Test::More tests => 10; use Test::Requires; test_requires 'Some::Optional::Test::Required::Modules'; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/later.t0000644000175100017510000000051014001101046021541 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('without arg', <<'END', {'later' => 0}, {}, {'Carp' => 0}); use later 'Carp'; END test('with an optional hash', <<'END', {'later' => 0}, {}, {'Data::Dumper' => 0}); use later 'Data::Dumper', do_fuss => 1; END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/t/module_runtime.t0000644000175100017510000000310214001101046023462 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use lib "$FindBin::Bin/../"; use Test::More; use t::Util; test('use_module', <<'END', {'Module::Runtime' => 0, 'Test::More' => 0}); use Module::Runtime 'use_module'; use_module('Test::More'); END test('conditional use_module', <<'END', {'Module::Runtime' => 0}, {}, {'Test::More' => 0}); use Module::Runtime 'use_module'; if (1) { use_module('Test::More'); } END test('use_module in a sub', <<'END', {'Module::Runtime' => 0}, {}, {'Test::More' => 0}); use Module::Runtime 'use_module'; sub foo { use_module('Test::More'); } END test('use_module in BEGIN', <<'END', {'Module::Runtime' => 0, 'Test::More' => 0}); use Module::Runtime 'use_module'; BEGIN { use_module('Test::More'); } END test('use_module with version', <<'END', {'Module::Runtime' => 0, 'Test::More' => '0.01'}); use Module::Runtime 'use_module'; use_module('Test::More', '0.01'); END test('require_module', <<'END', {'Module::Runtime' => 0, 'Test::More' => 0}); use Module::Runtime 'require_module'; require_module('Test::More'); END test('use_package_optimistically', <<'END', {'Module::Runtime' => 0, 'Test::More' => 0}); use Module::Runtime 'use_package_optimistically'; use_package_optimistically('Test::More'); END test('use_package_optimistically with version', <<'END', {'Module::Runtime' => 0, 'Test::More' => '0.01'}); use Module::Runtime 'use_package_optimistically'; use_package_optimistically('Test::More', '0.01'); END test('use_module', <<'END', {'Module::Runtime' => 0, 'Test::More' => 0}); use Module::Runtime; Module::Runtime::use_module('Test::More'); END done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/LICENSE0000644000175100017510000004423614001101046021024 0ustar ishigakiishigakiThis software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2015 by Kenichi Ishigaki. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. <one line to give the program's name and a brief idea of what it does.> Copyright (C) 19yy <name of author> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. <signature of Ty Coon>, 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2015 by Kenichi Ishigaki. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Perl-PrereqScanner-NotQuiteLite-0.9917/xt/0000755000175100017510000000000014422514733020463 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/xt/cpanfile.t0000644000175100017510000000015614001101046022411 0ustar ishigakiishigakiuse strict; use warnings; use Test::More; use Test::CPANfile; cpanfile_has_all_used_modules(); done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/xt/bundle.t0000644000175100017510000000050614001101046022100 0ustar ishigakiishigakiuse strict; use warnings; use FindBin; use Test::More; use Perl::PrereqScanner::NotQuiteLite; my @parsers = map { my ($name) = /(\w+)\.pm$/; $name } glob("$FindBin::Bin/../lib/Perl/PrereqScanner/NotQuiteLite/Parser/*"); is_deeply [sort @parsers] => [sort @Perl::PrereqScanner::NotQuiteLite::BUNDLED_PARSERS]; done_testing; Perl-PrereqScanner-NotQuiteLite-0.9917/xt/99_pod.t0000644000175100017510000000034514001101046021733 0ustar ishigakiishigakiuse strict; use warnings; use Test::More; eval "use Test::Pod 1.18"; plan skip_all => 'Test::Pod 1.18 required' if $@; plan skip_all => 'set RELEASE_TESTING to enable this test' unless $ENV{RELEASE_TESTING}; all_pod_files_ok(); Perl-PrereqScanner-NotQuiteLite-0.9917/bin/0000755000175100017510000000000014422514733020600 5ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite-0.9917/bin/scan-perl-prereqs-nqlite0000644000175100017510000001315514221572253025363 0ustar ishigakiishigaki#!perl BEGIN { pop @INC if $INC[-1] eq '.' } use strict; use warnings; use lib (); use Perl::PrereqScanner::NotQuiteLite::App; use Getopt::Long; use Pod::Usage; GetOptions(\my %opts, qw/ inc|lib|I=s@ libs|scan_also|scan-also|also=s@ parsers|parser=s@ version help json cpanfile save_cpanfile|save-cpanfile exclude_core|exclude-core perl_version|perl-version=s allow_test_pms|allow-test-pms features|feature=s@ base_dir|base-dir=s ignore_re|ignore-re=s ignore=s@ optional_re|optional-re=s optional=s@ private_re|private-re=s private=s@ recommends suggests develop blib use_index|use-index=s perl_minimum_version verbose /); if ($opts{version}) { print "scan-perl-prereqs-nqlite v" . (Perl::PrereqScanner::NotQuiteLite->VERSION || 'DEV') . "\n"; exit; } if ($opts{help}) { pod2usage(-verbose => 1); exit; } lib->import(@{$opts{inc}}) if $opts{inc}; for my $key (keys %opts) { next unless $key =~ /\-/; (my $replaced_key = $key) =~ s/\-/_/g; $opts{$replaced_key} = $opts{$key}; } $opts{print} = 1; Perl::PrereqScanner::NotQuiteLite::App->new(%opts)->run(@ARGV); __END__ =encoding utf-8 =head1 NAME scan-perl-prereqs-nqlite =head1 SYNOPSIS scan-perl-prereqs-nqlite [DIRS|FILES] =head1 DESCRIPTION C traverses several files and subdirectories in the current directory with L to collect all C<.pl>, C<.PL>, C<.pm>, C<.t>, C<.psgi> files (as well as all the files in C and C directories), and prints a single combined list of prerequisites, which should be suitable for piping to C or similar tools. You can also pass files and/or directories to limit files to scan. In this case, however, C may fail to exclude modules that should belong to the same distribution. =head1 OPTIONS =over 4 =item version Show the version. =item help Show this help. =item json Print prerequisites as a JSON if L is installed. =item cpanfile, save_cpanfile Print prerequisites as C if L is installed. If C is set, create or update C. =item suggests Print suggestions (Cd modules in C) as well. =item develop Print requirements/suggestions for developers (Cd modules in C and C directories) as well. =item perl_minimum_version May modify required perl version if new language features are used without declaring the required perl version explicitly. =item exclude_core Ignore prerequisites that are bundled with Perl (of 5.008001 by default). This requires L version 2.99 or above. =item perl_version Ignore prerequisites that are bundled with Perl of a specific version. This implies C as well. =item allow_test_pms Print requirements/suggestions in .pm files that are placed under t/ directory but are not directly used from .t files, too. If Test::Class family is used under t/, this option is implicitly set. =item base_dir Set the base directory from where C starts traversing files and directories. =item ignore Set a list of paths C should ignore. This is useful when your distribution has a set of OS-specific modules, for example. =item ignore_re You can also specify a regexp instead of a list of paths. If this is set, C options are ignored. =item optional Set a list of paths C should ignore. This is useful when your distribution has a set of OS-specific modules, for example. =item optional_re You can also specify a regexp instead of a list of paths. If this is set, C options are ignored. =item private Set a list of modules C should consider private, that is, that are not uploaded to the CPAN. Contrary to the C option, which makes the scanner skip scanning the file, this option lets the scanner scan files, and excludes matched prerequisites afterwards. =item private_re You can also specify a regexp instead of a list of modules. If this is set, C options are ignored. =item scan_also Set a list of extra paths C should also scan. This is useful when your application/distribution uses an untraditional file layout. =item feature scan-perl-prereqs-nqlite \ --feature name:description:lib/My/Plugin/For/SpecificOS \ --feature name:description:web/lib,web/bin Specify a feature name, a description, and matching paths. =item use_index You can specify an index name of CPAN::Common::Index module (such as "Mirror" or "MetaDB") not to list all the modules of a required distribution. =item blib If this is set, C will traverse subdirectories under C to collect runtime requirements. It may return better results if some of the files are located in some uncommon places and/or some of them are listed in C. However, files in C may be older than the ones under C etc, and you need to update them by running a make or a C script before you run C. =item parser Set a list of parsers (or parser tags) C uses. If this option is not set, the scanner uses C<:installed> parsers by default. =item inc Add a list of additional @INC path C looks for private parsers. =item verbose Print verbose messages. =back =head1 AUTHOR Kenichi Ishigaki, Eishigaki@cpan.orgE =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Perl-PrereqScanner-NotQuiteLite-0.9917/README0000644000175100017510000000064014001101046020666 0ustar ishigakiishigakiPerl-PrereqScanner-NotQuiteLite INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install COPYRIGHT AND LICENSE Copyright (C) 2015 Kenichi Ishigaki This software is copyright (c) 2015 by Kenichi Ishigaki. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Perl-PrereqScanner-NotQuiteLite-0.9917/META.json0000664000175100017510000000362014422514733021454 0ustar ishigakiishigaki{ "abstract" : "a tool to scan your Perl code for its prerequisites", "author" : [ "Kenichi Ishigaki " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Perl-PrereqScanner-NotQuiteLite", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker::CPANfile" : "0.09" } }, "develop" : { "suggests" : { "Perl::PrereqScanner::Lite" : "0", "Test::Pod" : "1.18" } }, "runtime" : { "requires" : { "CPAN::Meta::Prereqs" : "2.150010", "CPAN::Meta::Requirements" : "2.140", "Data::Dump" : "0", "Exporter" : "5.57", "Module::CPANfile" : "1.1004", "Module::CoreList" : "3.11", "Module::Find" : "0", "Parse::Distname" : "0", "Regexp::Trie" : "0", "parent" : "0", "perl" : "5.008001" }, "suggests" : { "CPAN::Common::Index" : "0", "JSON::PP" : "0" } }, "test" : { "requires" : { "Test::FailWarnings" : "0", "Test::More" : "0.98", "Test::UseAllModules" : "0.17" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/charsbar/Perl-PrereqScanner-NotQuiteLite" } }, "version" : "0.9917", "x_serialization_backend" : "JSON::PP version 4.12" }