├── .appveyor.yml ├── .github ├── README.md └── workflows │ ├── run-tests.yml │ └── run-tests.yml.tmpl ├── .gitignore ├── Changes ├── MANIFEST ├── MANIFEST.SKIP ├── Makefile.PL ├── Makefile_PL_settings.plx ├── Makefile_PL_settings_maint.plx ├── Parameters.xs ├── hax ├── COP_SEQ_RANGE_HIGH_set.c.inc ├── COP_SEQ_RANGE_LOW_set.c.inc ├── STATIC_ASSERT_STMT.c.inc ├── block_end.c.inc ├── block_start.c.inc ├── intro_my.c.inc ├── newDEFSVOP.c.inc ├── op_convert_list.c.inc ├── pad_add_name_pvs.c.inc ├── pad_add_name_sv.c.inc ├── pad_alloc.c.inc ├── pad_block_start.c.inc ├── pad_findmy_pvs.c.inc ├── pad_leavemy.c.inc └── scalarseq.c.inc ├── lib └── Function │ ├── Parameters.pm │ └── Parameters │ └── Info.pm ├── maint ├── distcheck.pl ├── eumm-fixup.pl ├── pod2markdown.pl ├── pod2readme.pl └── tm.pl ├── t ├── 01-compiles.t ├── 02-compiles.t ├── 03-compiles.t ├── attributes.t ├── bonus.t ├── checkered.t ├── checkered_2.t ├── checkered_3.t ├── checkered_4.t ├── croak.t ├── defaults.t ├── defaults_bare.t ├── defaults_regress.t ├── eating_strict_error.fail ├── eating_strict_error.t ├── eating_strict_error_2.fail ├── elsewhere.t ├── eval.t ├── gorn.t ├── hueg.t ├── imports.t ├── info.t ├── install.t ├── invocant.t ├── lexical.t ├── lifetime.t ├── lineno-torture.t ├── lineno.t ├── method_cache.t ├── method_runtime.t ├── name.t ├── name_1.fail ├── name_2.fail ├── name_3.fail ├── name_4.fail ├── named_params.t ├── precedence.t ├── prototype.t ├── recursion.t ├── regress.t ├── rename.t ├── strict.t ├── strict_1.fail ├── strict_2.fail ├── strict_3.fail ├── strict_4.fail ├── strict_5.fail ├── stringy_h.t ├── threads.t ├── threads2.t ├── types_auto.t ├── types_caller.t ├── types_coerce.t ├── types_custom.t ├── types_custom_2.t ├── types_custom_3.t ├── types_custom_4.t ├── types_inline.t ├── types_moose.t ├── types_moose_2.t ├── types_moose_3.t ├── types_moosex.t ├── types_moosex_2.t ├── types_msg.t ├── types_parse.t ├── unicode.t └── unicode2.t └── xt ├── foreign ├── Fun │ ├── anon.t │ ├── basic.t │ ├── closure-proto.t │ ├── compile-time.t │ ├── defaults.t │ ├── name.t │ ├── package.t │ ├── recursion.t │ ├── slurpy-syntax-errors.t │ ├── slurpy.t │ └── state.t ├── Method-Signatures-Simple │ ├── 02-use.t │ ├── 03-config.t │ ├── RT80505.t │ ├── RT80507.t │ ├── RT80508.t │ └── RT80510.t ├── Method-Signatures │ ├── anon.t │ ├── array_param.t │ ├── at_underscore.t │ ├── attributes.t │ ├── begin.t │ ├── caller.t │ ├── comments.t │ ├── defaults.t │ ├── error_interruption.t │ ├── func.t │ ├── into.t │ ├── invocant.t │ ├── larna.t │ ├── lib │ │ ├── Bad.pm │ │ ├── BarfyDie.pm │ │ └── MooseLoadTest.pm │ ├── method.t │ ├── named.t │ ├── odd_number.t │ ├── one_line.t │ ├── optional.t │ ├── paren_on_own_line.t │ ├── paren_plus_open_block.t │ ├── required.t │ ├── simple.plx │ ├── slurpy.t │ ├── syntax_errors.t │ ├── too_many_args.t │ ├── trailing_comma.t │ ├── type_check.t │ ├── typeload_moose.t │ └── typeload_notypes.t ├── MooseX-Method-Signatures │ ├── attributes.t │ ├── caller.t │ ├── closure.t │ ├── errors.t │ ├── eval.t │ ├── lib │ │ ├── InvalidCase01.pm │ │ ├── My │ │ │ └── Annoyingly │ │ │ │ └── Long │ │ │ │ └── Name │ │ │ │ └── Space.pm │ │ └── Redefined.pm │ ├── list.t │ ├── named_defaults.t │ ├── no_signature.t │ ├── precedence.t │ ├── sigs-optional.t │ ├── too_many_args.t │ ├── type_alias.t │ ├── types.t │ ├── undef_method_arg.t │ └── undef_method_arg2.t ├── perl │ └── signatures.t └── signatures │ ├── anon.t │ ├── basic.t │ ├── eval.t │ ├── proto.t │ └── weird.t └── pod.t /.appveyor.yml: -------------------------------------------------------------------------------- 1 | cache: 2 | - C:\strawberry 3 | 4 | install: 5 | - if not exist "C:\strawberry" choco install strawberryperl -y 6 | - set PATH=C:\strawberry\c\bin;C:\strawberry\perl\site\bin;C:\strawberry\perl\bin;%PATH% 7 | - cd %APPVEYOR_BUILD_FOLDER% 8 | - cpanm --quiet --installdeps --with-develop --notest . 9 | 10 | build_script: 11 | - perl Makefile.PL 12 | - gmake 13 | 14 | test_script: 15 | - gmake test 16 | -------------------------------------------------------------------------------- /.github/workflows/run-tests.yml: -------------------------------------------------------------------------------- 1 | # vi: set ft=yaml: 2 | name: "run tests" 3 | on: 4 | [push, pull_request] 5 | 6 | jobs: 7 | perl_tester: 8 | strategy: 9 | fail-fast: false 10 | matrix: 11 | os: 12 | - "ubuntu-latest" 13 | - "macos-latest" 14 | - "windows-latest" 15 | perl-version: ["5.14", "5.16", "5.18", "5.20", "5.22", "5.24", "5.26", "5.28", "5.30", "5.32", "5.34", "5.36", "5.38", "5.40"] 16 | exclude: 17 | - { os: windows-latest, perl-version: "5.18" } 18 | - { os: windows-latest, perl-version: "5.20" } 19 | - { os: windows-latest, perl-version: "5.22" } 20 | - { os: windows-latest, perl-version: "5.24" } 21 | - { os: windows-latest, perl-version: "5.26" } 22 | - { os: windows-latest, perl-version: "5.38" } 23 | - { os: windows-latest, perl-version: "5.40" } 24 | 25 | runs-on: ${{ matrix.os }} 26 | name: "perl v${{ matrix.perl-version }} on ${{ matrix.os }}" 27 | 28 | env: 29 | cachepan: cachepan 30 | locallib: xlocal 31 | 32 | steps: 33 | - uses: actions/checkout@v4 34 | - name: "Set up perl" 35 | uses: shogo82148/actions-setup-perl@v1 36 | with: 37 | perl-version: ${{ matrix.perl-version }} 38 | - name: "Create perl fingerprint file" 39 | run: perl -MConfig -wE 'say for sprintf(q{%vd}, $^V), Config::bincompat_options' > perl-fingerprint 40 | - name: "Cache CPAN fragments" 41 | uses: actions/cache@v4 42 | with: 43 | enableCrossOsArchive: true 44 | path: ${{ env.cachepan }} 45 | key: cpan-dists-${{ github.run_id }} 46 | restore-keys: | 47 | cpan-dists- 48 | - name: "Cache local dependencies" 49 | uses: actions/cache@v4 50 | with: 51 | path: ${{ env.locallib }} 52 | key: xlocal-lib-${{ matrix.os }}-${{ hashFiles('perl-fingerprint', 'Makefile_PL_settings*.plx') }} 53 | - name: "Activate local lib directory" 54 | run: echo 'PERL5LIB=${{ github.workspace }}/${{ env.locallib }}/lib/perl5' >> $GITHUB_ENV 55 | shell: bash 56 | - run: cpanm --mirror "file://${{ github.workspace }}/${{ env.cachepan }}" --mirror https://www.cpan.org/ --save-dist "${{ github.workspace }}/${{ env.cachepan }}" -l "${{ env.locallib }}" --notest ExtUtils::MakeMaker 57 | - run: cpanm --mirror "file://${{ github.workspace }}/${{ env.cachepan }}" --mirror https://www.cpan.org/ --save-dist "${{ github.workspace }}/${{ env.cachepan }}" -l "${{ env.locallib }}" --notest --installdeps --with-develop . 58 | - run: perl Makefile.PL 59 | - run: make test 60 | -------------------------------------------------------------------------------- /.github/workflows/run-tests.yml.tmpl: -------------------------------------------------------------------------------- 1 | # vi: set ft=yaml: 2 | name: "run tests" 3 | on: 4 | [push, pull_request] 5 | 6 | jobs: 7 | perl_tester: 8 | strategy: 9 | fail-fast: false 10 | matrix: 11 | os: 12 | - "ubuntu-latest" 13 | - "macos-latest" 14 | - "windows-latest" 15 | perl-version: 16 | exclude: 17 | - { os: windows-latest, perl-version: "5.18" } 18 | - { os: windows-latest, perl-version: "5.20" } 19 | - { os: windows-latest, perl-version: "5.22" } 20 | - { os: windows-latest, perl-version: "5.24" } 21 | - { os: windows-latest, perl-version: "5.26" } 22 | - { os: windows-latest, perl-version: "5.38" } 23 | - { os: windows-latest, perl-version: "5.40" } 24 | 25 | runs-on: ${{ matrix.os }} 26 | name: "perl v${{ matrix.perl-version }} on ${{ matrix.os }}" 27 | 28 | env: 29 | cachepan: cachepan 30 | locallib: xlocal 31 | 32 | steps: 33 | - uses: actions/checkout@v4 34 | - name: "Set up perl" 35 | uses: shogo82148/actions-setup-perl@v1 36 | with: 37 | perl-version: ${{ matrix.perl-version }} 38 | - name: "Create perl fingerprint file" 39 | run: perl -MConfig -wE 'say for sprintf(q{%vd}, $^V), Config::bincompat_options' > perl-fingerprint 40 | - name: "Cache CPAN fragments" 41 | uses: actions/cache@v4 42 | with: 43 | enableCrossOsArchive: true 44 | path: ${{ env.cachepan }} 45 | key: cpan-dists-${{ github.run_id }} 46 | restore-keys: | 47 | cpan-dists- 48 | - name: "Cache local dependencies" 49 | uses: actions/cache@v4 50 | with: 51 | path: ${{ env.locallib }} 52 | key: xlocal-lib-${{ matrix.os }}-${{ hashFiles('perl-fingerprint', 'Makefile_PL_settings*.plx') }} 53 | - name: "Activate local lib directory" 54 | run: echo 'PERL5LIB=${{ github.workspace }}/${{ env.locallib }}/lib/perl5' >> $GITHUB_ENV 55 | shell: bash 56 | - run: cpanm --mirror "file://${{ github.workspace }}/${{ env.cachepan }}" --mirror https://www.cpan.org/ --save-dist "${{ github.workspace }}/${{ env.cachepan }}" -l "${{ env.locallib }}" --notest ExtUtils::MakeMaker 57 | - run: cpanm --mirror "file://${{ github.workspace }}/${{ env.cachepan }}" --mirror https://www.cpan.org/ --save-dist "${{ github.workspace }}/${{ env.cachepan }}" -l "${{ env.locallib }}" --notest --installdeps --with-develop . 58 | - run: perl Makefile.PL 59 | - run: make test 60 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /*.tar.gz 2 | /MANIFEST.bak 3 | /META.json 4 | /META.yml 5 | /MYMETA.json 6 | /MYMETA.yml 7 | /Makefile 8 | /Makefile.* 9 | !/Makefile.PL 10 | /blib/ 11 | /pm_to_blib 12 | Parameters.bs 13 | Parameters.c 14 | Parameters.o 15 | Parameters.i 16 | Parameters.s 17 | /untracked/ 18 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | hax/block_end.c.inc 3 | hax/block_start.c.inc 4 | hax/COP_SEQ_RANGE_HIGH_set.c.inc 5 | hax/COP_SEQ_RANGE_LOW_set.c.inc 6 | hax/intro_my.c.inc 7 | hax/newDEFSVOP.c.inc 8 | hax/op_convert_list.c.inc 9 | hax/pad_add_name_pvs.c.inc 10 | hax/pad_add_name_sv.c.inc 11 | hax/pad_alloc.c.inc 12 | hax/pad_block_start.c.inc 13 | hax/pad_findmy_pvs.c.inc 14 | hax/pad_leavemy.c.inc 15 | hax/scalarseq.c.inc 16 | hax/STATIC_ASSERT_STMT.c.inc 17 | lib/Function/Parameters.pm 18 | lib/Function/Parameters/Info.pm 19 | Makefile.PL 20 | Makefile_PL_settings.plx 21 | MANIFEST 22 | MANIFEST.SKIP 23 | Parameters.xs 24 | t/01-compiles.t 25 | t/02-compiles.t 26 | t/03-compiles.t 27 | t/attributes.t 28 | t/bonus.t 29 | t/checkered.t 30 | t/checkered_2.t 31 | t/checkered_3.t 32 | t/checkered_4.t 33 | t/croak.t 34 | t/defaults.t 35 | t/defaults_bare.t 36 | t/defaults_regress.t 37 | t/eating_strict_error.fail 38 | t/eating_strict_error.t 39 | t/eating_strict_error_2.fail 40 | t/elsewhere.t 41 | t/eval.t 42 | t/gorn.t 43 | t/hueg.t 44 | t/imports.t 45 | t/info.t 46 | t/install.t 47 | t/invocant.t 48 | t/lexical.t 49 | t/lifetime.t 50 | t/lineno-torture.t 51 | t/lineno.t 52 | t/method_cache.t 53 | t/method_runtime.t 54 | t/name.t 55 | t/name_1.fail 56 | t/name_2.fail 57 | t/name_3.fail 58 | t/name_4.fail 59 | t/named_params.t 60 | t/precedence.t 61 | t/prototype.t 62 | t/recursion.t 63 | t/regress.t 64 | t/rename.t 65 | t/strict.t 66 | t/strict_1.fail 67 | t/strict_2.fail 68 | t/strict_3.fail 69 | t/strict_4.fail 70 | t/strict_5.fail 71 | t/stringy_h.t 72 | t/threads.t 73 | t/threads2.t 74 | t/types_auto.t 75 | t/types_caller.t 76 | t/types_coerce.t 77 | t/types_custom.t 78 | t/types_custom_2.t 79 | t/types_custom_3.t 80 | t/types_custom_4.t 81 | t/types_inline.t 82 | t/types_moose.t 83 | t/types_moose_2.t 84 | t/types_moose_3.t 85 | t/types_moosex.t 86 | t/types_moosex_2.t 87 | t/types_msg.t 88 | t/types_parse.t 89 | t/unicode.t 90 | t/unicode2.t 91 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | (?can('is_make_type')) { 10 | my $value = join ':', @$harness_options; 11 | if ($self->is_make_type('gmake')) { 12 | $args{text} .= "export HARNESS_OPTIONS := $value\n"; 13 | } elsif ($self->is_make_type('nmake')) { 14 | $args{text} .= "!if [set HARNESS_OPTIONS=$value]\n!endif\n"; 15 | } 16 | } 17 | $args{text} || '' 18 | } 19 | 20 | sub find_tests_recursively_in { 21 | my ($dir) = @_; 22 | -d $dir or die "$dir is not a directory"; 23 | 24 | my %seen; 25 | my $wanted = sub { 26 | /\.t\z/ or return; 27 | my $directories = (File::Spec->splitpath($File::Find::name))[1]; 28 | my $depth = grep $_ ne '', File::Spec->splitdir($directories); 29 | $seen{$depth} = 1; 30 | }; 31 | File::Find::find($wanted, $dir); 32 | 33 | join ' ', 34 | map { $dir . '/*' x $_ . '.t' } 35 | sort { $a <=> $b } 36 | keys %seen 37 | } 38 | 39 | $::MAINT_MODE = !-f 'META.yml'; 40 | my $settings_file = 'Makefile_PL_settings.plx'; 41 | my %settings = %{do "./$settings_file" or die "Internal error: can't do $settings_file: ", $@ || $!}; 42 | 43 | (do './maint/eumm-fixup.pl' || die $@ || $!)->(\%settings) if $::MAINT_MODE; 44 | 45 | { 46 | $settings{depend}{Makefile} .= " $settings_file"; 47 | $settings{LICENSE} ||= 'perl'; 48 | $settings{PL_FILES} ||= {}; 49 | 50 | $settings{CONFIGURE_REQUIRES}{strict} ||= 0; 51 | $settings{CONFIGURE_REQUIRES}{warnings} ||= 0; 52 | $settings{CONFIGURE_REQUIRES}{'File::Find'} ||= 0; 53 | $settings{CONFIGURE_REQUIRES}{'File::Spec'} ||= 0; 54 | for ($settings{CONFIGURE_REQUIRES}{'ExtUtils::MakeMaker'}) { 55 | $_ = '7.0' if !$_ || $_ < 7; 56 | } 57 | 58 | my $module_file = $settings{NAME}; 59 | $module_file =~ s!::!/!g; 60 | $module_file = "lib/$module_file.pm"; 61 | 62 | $settings{VERSION_FROM} ||= $module_file; 63 | $settings{ABSTRACT_FROM} ||= $module_file; 64 | 65 | $settings{test}{TESTS} ||= do { 66 | my $extra_test_dirs = delete $settings{EXTRA_TEST_DIRS}; 67 | join ' ', map find_tests_recursively_in($_), 't', @{$extra_test_dirs || []} 68 | }; 69 | 70 | $settings{DISTNAME} ||= do { 71 | my $name = $settings{NAME}; 72 | $name =~ s!::!-!g; 73 | $name 74 | }; 75 | 76 | $settings{clean}{FILES} ||= "$settings{DISTNAME}-*"; 77 | 78 | $settings{dist}{COMPRESS} ||= 'gzip -9f'; 79 | $settings{dist}{SUFFIX} ||= '.gz'; 80 | 81 | my $version = $settings{VERSION} || MM->parse_version($settings{VERSION_FROM}); 82 | if ($version =~ s/-TRIAL[0-9]*\z//) { 83 | $settings{META_MERGE}{release_status} ||= 'unstable'; 84 | $settings{META_MERGE}{version} ||= $version; 85 | $settings{XS_VERSION} ||= $version; 86 | } 87 | 88 | $settings{META_MERGE}{'meta-spec'}{version} ||= 2; 89 | $settings{META_MERGE}{dynamic_config} ||= 0; 90 | 91 | push @{$settings{META_MERGE}{no_index}{directory}}, 'xt'; 92 | if (my $dev = delete $settings{DEVELOP_REQUIRES}) { 93 | @{$settings{META_MERGE}{prereqs}{develop}{requires}}{keys %$dev} = values %$dev; 94 | } 95 | if (my $rec = delete $settings{RECOMMENDS}) { 96 | @{$settings{META_MERGE}{prereqs}{runtime}{recommends}}{keys %$rec} = values %$rec; 97 | } 98 | 99 | if (my $sug = delete $settings{SUGGESTS}) { 100 | @{$settings{META_MERGE}{prereqs}{runtime}{suggests}}{keys %$sug} = values %$sug; 101 | } 102 | 103 | if (my $repo = delete $settings{REPOSITORY}) { 104 | if (ref($repo) eq 'ARRAY') { 105 | my ($type, @args) = @$repo; 106 | if ($type eq 'github') { 107 | my ($account, $project) = @args; 108 | $project ||= '%d'; 109 | $project =~ s{%(L?)(.)}{ 110 | my $x = 111 | $2 eq '%' ? '%' : 112 | $2 eq 'd' ? $settings{DISTNAME} : 113 | $2 eq 'm' ? $settings{NAME} : 114 | die "Internal error: unknown placeholder %$1$2"; 115 | $1 ? lc($x) : $x 116 | }seg; 117 | my $addr = "github.com/$account/$project"; 118 | $repo = { 119 | type => 'git', 120 | url => "git://$addr", 121 | web => "https://$addr", 122 | }; 123 | } else { 124 | die "Internal error: unknown REPOSITORY type '$type'"; 125 | } 126 | } 127 | ref($repo) eq 'HASH' or die "Internal error: REPOSITORY must be a hashref, not $repo"; 128 | @{$settings{META_MERGE}{resources}{repository}}{keys %$repo} = values %$repo; 129 | } 130 | 131 | if (my $harness_options = delete $settings{HARNESS_OPTIONS}) { 132 | $settings{postamble}{HARNESS_OPTIONS} = $harness_options; 133 | } 134 | } 135 | 136 | WriteMakefile %settings; 137 | -------------------------------------------------------------------------------- /Makefile_PL_settings.plx: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | { 5 | my $broken; 6 | if (eval { require Moose }) { 7 | if (!eval { package A_Moose_User; Moose->import; 1 }) { 8 | $broken = 'import'; 9 | } 10 | } elsif ($@ !~ /^Can't locate Moose\.pm /) { 11 | $broken = 'require'; 12 | } 13 | if ($broken) { 14 | print STDERR <<"EOT"; 15 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 16 | !!! Error: You seem to have Moose but I can't "use" it ($broken dies). !!! 17 | !!! This would cause confusing test errors, so I'm bailing out. Sorry. !!! 18 | !!! Maybe try upgrading Moose? !!! 19 | !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 20 | 21 | The exception was: 22 | $@ 23 | EOT 24 | exit 1; 25 | } 26 | } 27 | 28 | return { 29 | NAME => 'Function::Parameters', 30 | AUTHOR => q{Lukas Mai }, 31 | 32 | MIN_PERL_VERSION => '5.14.0', 33 | CONFIGURE_REQUIRES => {}, 34 | BUILD_REQUIRES => {}, 35 | TEST_REQUIRES => { 36 | 'constant' => 0, 37 | 'strict' => 0, 38 | 'utf8' => 0, 39 | 'FindBin' => 0, 40 | 'Hash::Util' => 0.07, 41 | 'Test::More' => 0, 42 | 'Test::Fatal' => 0, 43 | }, 44 | PREREQ_PM => { 45 | 'Carp' => 0, 46 | 'Scalar::Util' => 0, 47 | 'XSLoader' => 0, 48 | 'warnings' => 0, 49 | }, 50 | 51 | depend => { 52 | '$(OBJECT)' => join(' ', glob 'hax/*.c.inc'), 53 | }, 54 | 55 | REPOSITORY => [ github => 'mauke' ], 56 | 57 | HARNESS_OPTIONS => ['j4'], 58 | }; 59 | -------------------------------------------------------------------------------- /Makefile_PL_settings_maint.plx: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | sub { 5 | my ($opt) = @_; 6 | 7 | if ($^V ge v5.16.0 && $^V lt v5.22.0) { 8 | # Hack. ASan reports a memory leak on 5.16 .. 5.20, but I don't 9 | # want integration tests to fail for now. 10 | $opt->{EXTRA_ASAN_OPTIONS} .= " LSAN_OPTIONS='exitcode=0'"; 11 | } 12 | 13 | $opt->{DEVELOP_REQUIRES} = { 14 | 'aliased' => 0, 15 | 'Moose' => 0, 16 | 'MooseX::Types' => 0, 17 | 'Sub::Name' => 0, 18 | 'Test::Deep' => 0, 19 | 'Test::Pod' => 1.22, 20 | }; 21 | } 22 | -------------------------------------------------------------------------------- /hax/COP_SEQ_RANGE_HIGH_set.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef COP_SEQ_RANGE_HIGH_set 4 | 5 | #define COP_SEQ_RANGE_HIGH_set(SV, VAL) \ 6 | STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /hax/COP_SEQ_RANGE_LOW_set.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef COP_SEQ_RANGE_LOW_set 4 | 5 | #define COP_SEQ_RANGE_LOW_set(SV, VAL) \ 6 | STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END 7 | 8 | #endif 9 | -------------------------------------------------------------------------------- /hax/STATIC_ASSERT_STMT.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef STATIC_ASSERT_STMT 4 | 5 | #if (defined(static_assert) || (defined(__cplusplus) && __cplusplus >= 201103L)) && (!defined(__IBMC__) || __IBMC__ >= 1210) 6 | /* static_assert is a macro defined in in C11 or a compiler 7 | builtin in C++11. But IBM XL C V11 does not support _Static_assert, no 8 | matter what says. 9 | */ 10 | # define STATIC_ASSERT_DECL(COND) static_assert(COND, #COND) 11 | #else 12 | /* We use a bit-field instead of an array because gcc accepts 13 | 'typedef char x[n]' where n is not a compile-time constant. 14 | We want to enforce constantness. 15 | */ 16 | # define STATIC_ASSERT_2(COND, SUFFIX) \ 17 | typedef struct { \ 18 | unsigned int _static_assertion_failed_##SUFFIX : (COND) ? 1 : -1; \ 19 | } _static_assertion_failed_##SUFFIX PERL_UNUSED_DECL 20 | # define STATIC_ASSERT_1(COND, SUFFIX) STATIC_ASSERT_2(COND, SUFFIX) 21 | # define STATIC_ASSERT_DECL(COND) STATIC_ASSERT_1(COND, __LINE__) 22 | #endif 23 | /* We need this wrapper even in C11 because 'case X: static_assert(...);' is an 24 | error (static_assert is a declaration, and only statements can have labels). 25 | */ 26 | #define STATIC_ASSERT_STMT(COND) do { STATIC_ASSERT_DECL(COND); } while (0) 27 | 28 | #endif 29 | -------------------------------------------------------------------------------- /hax/block_end.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef block_end 4 | 5 | #include "scalarseq.c.inc" 6 | #include "pad_leavemy.c.inc" 7 | 8 | #define block_end(A, B) S_block_end(aTHX_ A, B) 9 | 10 | static OP *S_block_end(pTHX_ I32 floor, OP *seq) { 11 | dVAR; 12 | const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; 13 | OP *retval = scalarseq(seq); 14 | OP *o; 15 | 16 | CALL_BLOCK_HOOKS(bhk_pre_end, &retval); 17 | 18 | LEAVE_SCOPE(floor); 19 | #if !HAVE_PERL_VERSION(5, 19, 3) 20 | CopHINTS_set(&PL_compiling, PL_hints); 21 | #endif 22 | if (needblockscope) 23 | PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ 24 | 25 | o = pad_leavemy(); 26 | if (o) { 27 | #if HAVE_PERL_VERSION(5, 17, 4) 28 | OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; 29 | OP *const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; 30 | for (;; kid = kid->op_sibling) { 31 | OP *newkid = newOP(OP_CLONECV, 0); 32 | newkid->op_targ = kid->op_targ; 33 | o = op_append_elem(OP_LINESEQ, o, newkid); 34 | if (kid == last) break; 35 | } 36 | retval = op_prepend_elem(OP_LINESEQ, o, retval); 37 | #endif 38 | } 39 | 40 | CALL_BLOCK_HOOKS(bhk_post_end, &retval); 41 | 42 | return retval; 43 | } 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /hax/block_start.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef block_start 4 | 5 | #include "pad_block_start.c.inc" 6 | 7 | #define block_start(A) S_block_start(aTHX_ A) 8 | 9 | static int S_block_start(pTHX_ int full) { 10 | dVAR; 11 | const int retval = PL_savestack_ix; 12 | 13 | pad_block_start(full); 14 | SAVEHINTS(); 15 | PL_hints &= ~HINT_BLOCK_SCOPE; 16 | SAVECOMPILEWARNINGS(); 17 | PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); 18 | 19 | CALL_BLOCK_HOOKS(bhk_start, full); 20 | 21 | return retval; 22 | } 23 | 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /hax/intro_my.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef intro_my 4 | 5 | #include "COP_SEQ_RANGE_HIGH_set.c.inc" 6 | #include "COP_SEQ_RANGE_LOW_set.c.inc" 7 | 8 | #define intro_my() S_intro_my(aTHX) 9 | 10 | static U32 S_intro_my(pTHX) { 11 | dVAR; 12 | SV **svp; 13 | I32 i; 14 | U32 seq; 15 | 16 | ASSERT_CURPAD_ACTIVE("intro_my"); 17 | if (! PL_min_intro_pending) 18 | return PL_cop_seqmax; 19 | 20 | svp = AvARRAY(PL_comppad_name); 21 | for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { 22 | SV *const sv = svp[i]; 23 | 24 | if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv) 25 | && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) 26 | { 27 | COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ 28 | COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); 29 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, 30 | "Pad intromy: %ld \"%s\", (%lu,%lu)\n", 31 | (long)i, SvPVX_const(sv), 32 | (unsigned long)COP_SEQ_RANGE_LOW(sv), 33 | (unsigned long)COP_SEQ_RANGE_HIGH(sv)) 34 | ); 35 | } 36 | } 37 | seq = PL_cop_seqmax; 38 | PL_cop_seqmax++; 39 | if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ 40 | PL_cop_seqmax++; 41 | PL_min_intro_pending = 0; 42 | PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */ 43 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, 44 | "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); 45 | 46 | return seq; 47 | } 48 | 49 | #endif 50 | -------------------------------------------------------------------------------- /hax/newDEFSVOP.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef newDEFSVOP 4 | 5 | #include "pad_findmy_pvs.c.inc" 6 | 7 | #define newDEFSVOP() S_newDEFSVOP(aTHX) 8 | 9 | static OP *S_newDEFSVOP(pTHX) { 10 | dVAR; 11 | const PADOFFSET offset = pad_findmy_pvs("$_", 0); 12 | if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { 13 | return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); 14 | } 15 | else { 16 | OP * const o = newOP(OP_PADSV, 0); 17 | o->op_targ = offset; 18 | return o; 19 | } 20 | } 21 | 22 | #endif 23 | -------------------------------------------------------------------------------- /hax/op_convert_list.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef op_convert_list 4 | 5 | #define CHECKOP(type,o) \ 6 | ((PL_op_mask && PL_op_mask[type]) \ 7 | ? ( op_free((OP*)o), \ 8 | Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ 9 | (OP*)0 ) \ 10 | : PL_check[type](aTHX_ (OP*)o)) 11 | 12 | static OP *S_op_std_init(pTHX_ OP *o) { 13 | I32 type = o->op_type; 14 | 15 | if (PL_opargs[type] & OA_RETSCALAR) 16 | op_contextualize(o, G_SCALAR); 17 | if (PL_opargs[type] & OA_TARGET && !o->op_targ) 18 | o->op_targ = pad_alloc(type, SVs_PADTMP); 19 | 20 | return o; 21 | } 22 | 23 | #define op_convert_list(A, B, C) S_op_convert_list(aTHX_ A, B, C) 24 | 25 | static OP *S_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) 26 | { 27 | dVAR; 28 | assert(type >= 0); 29 | if (!o || o->op_type != OP_LIST) 30 | o = newLISTOP(OP_LIST, 0, o, NULL); 31 | else 32 | o->op_flags &= ~OPf_WANT; 33 | 34 | if (!(PL_opargs[type] & OA_MARK)) 35 | op_null(cLISTOPo->op_first); 36 | else { 37 | #if HAVE_PERL_VERSION(5, 15, 3) 38 | OP * const kid2 = cLISTOPo->op_first->op_sibling; 39 | if (kid2 && kid2->op_type == OP_COREARGS) { 40 | op_null(cLISTOPo->op_first); 41 | kid2->op_private |= OPpCOREARGS_PUSHMARK; 42 | } 43 | #endif 44 | } 45 | 46 | o->op_type = (OPCODE)type; 47 | o->op_ppaddr = PL_ppaddr[type]; 48 | o->op_flags |= flags; 49 | 50 | o = CHECKOP(type, o); 51 | if (o->op_type != type) { 52 | return o; 53 | } 54 | 55 | return S_op_std_init(aTHX_ o); 56 | } 57 | 58 | #endif 59 | -------------------------------------------------------------------------------- /hax/pad_add_name_pvs.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef pad_add_name_pvs 4 | 5 | #define pad_add_name_pvs(NAME, FLAGS, TYPESTASH, OURSTASH) S_pad_add_name_pvn(aTHX_ "" NAME "", sizeof NAME - 1, FLAGS, TYPESTASH, OURSTASH) 6 | 7 | #endif 8 | -------------------------------------------------------------------------------- /hax/pad_add_name_sv.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef pad_add_name_sv 4 | 5 | #include "pad_alloc.c.inc" 6 | #include "COP_SEQ_RANGE_LOW_set.c.inc" 7 | #include "COP_SEQ_RANGE_HIGH_set.c.inc" 8 | 9 | #define pad_add_name_sv(NAMESV, FLAGS, TYPESTASH, OURSTASH) S_pad_add_name_sv(aTHX_ NAMESV, FLAGS, TYPESTASH, OURSTASH) 10 | 11 | static PADOFFSET S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) { 12 | dVAR; 13 | const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); 14 | 15 | (void)flags; 16 | assert(flags == 0); 17 | 18 | ASSERT_CURPAD_ACTIVE("pad_alloc_name"); 19 | 20 | if (typestash) { 21 | assert(SvTYPE(namesv) == SVt_PVMG); 22 | SvPAD_TYPED_on(namesv); 23 | SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); 24 | } 25 | if (ourstash) { 26 | SvPAD_OUR_on(namesv); 27 | SvOURSTASH_set(namesv, ourstash); 28 | SvREFCNT_inc_simple_void_NN(ourstash); 29 | } 30 | 31 | av_store(PL_comppad_name, offset, namesv); 32 | return offset; 33 | } 34 | 35 | static PADOFFSET S_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) { 36 | dVAR; 37 | PADOFFSET offset; 38 | SV *namesv; 39 | 40 | assert(flags == 0); 41 | 42 | namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); 43 | 44 | sv_setpvn(namesv, namepv, namelen); 45 | 46 | offset = S_pad_alloc_name(aTHX_ namesv, flags, typestash, ourstash); 47 | 48 | /* not yet introduced */ 49 | COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO); 50 | COP_SEQ_RANGE_HIGH_set(namesv, 0); 51 | 52 | if (!PL_min_intro_pending) 53 | PL_min_intro_pending = offset; 54 | PL_max_intro_pending = offset; 55 | /* if it's not a simple scalar, replace with an AV or HV */ 56 | assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); 57 | assert(SvREFCNT(PL_curpad[offset]) == 1); 58 | if (namelen != 0 && *namepv == '@') 59 | sv_upgrade(PL_curpad[offset], SVt_PVAV); 60 | else if (namelen != 0 && *namepv == '%') 61 | sv_upgrade(PL_curpad[offset], SVt_PVHV); 62 | assert(SvPADMY(PL_curpad[offset])); 63 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, 64 | "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", 65 | (long)offset, SvPVX(namesv), 66 | PTR2UV(PL_curpad[offset]))); 67 | 68 | return offset; 69 | } 70 | 71 | static PADOFFSET S_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) { 72 | char *namepv; 73 | STRLEN namelen; 74 | assert(flags == 0); 75 | namepv = SvPV(name, namelen); 76 | return S_pad_add_name_pvn(aTHX_ namepv, namelen, flags, typestash, ourstash); 77 | } 78 | 79 | #endif 80 | -------------------------------------------------------------------------------- /hax/pad_alloc.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef pad_alloc 4 | 5 | #define pad_alloc(OPTYPE, TMPTYPE) S_pad_alloc(aTHX_ OPTYPE, TMPTYPE) 6 | 7 | static PADOFFSET S_pad_alloc(pTHX_ I32 optype, U32 tmptype) { 8 | dVAR; 9 | SV *sv; 10 | I32 retval; 11 | 12 | PERL_UNUSED_ARG(optype); 13 | ASSERT_CURPAD_ACTIVE("pad_alloc"); 14 | 15 | if (AvARRAY(PL_comppad) != PL_curpad) 16 | Perl_croak(aTHX_ "panic: pad_alloc"); 17 | PL_pad_reset_pending = FALSE; 18 | if (tmptype & SVs_PADMY) { 19 | sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); 20 | retval = AvFILLp(PL_comppad); 21 | } 22 | else { 23 | SV * const * const names = AvARRAY(PL_comppad_name); 24 | const SSize_t names_fill = AvFILLp(PL_comppad_name); 25 | for (;;) { 26 | /* 27 | * "foreach" index vars temporarily become aliases to non-"my" 28 | * values. Thus we must skip, not just pad values that are 29 | * marked as current pad values, but also those with names. 30 | */ 31 | /* HVDS why copy to sv here? we don't seem to use it */ 32 | if (++PL_padix <= names_fill && 33 | (sv = names[PL_padix]) && sv != &PL_sv_undef) 34 | continue; 35 | sv = *av_fetch(PL_comppad, PL_padix, TRUE); 36 | if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) && 37 | !IS_PADGV(sv) && !IS_PADCONST(sv)) 38 | break; 39 | } 40 | retval = PL_padix; 41 | } 42 | SvFLAGS(sv) |= tmptype; 43 | PL_curpad = AvARRAY(PL_comppad); 44 | 45 | DEBUG_X(PerlIO_printf(Perl_debug_log, 46 | "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n", 47 | PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, 48 | PL_op_name[optype])); 49 | #ifdef DEBUG_LEAKING_SCALARS 50 | sv->sv_debug_optype = optype; 51 | sv->sv_debug_inpad = 1; 52 | #endif 53 | return (PADOFFSET)retval; 54 | } 55 | 56 | #endif 57 | -------------------------------------------------------------------------------- /hax/pad_block_start.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef pad_block_start 4 | 5 | #define pad_block_start(A) S_pad_block_start(aTHX_ A) 6 | 7 | static void S_pad_block_start(pTHX_ int full) { 8 | dVAR; 9 | ASSERT_CURPAD_ACTIVE("pad_block_start"); 10 | SAVEI32(PL_comppad_name_floor); 11 | PL_comppad_name_floor = AvFILLp(PL_comppad_name); 12 | if (full) 13 | PL_comppad_name_fill = PL_comppad_name_floor; 14 | if (PL_comppad_name_floor < 0) 15 | PL_comppad_name_floor = 0; 16 | SAVEI32(PL_min_intro_pending); 17 | SAVEI32(PL_max_intro_pending); 18 | PL_min_intro_pending = 0; 19 | SAVEI32(PL_comppad_name_fill); 20 | SAVEI32(PL_padix_floor); 21 | PL_padix_floor = PL_padix; 22 | PL_pad_reset_pending = FALSE; 23 | } 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /hax/pad_findmy_pvs.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef pad_findmy_pvs 4 | 5 | #if HAVE_PERL_VERSION(5, 16, 0) 6 | #error "This situation surprises me considerably." 7 | #endif 8 | 9 | #define pad_findmy_pvs(NAME, FLAGS) pad_findmy("" NAME "", sizeof NAME - 1, FLAGS) 10 | 11 | #endif 12 | -------------------------------------------------------------------------------- /hax/pad_leavemy.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef pad_leavemy 4 | 5 | #define pad_leavemy() S_pad_leavemy(aTHX) 6 | 7 | static OP *S_pad_leavemy(pTHX) { 8 | dVAR; 9 | I32 off; 10 | OP *o = NULL; 11 | SV * const * const svp = AvARRAY(PL_comppad_name); 12 | 13 | PL_pad_reset_pending = FALSE; 14 | 15 | ASSERT_CURPAD_ACTIVE("pad_leavemy"); 16 | if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { 17 | for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { 18 | const SV * const sv = svp[off]; 19 | if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv)) 20 | Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), 21 | "%"SVf" never introduced", 22 | SVfARG(sv)); 23 | } 24 | } 25 | /* "Deintroduce" my variables that are leaving with this scope. */ 26 | for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { 27 | SV * const sv = svp[off]; 28 | if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv) 29 | && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) 30 | { 31 | COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); 32 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, 33 | "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", 34 | (long)off, SvPVX_const(sv), 35 | (unsigned long)COP_SEQ_RANGE_LOW(sv), 36 | (unsigned long)COP_SEQ_RANGE_HIGH(sv)) 37 | ); 38 | #if HAVE_PERL_VERSION(5, 17, 4) 39 | if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) 40 | && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { 41 | OP *kid = newOP(OP_INTROCV, 0); 42 | kid->op_targ = off; 43 | o = op_prepend_elem(OP_LINESEQ, kid, o); 44 | } 45 | #endif 46 | } 47 | } 48 | PL_cop_seqmax++; 49 | if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ 50 | PL_cop_seqmax++; 51 | DEBUG_Xv(PerlIO_printf(Perl_debug_log, 52 | "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); 53 | return o; 54 | } 55 | 56 | #endif 57 | -------------------------------------------------------------------------------- /hax/scalarseq.c.inc: -------------------------------------------------------------------------------- 1 | /* vi: set ft=c inde=: */ 2 | 3 | #ifndef scalarseq 4 | 5 | #define scalarseq(A) S_scalarseq(aTHX_ A) 6 | 7 | static OP *S_scalarseq(pTHX_ OP *o) { 8 | dVAR; 9 | if (o) { 10 | const OPCODE type = o->op_type; 11 | 12 | if (type == OP_LINESEQ || type == OP_SCOPE || 13 | type == OP_LEAVE || type == OP_LEAVETRY) 14 | { 15 | OP *kid; 16 | for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { 17 | if (kid->op_sibling) { 18 | op_contextualize(kid, G_VOID); 19 | } 20 | } 21 | PL_curcop = &PL_compiling; 22 | } 23 | o->op_flags &= ~OPf_PARENS; 24 | if (PL_hints & HINT_BLOCK_SCOPE) 25 | o->op_flags |= OPf_PARENS; 26 | } 27 | else 28 | o = newOP(OP_STUB, 0); 29 | return o; 30 | } 31 | 32 | #endif 33 | -------------------------------------------------------------------------------- /maint/distcheck.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | sub slurp { 5 | my ($file) = @_; 6 | open my $fh, '<', $file or die "$0: $file: $!\n"; 7 | local $/; 8 | readline $fh 9 | } 10 | 11 | my $version = shift @ARGV; 12 | my @modules = split ' ', shift @ARGV; 13 | 14 | my @errors; 15 | 16 | my $version_suffix = ''; 17 | if ($version =~ /(-TRIAL[0-9]*)\z/) { 18 | $version_suffix = $1; 19 | } elsif ($version !~ /_/) { 20 | my $file = 'Changes'; 21 | my $contents = slurp $file; 22 | 23 | $contents =~ m{ 24 | (?: 25 | \A \n? 26 | | 27 | \n \n 28 | ) 29 | \Q$version\E \s+ \d{4}-\d{2}-\d{2} \n 30 | [^\n\w]* \w 31 | }x or push @errors, "$file doesn't seem to contain an entry for $version"; 32 | } 33 | 34 | for my $module (@modules) { 35 | my $contents = slurp $module; 36 | my $pkg = $module; 37 | $pkg =~ s/\.pm\z//; 38 | $pkg =~ s![/\\]!::!g; 39 | $pkg =~ s/^lib:://; 40 | 41 | $contents =~ m{ 42 | ^ [ \t]* (?: our [ \t]+ )? 43 | \$ (?: \Q$pkg\E :: )? VERSION [ \t]* = [ \t]* 44 | ( \d+ (?: \. \d+ )? | '([^'\\]+)' ) ; 45 | }xm or do { 46 | push @errors, "$module doesn't contain a parsable VERSION declaration"; 47 | next; 48 | }; 49 | my $v = $+; 50 | 51 | $v eq $version || "$v$version_suffix" eq $version 52 | or push @errors, "$module version '$v' doesn't match distribution version '$version'"; 53 | } 54 | 55 | if (@errors) { 56 | print STDERR map "$0: $_\n", @errors; 57 | exit 1; 58 | } 59 | -------------------------------------------------------------------------------- /maint/pod2markdown.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | BEGIN { 5 | package Pod2GithubMarkdown; 6 | use Pod::Markdown (); 7 | our @ISA = 'Pod::Markdown'; 8 | 9 | sub new { 10 | my $class = shift; 11 | my $self = $class->SUPER::new( 12 | markdown_fragment_format => sub { 13 | my ($self, $str) = @_; 14 | $str =~ tr/A-Za-z0-9_\- //cd; 15 | $str =~ tr/A-Z /a-z-/; 16 | $str 17 | }, 18 | @_ 19 | ); 20 | $self->accept_targets('highlighter', 'github-markdown'); 21 | $self->{+__PACKAGE__} = { 22 | hl_language => '', 23 | }; 24 | $self 25 | } 26 | 27 | sub format_perldoc_url { 28 | my $self = shift; 29 | my ($name, $section) = @_; 30 | my $prev_url_prefix; 31 | if (defined $name && $name =~ /\Aperl[a-z0-9]*\z/) { 32 | $prev_url_prefix = $self->perldoc_url_prefix; 33 | $self->perldoc_url_prefix('https://perldoc.perl.org/'); 34 | } 35 | my $url = $self->SUPER::format_perldoc_url($name, $section); 36 | $self->perldoc_url_prefix($prev_url_prefix) if defined $prev_url_prefix; 37 | $url 38 | } 39 | 40 | sub start_for { 41 | my $self = shift; 42 | my ($attr) = @_; 43 | if ($attr->{target} eq 'highlighter') { 44 | $self->_new_stack; 45 | $self->_stack_state->{for_highlighter} = 1; 46 | return; 47 | } 48 | $self->SUPER::start_for(@_) 49 | } 50 | 51 | sub end_for { 52 | my $self = shift; 53 | my ($attr) = @_; 54 | if ($self->_stack_state->{for_highlighter}) { 55 | my $text = $self->_pop_stack_text; 56 | my %settings = 57 | map /\A([^=]*)=(.*)\z/s 58 | ? ($1 => $2) 59 | : (language => $_), 60 | split ' ', $text; 61 | $self->{+__PACKAGE__}{hl_language} = $settings{language} // ''; 62 | return; 63 | } 64 | $self->SUPER::end_for(@_) 65 | } 66 | 67 | sub _indent_verbatim { 68 | my $self = shift; 69 | my ($paragraph) = @_; 70 | my $min_indent = 'inf'; 71 | while ($paragraph =~ /^( +)/mg) { 72 | my $n = length $1; 73 | $min_indent = $n if $n < $min_indent; 74 | } 75 | my $rep = 76 | $min_indent < 'inf' 77 | ? "{$min_indent}" 78 | : '+'; 79 | $paragraph =~ s/^ $rep//mg; 80 | my $fence = '```'; 81 | while ($paragraph =~ /^ *\Q$fence\E *$/m) { 82 | $fence .= '`'; 83 | } 84 | my $hl_language = $self->{+__PACKAGE__}{hl_language}; 85 | if ($hl_language !~ /\A[^`\s]\S*\z/) { 86 | $hl_language = ''; 87 | } 88 | "$fence$hl_language\n$paragraph\n$fence" 89 | } 90 | 91 | sub end_item_number { 92 | my $self = shift; 93 | if ($self->_last_string =~ /\S/) { 94 | return $self->SUPER::end_item_number(@_); 95 | } 96 | $self->_end_item($self->_private->{item_number} . '. '); 97 | } 98 | } 99 | 100 | binmode $_ for \*STDIN, \*STDOUT; 101 | 102 | my $parser = Pod2GithubMarkdown->new( 103 | output_encoding => 'UTF-8', 104 | ); 105 | $parser->output_fh(\*STDOUT); 106 | $parser->parse_file(\*STDIN); 107 | -------------------------------------------------------------------------------- /maint/pod2readme.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | BEGIN { 5 | package Pod2ReadmeText; 6 | use Pod::Text (); 7 | our @ISA = 'Pod::Text'; 8 | 9 | sub new { 10 | my $class = shift; 11 | my $self = $class->SUPER::new(@_); 12 | $self->accept_targets('README'); 13 | $self->{+__PACKAGE__} = { 14 | passthrough => 0, 15 | }; 16 | $self 17 | } 18 | 19 | sub cmd_head1 { 20 | my $self = shift; 21 | my ($attrs, $text) = @_; 22 | $self->{+__PACKAGE__}{passthrough} = $text =~ /^\s*(?:NAME|INSTALLATION|LICENSE|COPYRIGHT|SUPPORT)\b/; 23 | $self->SUPER::cmd_head1(@_) 24 | } 25 | 26 | sub output { 27 | my $self = shift; 28 | $self->{+__PACKAGE__}{passthrough} or return; 29 | $self->SUPER::output(@_) 30 | } 31 | } 32 | 33 | my $parser = Pod2ReadmeText->new( 34 | sentence => 0, 35 | errors => 'die', 36 | loose => 1, 37 | ); 38 | 39 | $parser->parse_from_file; 40 | -------------------------------------------------------------------------------- /maint/tm.pl: -------------------------------------------------------------------------------- 1 | use v5.12.0; 2 | use warnings; 3 | 4 | my $tmpl_file; 5 | (($tmpl_file, my $perl_ver_min, my $perl_ver_max) = @ARGV) == 3 6 | && (my $out_file = $tmpl_file) =~ s/\.tmpl\z// 7 | or die "Usage: $0 FILE.tmpl PERL_VER_MIN PERL_VER_MAX\n"; 8 | 9 | open my $fh, '<', $tmpl_file 10 | or die "$0: can't open for reading: $tmpl_file: $!\n"; 11 | 12 | my %tmpl_var = ( 13 | 'perl-versions' => '[' . join(', ', map $_ % 2 ? () : qq{"5.$_"}, $perl_ver_min .. $perl_ver_max) . ']', 14 | ); 15 | 16 | my $output = ''; 17 | while (my $line = readline $fh) { 18 | $line =~ s{<\?php echo \h*(.*?)\h*; \?>}{ 19 | $tmpl_var{$1} // die "Unknown template parameter '$1'"; 20 | }eg; 21 | $output .= $line; 22 | } 23 | 24 | my $out_file_tmp = "$out_file.~tmp~"; 25 | 26 | open my $out_fh, '>', $out_file_tmp 27 | or die "$0: can't open for writing: $out_file_tmp: $!\n"; 28 | 29 | print $out_fh $output 30 | or die "$0: can't write: $out_file_tmp: $!\n"; 31 | 32 | close $out_fh 33 | or die "$0: can't write: $out_file_tmp: $!\n"; 34 | 35 | rename $out_file_tmp, $out_file 36 | or die "$0: can't rename $out_file_tmp to $out_file: $!\n"; 37 | -------------------------------------------------------------------------------- /t/01-compiles.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 10; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters; 9 | 10 | fun id_1($x) { $x } 11 | 12 | fun id_2 13 | ( 14 | $x 15 | ) 16 | : #hello 17 | prototype( 18 | $ 19 | ) 20 | {@_ == 1 or return; 21 | $x 22 | } 23 | 24 | fun id_3 ## 25 | ( $x ## 26 | ) ##AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 27 | { ## 28 | $x ## 29 | } ## 30 | 31 | fun add($x, $y) { 32 | $x + $y 33 | } 34 | 35 | fun mymap($fun, @args) :prototype(&@) { 36 | my @res; 37 | for (@args) { 38 | push @res, $fun->($_); 39 | } 40 | @res 41 | } 42 | 43 | fun fac_1($n) { 44 | $n < 2 ? 1 : $n * fac_1 $n - 1 45 | } 46 | 47 | fun fac_2($n) :prototype($) { 48 | $n < 2 ? 1 : $n * fac_2 $n - 1 49 | } 50 | 51 | ok id_1 1; 52 | ok id_1(1), 'basic sanity'; 53 | ok id_2 1, 'simple prototype'; 54 | ok id_3(1), 'definition over multiple lines'; 55 | is add(2, 2), 4, '2 + 2 = 4'; 56 | is add(39, 3), 42, '39 + 3 = 42'; 57 | is_deeply [mymap { $_ * 2 } 2, 3, 5, 9], [4, 6, 10, 18], 'mymap works'; 58 | is fac_1(5), 120, 'fac_1'; 59 | is fac_2 6, 720, 'fac_2'; 60 | is fun ($x, $y) { $x . $y }->(fun ($foo) { $foo + 1 }->(3), fun ($bar) { $bar * 2 }->(1)), '42', 'anonyfun'; 61 | -------------------------------------------------------------------------------- /t/02-compiles.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 10; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters; 9 | 10 | method id_1() { $self } 11 | 12 | method id_2 13 | ( 14 | 15 | ) 16 | : #hello 17 | prototype( 18 | $ 19 | ) 20 | {@_ == 0 or return; 21 | $self 22 | } 23 | 24 | method## 25 | id_3 ## 26 | ( ## 27 | # 28 | ) ##AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 29 | { ## 30 | $self ## 31 | } ## 32 | 33 | method add($y) { 34 | $self + $y 35 | } 36 | 37 | method mymap(@args) :prototype(&@) { 38 | my @res; 39 | for (@args) { 40 | push @res, $self->($_); 41 | } 42 | @res 43 | } 44 | 45 | method fac_1() { 46 | $self < 2 ? 1 : $self * fac_1 $self - 1 47 | } 48 | 49 | method fac_2() :prototype($) { 50 | $self < 2 ? 1 : $self * fac_2 $self - 1 51 | } 52 | 53 | ok id_1 1; 54 | ok id_1(1), 'basic sanity'; 55 | ok id_2 1, 'simple prototype'; 56 | ok id_3(1), 'definition over multiple lines'; 57 | is add(2, 2), 4, '2 + 2 = 4'; 58 | is add(39, 3), 42, '39 + 3 = 42'; 59 | is_deeply [mymap { $_ * 2 } 2, 3, 5, 9], [4, 6, 10, 18], 'mymap works'; 60 | is fac_1(5), 120, 'fac_1'; 61 | is fac_2 6, 720, 'fac_2'; 62 | is method ($y) { $self . $y }->(method () { $self + 1 }->(3), method () { $self * 2 }->(1)), '42', 'anonyfun'; 63 | -------------------------------------------------------------------------------- /t/03-compiles.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 10; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters { clathod => 'classmethod' }; 9 | 10 | clathod id_1() { $class } 11 | 12 | clathod id_2 13 | ( 14 | 15 | ) 16 | : #hello 17 | prototype( 18 | $ 19 | ) 20 | {@_ == 0 or return; 21 | $class 22 | } 23 | 24 | clathod## 25 | id_3 ## 26 | ( ## 27 | # 28 | ) ##AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 29 | { ## 30 | $class## 31 | } ## 32 | 33 | clathod add($y) { 34 | $class + $y 35 | } 36 | 37 | clathod mymap(@args) :prototype(&@) { 38 | my @res; 39 | for (@args) { 40 | push @res, $class->($_); 41 | } 42 | @res 43 | } 44 | 45 | clathod fac_1() { 46 | $class < 2 ? 1 : $class * fac_1 $class - 1 47 | } 48 | 49 | clathod fac_2() :prototype($) { 50 | $class < 2 ? 1 : $class * fac_2 $class - 1 51 | } 52 | 53 | ok id_1 1; 54 | ok id_1(1), 'basic sanity'; 55 | ok id_2 1, 'simple prototype'; 56 | ok id_3(1), 'definition over multiple lines'; 57 | is add(2, 2), 4, '2 + 2 = 4'; 58 | is add(39, 3), 42, '39 + 3 = 42'; 59 | is_deeply [mymap { $_ * 2 } 2, 3, 5, 9], [4, 6, 10, 18], 'mymap works'; 60 | is fac_1(5), 120, 'fac_1'; 61 | is fac_2 6, 720, 'fac_2'; 62 | is clathod ($y) { $class . $y }->(clathod () { $class + 1 }->(3), clathod () { $class * 2 }->(1)), '42', 'anonyfun'; 63 | -------------------------------------------------------------------------------- /t/attributes.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 10; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters { 9 | fun => 'function', 10 | method => 'method', 11 | elrond => { 12 | attributes => ':lvalue', 13 | }, 14 | }; 15 | 16 | is eval('use Function::Parameters { fun => { attributes => "nope" } }; 1'), undef; 17 | like $@, qr/nope.*attributes/; 18 | 19 | is eval('use Function::Parameters { fun => { attributes => ": in valid {" } }; 1'), undef; 20 | like $@, qr/in valid.*attributes/; 21 | 22 | elrond hobbard($ref) { $$ref } 23 | { 24 | my $x = 1; 25 | hobbard(\$x) = 'bling'; 26 | is $x, 'bling'; 27 | 28 | } 29 | $_ = 'fool'; 30 | chop hobbard \$_; 31 | is $_, 'foo'; 32 | 33 | { 34 | package BatCountry; 35 | 36 | fun join($group, $peer) { 37 | return "* $peer has joined $group"; 38 | } 39 | 40 | ::is eval('join("left", "right")'), undef; 41 | ::like $@, qr/Ambiguous.*CORE::/; 42 | } 43 | 44 | { 45 | package CatCountry; 46 | 47 | method join($peer) { 48 | return "* $peer has joined $self->{name}"; 49 | } 50 | 51 | ::is join('!', 'left', 'right'), 'left!right'; 52 | 53 | my $obj = bless {name => 'kittens'}; 54 | ::is $obj->join("twig"), "* twig has joined kittens"; 55 | } 56 | -------------------------------------------------------------------------------- /t/bonus.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 13; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters { 9 | fun => { 10 | defaults => 'function_strict', 11 | }, 12 | }; 13 | 14 | fun filter($f = fun ($x) { 1 }, @xs) { 15 | !@xs 16 | ? () 17 | : (($f->($xs[0]) ? $xs[0] : ()), filter $f, @xs[1 .. $#xs]) 18 | } 19 | 20 | is_deeply [filter], []; 21 | is_deeply [filter fun (@) { 1 }, 2 .. 3], [2 .. 3]; 22 | is_deeply [filter fun ($x) { $x % 2 }, 1 .. 10], [1, 3, 5, 7, 9]; 23 | 24 | fun fact($k, $n) :prototype(&$) { 25 | $n < 2 26 | ? $k->(1) 27 | : fact { $k->($n * $_[0]) } $n - 1 28 | } 29 | 30 | is +(fact { "~@_~" } 5), "~120~"; 31 | is +(fact { $_[0] / 2 } 6), 360; 32 | 33 | fun write_to($ref) :prototype(\$) :lvalue { $$ref } 34 | 35 | { 36 | my $x = 2; 37 | is $x, 2; 38 | write_to($x) = "hi"; 39 | is $x, "hi"; 40 | write_to($x)++; 41 | is $x, "hj"; 42 | } 43 | 44 | { 45 | my $c = 0; 46 | fun horf_dorf($ref, $val = $c++) :prototype(\@;$) :lvalue { 47 | push @$ref, $val; 48 | $ref->[-1] 49 | } 50 | } 51 | 52 | { 53 | my @asdf = "A"; 54 | is_deeply \@asdf, ["A"]; 55 | horf_dorf(@asdf) = "b"; 56 | is_deeply \@asdf, ["A", "b"]; 57 | ++horf_dorf @asdf; 58 | is_deeply \@asdf, ["A", "b", 2]; 59 | horf_dorf @asdf, 100; 60 | is_deeply \@asdf, ["A", "b", 2, 100]; 61 | splice @asdf, 1, 1; 62 | horf_dorf(@asdf) *= 3; 63 | is_deeply \@asdf, ["A", 2, 100, 6]; 64 | } 65 | -------------------------------------------------------------------------------- /t/checkered.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 108; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters { 9 | fun => { 10 | strict => 1, 11 | }, 12 | 13 | sad => { 14 | strict => 0, 15 | }, 16 | }; 17 | 18 | fun error_like($re, $body, $name = undef) { 19 | local $@; 20 | ok !eval { $body->(); 1 }; 21 | like $@, $re, $name; 22 | } 23 | 24 | fun foo_any(@) { [@_] } 25 | fun foo_any_a(@args) { [@args] } 26 | fun foo_any_b($x = undef, @rest) { [@_] } 27 | fun foo_0() { [@_] } 28 | fun foo_1($x) { [@_] } 29 | fun foo_2($x, $y) { [@_] } 30 | fun foo_3($x, $y, $z) { [@_] } 31 | fun foo_0_1($x = 'D0') { [$x] } 32 | fun foo_0_2($x = 'D0', $y = 'D1') { [$x, $y] } 33 | fun foo_0_3($x = 'D0', $y = undef, $z = 'D2') { [$x, $y, $z] } 34 | fun foo_1_2($x, $y = 'D1') { [$x, $y] } 35 | fun foo_1_3($x, $y = 'D1', $z = 'D2') { [$x, $y, $z] } 36 | fun foo_2_3($x, $y, $z = 'D2') { [$x, $y, $z] } 37 | fun foo_1_($x, @y) { [@_] } 38 | 39 | is_deeply foo_any, []; 40 | is_deeply foo_any('a'), ['a']; 41 | is_deeply foo_any('a', 'b'), ['a', 'b']; 42 | is_deeply foo_any('a', 'b', 'c'), ['a', 'b', 'c']; 43 | is_deeply foo_any('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 44 | 45 | is_deeply foo_any_a, []; 46 | is_deeply foo_any_a('a'), ['a']; 47 | is_deeply foo_any_a('a', 'b'), ['a', 'b']; 48 | is_deeply foo_any_a('a', 'b', 'c'), ['a', 'b', 'c']; 49 | is_deeply foo_any_a('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 50 | 51 | is_deeply foo_any_b, []; 52 | is_deeply foo_any_b('a'), ['a']; 53 | is_deeply foo_any_b('a', 'b'), ['a', 'b']; 54 | is_deeply foo_any_b('a', 'b', 'c'), ['a', 'b', 'c']; 55 | is_deeply foo_any_b('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 56 | 57 | is_deeply foo_0, []; 58 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a' }; 59 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b' }; 60 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c' }; 61 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c', 'd' }; 62 | 63 | error_like qr/^Too few arguments.*foo_1/, fun () { foo_1 }; 64 | is_deeply foo_1('a'), ['a']; 65 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b' }; 66 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c' }; 67 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c', 'd' }; 68 | 69 | error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 }; 70 | error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 'a' }; 71 | is_deeply foo_2('a', 'b'), ['a', 'b']; 72 | error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c' }; 73 | error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c', 'd' }; 74 | 75 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 }; 76 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a' }; 77 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a', 'b' }; 78 | is_deeply foo_3('a', 'b', 'c'), ['a', 'b', 'c']; 79 | error_like qr/^Too many arguments.*foo_3/, fun () { foo_3 'a', 'b', 'c', 'd' }; 80 | 81 | is_deeply foo_0_1, ['D0']; 82 | is_deeply foo_0_1('a'), ['a']; 83 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b' }; 84 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c' }; 85 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c', 'd' }; 86 | 87 | is_deeply foo_0_2, ['D0', 'D1']; 88 | is_deeply foo_0_2('a'), ['a', 'D1']; 89 | is_deeply foo_0_2('a', 'b'), ['a', 'b']; 90 | error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c' }; 91 | error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c', 'd' }; 92 | 93 | is_deeply foo_0_3, ['D0', undef, 'D2']; 94 | is_deeply foo_0_3('a'), ['a', undef, 'D2']; 95 | is_deeply foo_0_3('a', 'b'), ['a', 'b', 'D2']; 96 | is_deeply foo_0_3('a', 'b', 'c'), ['a', 'b', 'c']; 97 | error_like qr/^Too many arguments.*foo_0_3/, fun () { foo_0_3 'a', 'b', 'c', 'd' }; 98 | 99 | error_like qr/^Too few arguments.*foo_1_2/, fun () { foo_1_2 }; 100 | is_deeply foo_1_2('a'), ['a', 'D1']; 101 | is_deeply foo_1_2('a', 'b'), ['a', 'b']; 102 | error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c' }; 103 | error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c', 'd' }; 104 | 105 | error_like qr/^Too few arguments.*foo_1_3/, fun () { foo_1_3 }; 106 | is_deeply foo_1_3('a'), ['a', 'D1', 'D2']; 107 | is_deeply foo_1_3('a', 'b'), ['a', 'b', 'D2']; 108 | is_deeply foo_1_3('a', 'b', 'c'), ['a', 'b', 'c']; 109 | error_like qr/^Too many arguments.*foo_1_3/, fun () { foo_1_3 'a', 'b', 'c', 'd' }; 110 | 111 | error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 }; 112 | error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 'a' }; 113 | is_deeply foo_2_3('a', 'b'), ['a', 'b', 'D2']; 114 | is_deeply foo_2_3('a', 'b', 'c'), ['a', 'b', 'c']; 115 | error_like qr/^Too many arguments.*foo_2_3/, fun () { foo_2_3 'a', 'b', 'c', 'd' }; 116 | 117 | error_like qr/^Too few arguments.*foo_1_/, fun () { foo_1_ }; 118 | is_deeply foo_1_('a'), ['a']; 119 | is_deeply foo_1_('a', 'b'), ['a', 'b']; 120 | is_deeply foo_1_('a', 'b', 'c'), ['a', 'b', 'c']; 121 | is_deeply foo_1_('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 122 | 123 | 124 | sad puppy($eyes) { [@_] } 125 | sad frog($will, $never) { $will * 3 + (pop) - $never } 126 | 127 | is_deeply puppy, []; 128 | is_deeply puppy('a'), ['a']; 129 | is_deeply puppy('a', 'b'), ['a', 'b']; 130 | is_deeply puppy('a', 'b', 'c'), ['a', 'b', 'c']; 131 | is_deeply puppy('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 132 | 133 | is frog(7, 4, 1), 18; 134 | is frog(7, 4), 21; 135 | -------------------------------------------------------------------------------- /t/checkered_3.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 108; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters qw(:strict); 9 | 10 | fun error_like($re, $body, $name = undef) { 11 | local $@; 12 | ok !eval { $body->(); 1 }; 13 | like $@, $re, $name; 14 | } 15 | 16 | fun foo_any(@) { [@_] } 17 | fun foo_any_a(@args) { [@args] } 18 | fun foo_any_b($x = undef, @rest) { [@_] } 19 | fun foo_0() { [@_] } 20 | fun foo_1($x) { [@_] } 21 | fun foo_2($x, $y) { [@_] } 22 | fun foo_3($x, $y, $z) { [@_] } 23 | fun foo_0_1($x = 'D0') { [$x] } 24 | fun foo_0_2($x = 'D0', $y = 'D1') { [$x, $y] } 25 | fun foo_0_3($x = 'D0', $y = undef, $z = 'D2') { [$x, $y, $z] } 26 | fun foo_1_2($x, $y = 'D1') { [$x, $y] } 27 | fun foo_1_3($x, $y = 'D1', $z = 'D2') { [$x, $y, $z] } 28 | fun foo_2_3($x, $y, $z = 'D2') { [$x, $y, $z] } 29 | fun foo_1_($x, @y) { [@_] } 30 | 31 | is_deeply foo_any, []; 32 | is_deeply foo_any('a'), ['a']; 33 | is_deeply foo_any('a', 'b'), ['a', 'b']; 34 | is_deeply foo_any('a', 'b', 'c'), ['a', 'b', 'c']; 35 | is_deeply foo_any('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 36 | 37 | is_deeply foo_any_a, []; 38 | is_deeply foo_any_a('a'), ['a']; 39 | is_deeply foo_any_a('a', 'b'), ['a', 'b']; 40 | is_deeply foo_any_a('a', 'b', 'c'), ['a', 'b', 'c']; 41 | is_deeply foo_any_a('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 42 | 43 | is_deeply foo_any_b, []; 44 | is_deeply foo_any_b('a'), ['a']; 45 | is_deeply foo_any_b('a', 'b'), ['a', 'b']; 46 | is_deeply foo_any_b('a', 'b', 'c'), ['a', 'b', 'c']; 47 | is_deeply foo_any_b('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 48 | 49 | is_deeply foo_0, []; 50 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a' }; 51 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b' }; 52 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c' }; 53 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c', 'd' }; 54 | 55 | error_like qr/^Too few arguments.*foo_1/, fun () { foo_1 }; 56 | is_deeply foo_1('a'), ['a']; 57 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b' }; 58 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c' }; 59 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c', 'd' }; 60 | 61 | error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 }; 62 | error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 'a' }; 63 | is_deeply foo_2('a', 'b'), ['a', 'b']; 64 | error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c' }; 65 | error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c', 'd' }; 66 | 67 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 }; 68 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a' }; 69 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a', 'b' }; 70 | is_deeply foo_3('a', 'b', 'c'), ['a', 'b', 'c']; 71 | error_like qr/^Too many arguments.*foo_3/, fun () { foo_3 'a', 'b', 'c', 'd' }; 72 | 73 | is_deeply foo_0_1, ['D0']; 74 | is_deeply foo_0_1('a'), ['a']; 75 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b' }; 76 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c' }; 77 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c', 'd' }; 78 | 79 | is_deeply foo_0_2, ['D0', 'D1']; 80 | is_deeply foo_0_2('a'), ['a', 'D1']; 81 | is_deeply foo_0_2('a', 'b'), ['a', 'b']; 82 | error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c' }; 83 | error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c', 'd' }; 84 | 85 | is_deeply foo_0_3, ['D0', undef, 'D2']; 86 | is_deeply foo_0_3('a'), ['a', undef, 'D2']; 87 | is_deeply foo_0_3('a', 'b'), ['a', 'b', 'D2']; 88 | is_deeply foo_0_3('a', 'b', 'c'), ['a', 'b', 'c']; 89 | error_like qr/^Too many arguments.*foo_0_3/, fun () { foo_0_3 'a', 'b', 'c', 'd' }; 90 | 91 | error_like qr/^Too few arguments.*foo_1_2/, fun () { foo_1_2 }; 92 | is_deeply foo_1_2('a'), ['a', 'D1']; 93 | is_deeply foo_1_2('a', 'b'), ['a', 'b']; 94 | error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c' }; 95 | error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c', 'd' }; 96 | 97 | error_like qr/^Too few arguments.*foo_1_3/, fun () { foo_1_3 }; 98 | is_deeply foo_1_3('a'), ['a', 'D1', 'D2']; 99 | is_deeply foo_1_3('a', 'b'), ['a', 'b', 'D2']; 100 | is_deeply foo_1_3('a', 'b', 'c'), ['a', 'b', 'c']; 101 | error_like qr/^Too many arguments.*foo_1_3/, fun () { foo_1_3 'a', 'b', 'c', 'd' }; 102 | 103 | error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 }; 104 | error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 'a' }; 105 | is_deeply foo_2_3('a', 'b'), ['a', 'b', 'D2']; 106 | is_deeply foo_2_3('a', 'b', 'c'), ['a', 'b', 'c']; 107 | error_like qr/^Too many arguments.*foo_2_3/, fun () { foo_2_3 'a', 'b', 'c', 'd' }; 108 | 109 | error_like qr/^Too few arguments.*foo_1_/, fun () { foo_1_ }; 110 | is_deeply foo_1_('a'), ['a']; 111 | is_deeply foo_1_('a', 'b'), ['a', 'b']; 112 | is_deeply foo_1_('a', 'b', 'c'), ['a', 'b', 'c']; 113 | is_deeply foo_1_('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 114 | 115 | 116 | use Function::Parameters qw(:lax); 117 | 118 | fun puppy($eyes) { [@_] } 119 | fun frog($will, $never) { $will * 3 + (pop) - $never } 120 | 121 | is_deeply puppy, []; 122 | is_deeply puppy('a'), ['a']; 123 | is_deeply puppy('a', 'b'), ['a', 'b']; 124 | is_deeply puppy('a', 'b', 'c'), ['a', 'b', 'c']; 125 | is_deeply puppy('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 126 | 127 | is frog(7, 4, 1), 18; 128 | is frog(7, 4), 21; 129 | -------------------------------------------------------------------------------- /t/checkered_4.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 108; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters { 9 | fun => 'function_strict', 10 | sad => 'function_lax', 11 | }; 12 | 13 | fun error_like($re, $body, $name = undef) { 14 | local $@; 15 | ok !eval { $body->(); 1 }; 16 | like $@, $re, $name; 17 | } 18 | 19 | fun foo_any(@) { [@_] } 20 | fun foo_any_a(@args) { [@args] } 21 | fun foo_any_b($x = undef, @rest) { [@_] } 22 | fun foo_0() { [@_] } 23 | fun foo_1($x) { [@_] } 24 | fun foo_2($x, $y) { [@_] } 25 | fun foo_3($x, $y, $z) { [@_] } 26 | fun foo_0_1($x = 'D0') { [$x] } 27 | fun foo_0_2($x = 'D0', $y = 'D1') { [$x, $y] } 28 | fun foo_0_3($x = 'D0', $y = undef, $z = 'D2') { [$x, $y, $z] } 29 | fun foo_1_2($x, $y = 'D1') { [$x, $y] } 30 | fun foo_1_3($x, $y = 'D1', $z = 'D2') { [$x, $y, $z] } 31 | fun foo_2_3($x, $y, $z = 'D2') { [$x, $y, $z] } 32 | fun foo_1_($x, @y) { [@_] } 33 | 34 | is_deeply foo_any, []; 35 | is_deeply foo_any('a'), ['a']; 36 | is_deeply foo_any('a', 'b'), ['a', 'b']; 37 | is_deeply foo_any('a', 'b', 'c'), ['a', 'b', 'c']; 38 | is_deeply foo_any('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 39 | 40 | is_deeply foo_any_a, []; 41 | is_deeply foo_any_a('a'), ['a']; 42 | is_deeply foo_any_a('a', 'b'), ['a', 'b']; 43 | is_deeply foo_any_a('a', 'b', 'c'), ['a', 'b', 'c']; 44 | is_deeply foo_any_a('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 45 | 46 | is_deeply foo_any_b, []; 47 | is_deeply foo_any_b('a'), ['a']; 48 | is_deeply foo_any_b('a', 'b'), ['a', 'b']; 49 | is_deeply foo_any_b('a', 'b', 'c'), ['a', 'b', 'c']; 50 | is_deeply foo_any_b('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 51 | 52 | is_deeply foo_0, []; 53 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a' }; 54 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b' }; 55 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c' }; 56 | error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c', 'd' }; 57 | 58 | error_like qr/^Too few arguments.*foo_1/, fun () { foo_1 }; 59 | is_deeply foo_1('a'), ['a']; 60 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b' }; 61 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c' }; 62 | error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c', 'd' }; 63 | 64 | error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 }; 65 | error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 'a' }; 66 | is_deeply foo_2('a', 'b'), ['a', 'b']; 67 | error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c' }; 68 | error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c', 'd' }; 69 | 70 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 }; 71 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a' }; 72 | error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a', 'b' }; 73 | is_deeply foo_3('a', 'b', 'c'), ['a', 'b', 'c']; 74 | error_like qr/^Too many arguments.*foo_3/, fun () { foo_3 'a', 'b', 'c', 'd' }; 75 | 76 | is_deeply foo_0_1, ['D0']; 77 | is_deeply foo_0_1('a'), ['a']; 78 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b' }; 79 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c' }; 80 | error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c', 'd' }; 81 | 82 | is_deeply foo_0_2, ['D0', 'D1']; 83 | is_deeply foo_0_2('a'), ['a', 'D1']; 84 | is_deeply foo_0_2('a', 'b'), ['a', 'b']; 85 | error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c' }; 86 | error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c', 'd' }; 87 | 88 | is_deeply foo_0_3, ['D0', undef, 'D2']; 89 | is_deeply foo_0_3('a'), ['a', undef, 'D2']; 90 | is_deeply foo_0_3('a', 'b'), ['a', 'b', 'D2']; 91 | is_deeply foo_0_3('a', 'b', 'c'), ['a', 'b', 'c']; 92 | error_like qr/^Too many arguments.*foo_0_3/, fun () { foo_0_3 'a', 'b', 'c', 'd' }; 93 | 94 | error_like qr/^Too few arguments.*foo_1_2/, fun () { foo_1_2 }; 95 | is_deeply foo_1_2('a'), ['a', 'D1']; 96 | is_deeply foo_1_2('a', 'b'), ['a', 'b']; 97 | error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c' }; 98 | error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c', 'd' }; 99 | 100 | error_like qr/^Too few arguments.*foo_1_3/, fun () { foo_1_3 }; 101 | is_deeply foo_1_3('a'), ['a', 'D1', 'D2']; 102 | is_deeply foo_1_3('a', 'b'), ['a', 'b', 'D2']; 103 | is_deeply foo_1_3('a', 'b', 'c'), ['a', 'b', 'c']; 104 | error_like qr/^Too many arguments.*foo_1_3/, fun () { foo_1_3 'a', 'b', 'c', 'd' }; 105 | 106 | error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 }; 107 | error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 'a' }; 108 | is_deeply foo_2_3('a', 'b'), ['a', 'b', 'D2']; 109 | is_deeply foo_2_3('a', 'b', 'c'), ['a', 'b', 'c']; 110 | error_like qr/^Too many arguments.*foo_2_3/, fun () { foo_2_3 'a', 'b', 'c', 'd' }; 111 | 112 | error_like qr/^Too few arguments.*foo_1_/, fun () { foo_1_ }; 113 | is_deeply foo_1_('a'), ['a']; 114 | is_deeply foo_1_('a', 'b'), ['a', 'b']; 115 | is_deeply foo_1_('a', 'b', 'c'), ['a', 'b', 'c']; 116 | is_deeply foo_1_('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 117 | 118 | 119 | sad puppy($eyes) { [@_] } 120 | sad frog($will, $never) { $will * 3 + (pop) - $never } 121 | 122 | is_deeply puppy, []; 123 | is_deeply puppy('a'), ['a']; 124 | is_deeply puppy('a', 'b'), ['a', 'b']; 125 | is_deeply puppy('a', 'b', 'c'), ['a', 'b', 'c']; 126 | is_deeply puppy('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; 127 | 128 | is frog(7, 4, 1), 18; 129 | is frog(7, 4), 21; 130 | -------------------------------------------------------------------------------- /t/croak.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More tests => 12; 7 | use Test::Fatal; 8 | 9 | use Function::Parameters { 10 | fun => { defaults => 'function_strict', reify_type => \&MyT::reify_type }, 11 | method => 'method_strict', 12 | }; 13 | 14 | { 15 | package MyT; 16 | 17 | fun reify_type($type) { 18 | bless [$type], __PACKAGE__ 19 | } 20 | 21 | method check($value) { 0 } 22 | 23 | method get_message($value) { 24 | "A failure ($self->[0]) of $value" 25 | } 26 | } 27 | 28 | my $marker = __LINE__; 29 | { 30 | package Crabs; 31 | 32 | fun take2($x, $y) {} 33 | fun worng1() { take2 1 } 34 | fun worng4() { take2 1, 2, 3, 4 } 35 | 36 | fun takekw(:$zomg) {} 37 | fun worngkw1() { takekw "a", "b", "c" } 38 | fun worngkw2() { takekw a => 1 } 39 | fun worngkw4() { takekw zomg => 1, a => 2 } 40 | 41 | fun taket(Cool[Story] $x) {} 42 | fun worngt1() { taket "X" } 43 | } 44 | 45 | is exception { Crabs::take2 1 }, "Too few arguments for fun take2 (expected 2, got 1) at ${\__FILE__} line ${\__LINE__}.\n"; 46 | is exception { Crabs::worng1 }, "Too few arguments for fun take2 (expected 2, got 1) at ${\__FILE__} line ${\($marker + 5)}.\n"; 47 | is exception { Crabs::take2 1, 2, 3, 4 }, "Too many arguments for fun take2 (expected 2, got 4) at ${\__FILE__} line ${\__LINE__}.\n"; 48 | is exception { Crabs::worng4 }, "Too many arguments for fun take2 (expected 2, got 4) at ${\__FILE__} line ${\($marker + 6)}.\n"; 49 | 50 | is exception { Crabs::takekw "a", "b", "c" }, "Odd number of paired arguments for fun takekw at ${\__FILE__} line ${\__LINE__}.\n"; 51 | is exception { Crabs::worngkw1 }, "Odd number of paired arguments for fun takekw at ${\__FILE__} line ${\($marker + 9)}.\n"; 52 | is exception { Crabs::takekw a => 1 }, "In fun takekw: missing named parameter: zomg at ${\__FILE__} line ${\__LINE__}.\n"; 53 | is exception { Crabs::worngkw2 }, "In fun takekw: missing named parameter: zomg at ${\__FILE__} line ${\($marker + 10)}.\n"; 54 | is exception { Crabs::takekw zomg => 1, a => 2 }, "In fun takekw: no such named parameter: a at ${\__FILE__} line ${\__LINE__}.\n"; 55 | is exception { Crabs::worngkw4 }, "In fun takekw: no such named parameter: a at ${\__FILE__} line ${\($marker + 11)}.\n"; 56 | 57 | is exception { Crabs::taket "X" }, "In fun taket: parameter 1 (\$x): A failure (Cool[Story]) of X at ${\__FILE__} line ${\__LINE__}.\n"; 58 | is exception { Crabs::worngt1 }, "In fun taket: parameter 1 (\$x): A failure (Cool[Story]) of X at ${\__FILE__} line ${\($marker + 14)}.\n"; 59 | -------------------------------------------------------------------------------- /t/defaults_bare.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 13; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters qw(:strict); 9 | 10 | fun foo_1($x = ) { [ $x ] } 11 | fun foo_2($x=) { [ $x ] } 12 | fun foo_3($x =, $y =) { [ $x, $y ] } 13 | fun foo_4($x = 'hi', $y= ) { [ $x, $y ] } 14 | fun foo_5($x= , $y='hi') { [ $x, $y ] } 15 | 16 | is_deeply foo_1(), [ undef ]; 17 | is_deeply foo_1('aa'), [ 'aa' ]; 18 | is_deeply foo_2(), [ undef ]; 19 | is_deeply foo_2('aa'), [ 'aa' ]; 20 | is_deeply foo_3(), [ undef, undef ]; 21 | is_deeply foo_3('aa'), [ 'aa', undef ]; 22 | is_deeply foo_3('aa', 'bb'), [ 'aa', 'bb' ]; 23 | is_deeply foo_4(), [ 'hi', undef ]; 24 | is_deeply foo_4('aa'), [ 'aa', undef ]; 25 | is_deeply foo_4('aa', 'bb'), [ 'aa', 'bb' ]; 26 | is_deeply foo_5(), [ undef, 'hi' ]; 27 | is_deeply foo_5('aa'), [ 'aa', 'hi' ]; 28 | is_deeply foo_5('aa', 'bb'), [ 'aa', 'bb' ]; 29 | -------------------------------------------------------------------------------- /t/defaults_regress.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 3; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters { 9 | fun => { 10 | default_arguments => 1, 11 | }, 12 | }; 13 | 14 | { 15 | my ($d0, $d1, $d2, $d3); 16 | my $default = 'aaa'; 17 | 18 | fun padness($x = $default++) { 19 | return $x; 20 | } 21 | 22 | is padness('unrelated'), 'unrelated'; 23 | is &padness(), 'aaa'; 24 | is padness, 'aab'; 25 | } 26 | -------------------------------------------------------------------------------- /t/eating_strict_error.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use Function::Parameters; 4 | 5 | fun get_record( $agent, $target_name ) { 6 | for my $record ( @$records ) { 7 | } 8 | } 9 | 10 | fun get_ip( $agent ) { 11 | } 12 | 13 | 'ok' 14 | -------------------------------------------------------------------------------- /t/eating_strict_error.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 4; 5 | use FindBin; 6 | 7 | for my $thing (map ["$FindBin::Bin/eating_strict_error$_->[0].fail", @$_[1 .. $#$_]], ['', 6], ['_2', 9]) { 8 | my ($file, $line) = @$thing; 9 | $@ = undef; 10 | my $done = do $file; 11 | my $exc = $@; 12 | my $err = $!; 13 | 14 | is $done, undef, "faulty code doesn't load - $file"; 15 | like $exc, qr{^Global symbol "\$records" requires explicit package name.* at \Q$file\E line \Q$line.\E\n}; 16 | $exc or die "$file: $err"; 17 | } 18 | -------------------------------------------------------------------------------- /t/eating_strict_error_2.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use Function::Parameters; 4 | 5 | fun get_ip( $agent ) { 6 | } 7 | 8 | fun get_record( $agent, $target_name ) { 9 | for my $record ( @$records ) { 10 | } 11 | } 12 | 13 | 'ok' 14 | -------------------------------------------------------------------------------- /t/elsewhere.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | { 6 | package Wrapper; 7 | use Function::Parameters (); 8 | sub shazam { Function::Parameters->import(@_); } 9 | } 10 | 11 | BEGIN { Wrapper::shazam; } 12 | 13 | ok fun ($x) { $x }->(1); 14 | 15 | { 16 | package Cu::Ba; 17 | BEGIN { Wrapper::shazam { gorn => 'function_lax' }; } 18 | 19 | gorn wooden ($gorn) { !$gorn } 20 | } 21 | 22 | ok Cu::Ba::wooden; 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/eval.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings FATAL => 'all'; 4 | use strict; 5 | 6 | use Function::Parameters; 7 | 8 | { 9 | package TX; 10 | 11 | method new($class: :$chk) { bless { @_ }, $class } 12 | 13 | method check($x) { $self->{chk}($x) } 14 | 15 | method get_message($x) { die "get_message($x)"; } 16 | } 17 | 18 | our @trace; 19 | 20 | use Function::Parameters { 21 | def => { 22 | defaults => 'function', 23 | runtime => 1, 24 | shift => [ 25 | [ 26 | '$self' => TX->new(chk => fun ($x) { 27 | push @trace, [self_check => $x]; 28 | 1 29 | }) 30 | ], 31 | ], 32 | install_sub => fun ($name, $body) { 33 | $name = caller . "::$name" unless $name =~ /::/; 34 | push @trace, [install => $name]; 35 | my $sym = do { no strict 'refs'; \*$name }; 36 | *$sym = $body; 37 | }, 38 | } 39 | }; 40 | 41 | package Groovy; 42 | use constant OtherType => TX->new( 43 | chk => fun ($x) { 44 | push @trace, [other_check => $x]; 45 | 1 46 | }, 47 | ); 48 | 49 | use Test::More tests => 5; 50 | 51 | is_deeply [ splice @trace ], []; 52 | 53 | def foo(OtherType $x) { push @trace, [foo => $self, $x]; } 54 | 55 | is_deeply [ splice @trace ], [ 56 | [install => 'Groovy::foo'], 57 | ]; 58 | 59 | is eval q{ 60 | def bar(OtherType $x) { push @trace, [bar => $self, $x]; } 61 | 42 62 | }, 42; 63 | 64 | is_deeply [ splice @trace ], [ 65 | [install => 'Groovy::bar'], 66 | ]; 67 | 68 | foo('A1', 'A2'); 69 | bar('B1', 'B2'); 70 | is_deeply [ splice @trace ], [ 71 | [self_check => 'A1'], 72 | [other_check => 'A2'], 73 | [foo => qw(A1 A2)], 74 | [self_check => 'B1'], 75 | [other_check => 'B2'], 76 | [bar => qw(B1 B2)], 77 | ]; 78 | -------------------------------------------------------------------------------- /t/gorn.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More tests => 4; 6 | 7 | use Function::Parameters; 8 | 9 | is eval 'fun {}', undef; 10 | like $@, qr/\A\QIn fun (anon): I was expecting a parameter list, not "{"/; 11 | 12 | is eval 'fun () :() {}', undef; 13 | like $@, qr/\A\QIn fun (anon): I was expecting a function body, not "("/; 14 | -------------------------------------------------------------------------------- /t/imports.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More tests => 58; 7 | use Test::Fatal; 8 | 9 | { 10 | use Function::Parameters {}; # ZERO BABIES 11 | 12 | is eval('fun foo :() {}; 1'), undef; 13 | like $@, qr/syntax error/; 14 | } 15 | 16 | { 17 | use Function::Parameters { pound => 'function' }; 18 | 19 | is eval('fun foo :() {}; 1'), undef; 20 | like $@, qr/syntax error/; 21 | 22 | pound foo_1($x) { $x } 23 | is foo_1(2 + 2), 4; 24 | 25 | like exception { foo_1(5, 6) }, qr/Too many arguments/; 26 | 27 | no Function::Parameters qw(pound); 28 | 29 | is eval('pound foo() {}; 1'), undef; 30 | like $@, qr/syntax error/; 31 | } 32 | 33 | { 34 | use Function::Parameters { pound => 'method' }; 35 | 36 | is eval('fun foo () {}; 1'), undef; 37 | like $@, qr/syntax error/; 38 | 39 | pound foo_2() { $self } 40 | is foo_2(2 + 2), 4; 41 | 42 | like exception { foo_2(5, 6) }, qr/Too many arguments/; 43 | 44 | no Function::Parameters qw(pound); 45 | 46 | is eval('pound unfoo :() {}; 1'), undef; 47 | like $@, qr/syntax error/; 48 | } 49 | 50 | { 51 | is eval('pound unfoo( ){}; 1'), undef; 52 | like $@, qr/syntax error/; 53 | 54 | use Function::Parameters { pound => 'classmethod' }; 55 | 56 | is eval('fun foo () {}; 1'), undef; 57 | like $@, qr/syntax error/; 58 | 59 | pound foo_3() { $class } 60 | is foo_3(2 + 2), 4; 61 | 62 | like exception { foo_3(5, 6) }, qr/Too many arguments/; 63 | 64 | no Function::Parameters; 65 | 66 | is eval('pound unfoo :lvalue{}; 1'), undef; 67 | like $@, qr/syntax error/; 68 | } 69 | 70 | { 71 | use Function::Parameters { pound => 'function_strict' }; 72 | 73 | is eval('fun foo :() {}; 1'), undef; 74 | like $@, qr/syntax error/; 75 | 76 | pound foo_4($x) { $x } 77 | is foo_4(2 + 2), 4; 78 | 79 | like exception { foo_4(5, 6) }, qr/Too many arguments/; 80 | 81 | no Function::Parameters qw(pound); 82 | 83 | is eval('pound foo() {}; 1'), undef; 84 | like $@, qr/syntax error/; 85 | } 86 | 87 | { 88 | use Function::Parameters { pound => 'method_strict' }; 89 | 90 | is eval('fun foo () {}; 1'), undef; 91 | like $@, qr/syntax error/; 92 | 93 | pound foo_5() { $self } 94 | is foo_5(2 + 2), 4; 95 | 96 | like exception { foo_5(5, 6) }, qr/Too many arguments/; 97 | 98 | no Function::Parameters qw(pound); 99 | 100 | is eval('pound unfoo :() {}; 1'), undef; 101 | like $@, qr/syntax error/; 102 | } 103 | 104 | { 105 | is eval('pound unfoo( ){}; 1'), undef; 106 | like $@, qr/syntax error/; 107 | 108 | use Function::Parameters { pound => 'classmethod_strict' }; 109 | 110 | is eval('fun foo () {}; 1'), undef; 111 | like $@, qr/syntax error/; 112 | 113 | pound foo_6() { $class } 114 | is foo_6(2 + 2), 4; 115 | 116 | like exception { foo_6(5, 6) }, qr/Too many arguments/; 117 | 118 | no Function::Parameters; 119 | 120 | is eval('pound unfoo :lvalue{}; 1'), undef; 121 | like $@, qr/syntax error/; 122 | } 123 | 124 | { 125 | use Function::Parameters qw(method); 126 | 127 | is method () { $self + 2 }->(2), 4; 128 | is eval('fun () {}'), undef; 129 | like $@, qr/syntax error/; 130 | } 131 | 132 | { 133 | use Function::Parameters qw(method fun); 134 | 135 | is method () { $self + 2 }->(2), 4; 136 | is fun ($x) { $x + 2 }->(2), 4; 137 | } 138 | 139 | { 140 | use Function::Parameters qw(:std), { def => 'function' }; 141 | 142 | is method () { $self + 2 }->(2), 4; 143 | is fun ($x) { $x + 2 }->(2), 4; 144 | is def ($x) { $x + 2 }->(2), 4; 145 | } 146 | 147 | like exception { Function::Parameters->import(":QQQQ") }, qr/not exported/; 148 | 149 | like exception { Function::Parameters->import({":QQQQ" => "function"}) }, qr/valid identifier/; 150 | 151 | like exception { Function::Parameters->import({"jetsam" => "QQQQ"}) }, qr/valid type/; 152 | 153 | like exception { Function::Parameters->import("asdf") }, qr/not exported/; 154 | 155 | for my $kw ('', '42', 'A::B', 'a b') { 156 | like exception { Function::Parameters->import({ $kw => 'function' }) }, qr/valid identifier /; 157 | } 158 | -------------------------------------------------------------------------------- /t/install.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More tests => 22; 6 | 7 | use constant MODIFIERS => qw( 8 | before after around augment override 9 | ); 10 | 11 | use Function::Parameters qw(:modifiers :std), { 12 | map +("${_}_c" => { defaults => $_, runtime => 0 }), MODIFIERS 13 | }; 14 | 15 | is eval 'before () {}', undef; 16 | like $@, qr/\bexpecting a function name\b/; 17 | 18 | my $test_pkg; 19 | { 20 | package NotMain; 21 | BEGIN { $test_pkg = __PACKAGE__; } 22 | 23 | my $TRACE; 24 | fun TRACE($str) { 25 | $TRACE .= " $str"; 26 | } 27 | fun getT() { 28 | my $r = $TRACE; 29 | $TRACE = ''; 30 | $r 31 | } 32 | 33 | BEGIN { 34 | for my $m (::MODIFIERS) { 35 | my $sym = do { no strict 'refs'; \*$m }; 36 | *$sym = fun ($name, $body) { 37 | TRACE "$m($name)"; 38 | $body->('A', 'B', 'C'); 39 | }; 40 | } 41 | } 42 | 43 | BEGIN { ::is getT, undef; } 44 | ::is getT, ''; 45 | 46 | around_c k_1($x) { 47 | TRACE "k_1($orig, $self, $x | @_)"; 48 | } 49 | around k_2($x) { 50 | TRACE "k_2($orig, $self, $x | @_)"; 51 | } 52 | BEGIN { ::is getT, ' around(k_1) k_1(A, B, C | C)'; } 53 | ::is getT, ' around(k_2) k_2(A, B, C | C)'; 54 | 55 | before_c k_3($x, $y) { 56 | TRACE "k_3($self, $x, $y | @_)"; 57 | } 58 | before k_4($x, $y) { 59 | TRACE "k_4($self, $x, $y | @_)"; 60 | } 61 | BEGIN { ::is getT, ' before(k_3) k_3(A, B, C | B C)'; } 62 | ::is getT, ' before(k_4) k_4(A, B, C | B C)'; 63 | 64 | after_c k_5($x, $y) { 65 | TRACE "k_5($self, $x, $y | @_)"; 66 | } 67 | after k_6($x, $y) { 68 | TRACE "k_6($self, $x, $y | @_)"; 69 | } 70 | BEGIN { ::is getT, ' after(k_5) k_5(A, B, C | B C)'; } 71 | ::is getT, ' after(k_6) k_6(A, B, C | B C)'; 72 | } 73 | 74 | BEGIN { 75 | for my $i (1 .. 6) { 76 | my $m = "k_$i"; 77 | is $test_pkg->can($m), undef, "$test_pkg->can($m) is undef at compile time"; 78 | } 79 | } 80 | for my $i (1 .. 6) { 81 | my $m = "k_$i"; 82 | is $test_pkg->can($m), undef, "$test_pkg->can($m) is undef at runtime"; 83 | } 84 | -------------------------------------------------------------------------------- /t/invocant.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More tests => 67; 7 | use Test::Fatal; 8 | 9 | use Function::Parameters; 10 | 11 | { 12 | package Foo; 13 | 14 | method new($class : ) { 15 | return bless { 16 | x => 1, 17 | y => 2, 18 | z => 3, 19 | }, $class; 20 | } 21 | 22 | method get_x() { $self->{x} } 23 | method get_y($self:) { $self->{y} } 24 | method get_z($this:) { $this->{z} } 25 | 26 | method set_x($val) { $self->{x} = $val; } 27 | method set_y($self:$val) { $self->{y} = $val; } 28 | method set_z($this: $val) { $this->{z} = $val; } 29 | } 30 | 31 | my $o = Foo->new; 32 | ok $o->isa('Foo'), "Foo->new->isa('Foo')"; 33 | 34 | is $o->get_x, 1; 35 | is $o->get_y, 2; 36 | is $o->get_z, 3; 37 | 38 | $o->set_x("A"); 39 | $o->set_y("B"); 40 | $o->set_z("C"); 41 | 42 | is $o->get_x, "A"; 43 | is $o->get_y, "B"; 44 | is $o->get_z, "C"; 45 | 46 | is method ($x = $self) { "$self $x [@_]" }->('A'), 'A A []'; 47 | 48 | is eval { $o->get_z(42) }, undef; 49 | like $@, qr/Too many arguments/; 50 | 51 | is eval { $o->set_z }, undef; 52 | like $@, qr/Too few arguments/; 53 | 54 | is eval q{fun ($self:) {}}, undef; 55 | like $@, qr/invocant \$self not allowed here/; 56 | 57 | is eval q{fun ($x : $y) {}}, undef; 58 | like $@, qr/invocant \$x not allowed here/; 59 | 60 | is eval q{method (@x:) {}}, undef; 61 | like $@, qr/invocant \@x can't be an array/; 62 | 63 | is eval q{method (%x:) {}}, undef; 64 | like $@, qr/invocant %x can't be a hash/; 65 | 66 | is eval q{method ($x, $y:) {}}, undef; 67 | like $@, qr/\Qnumber of invocants in parameter list (2) differs from number of invocants in keyword definition (1)/; 68 | 69 | { 70 | use Function::Parameters { 71 | def => { 72 | invocant => 1, 73 | strict => 0, 74 | } 75 | }; 76 | 77 | def foo1($x) { join ' ', $x, @_ } 78 | def foo2($x: $y) { join ' ', $x, $y, @_ } 79 | def foo3($x, $y) { join ' ', $x, $y, @_ } 80 | 81 | is foo1("a"), "a a"; 82 | is foo2("a", "b"), "a b b"; 83 | is foo3("a", "b"), "a b a b"; 84 | is foo1("a", "b"), "a a b"; 85 | is foo2("a", "b", "c"), "a b b c"; 86 | is foo3("a", "b", "c"), "a b a b c"; 87 | } 88 | 89 | use Function::Parameters { 90 | method2 => { 91 | defaults => 'method', 92 | shift => ['$self1', '$self2' ], 93 | }, 94 | }; 95 | 96 | method2 m2_a($x) { "$self1 $self2 $x [@_]" } 97 | is m2_a('a', 'b', 'c'), 'a b c [c]'; 98 | for my $info (Function::Parameters::info(\&m2_a)) { 99 | my @inv = $info->invocants; 100 | is_deeply \@inv, [qw($self1 $self2)]; 101 | is_deeply [map $_->name, @inv], [qw($self1 $self2)]; 102 | is_deeply [map $_->type, @inv], [undef, undef]; 103 | is $info->args_min, 3; 104 | is $info->args_max, 3; 105 | like exception { $info->invocant }, qr/single invocant/; 106 | } 107 | 108 | method2 m2_b($x = $self2, $y = $self1) { "$self1 $self2 $x $y [@_]" } 109 | like exception { m2_b('a', 'b', 'c', 'd', 'e') }, qr/^\QToo many arguments for method2 m2_b (expected 4, got 5)/; 110 | is m2_b('a', 'b', 'c', 'd'), 'a b c d [c d]'; 111 | is m2_b('a', 'b', 'c'), 'a b c a [c]'; 112 | is m2_b('a', 'b'), 'a b b a []'; 113 | like exception { m2_b('a') }, qr/^\QToo few arguments for method2 m2_b (expected 2, got 1)/; 114 | for my $info (Function::Parameters::info(\&m2_b)) { 115 | my @inv = $info->invocants; 116 | is_deeply \@inv, [qw($self1 $self2)]; 117 | is_deeply [map $_->name, @inv], [qw($self1 $self2)]; 118 | is_deeply [map $_->type, @inv], [undef, undef]; 119 | is $info->args_min, 2; 120 | is $info->args_max, 4; 121 | like exception { $info->invocant }, qr/single invocant/; 122 | } 123 | 124 | method2 m2_c($t1, $t2:) { "$t1 $t2 [@_]" } 125 | like exception { m2_c('a', 'b', 'c') }, qr/^\QToo many arguments for method2 m2_c (expected 2, got 3)/; 126 | is m2_c('a', 'b'), 'a b []'; 127 | like exception { m2_c('a') }, qr/^\QToo few arguments for method2 m2_c (expected 2, got 1)/; 128 | for my $info (Function::Parameters::info(\&m2_c)) { 129 | my @inv = $info->invocants; 130 | is_deeply \@inv, [qw($t1 $t2)]; 131 | is_deeply [map $_->name, @inv], [qw($t1 $t2)]; 132 | is_deeply [map $_->type, @inv], [undef, undef]; 133 | is $info->args_min, 2; 134 | is $info->args_max, 2; 135 | like exception { $info->invocant }, qr/single invocant/; 136 | } 137 | 138 | is eval('method2 ($t1, $t2:) { $self1 }'), undef; 139 | like $@, qr/^Global symbol "\$self1" requires explicit package name/; 140 | 141 | is eval('method2 ($self1) {}'), undef; 142 | like $@, qr/\$self1 can't appear twice in the same parameter list/; 143 | 144 | is eval('method2 ($x, $self2) {}'), undef; 145 | like $@, qr/\$self2 can't appear twice in the same parameter list/; 146 | 147 | is eval('method2 m2_z($self: $x) {} 1'), undef; 148 | like $@, qr/^\QIn method2 m2_z: number of invocants in parameter list (1) differs from number of invocants in keyword definition (2)/; 149 | ok !exists &m2_z; 150 | 151 | is eval('method2 m2_z($orig, $self, $x: $y) {} 1'), undef; 152 | like $@, qr/^\QIn method2 m2_z: number of invocants in parameter list (3) differs from number of invocants in keyword definition (2)/; 153 | ok !exists &m2_z; 154 | -------------------------------------------------------------------------------- /t/lexical.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 16; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | sub Burlap::fun (&) { $_[0]->() } 9 | 10 | { 11 | use Function::Parameters; 12 | 13 | is fun () { 2 + 2 }->(), 4; 14 | 15 | package Burlap; 16 | 17 | ::ok fun () { 0 }; 18 | } 19 | 20 | { 21 | package Burlap; 22 | 23 | ::is fun { 'singing' }, 'singing'; 24 | } 25 | 26 | { 27 | sub proc (&) { &Burlap::fun } 28 | 29 | use Function::Parameters { proc => 'function' }; 30 | 31 | proc add($x, $y) { 32 | return $x + $y; 33 | } 34 | 35 | is add(@{[2, 3]}), 5; 36 | 37 | { 38 | use Function::Parameters; 39 | 40 | is proc () { 'bla' }->(), 'bla'; 41 | is method () { $self }->('der'), 'der'; 42 | 43 | { 44 | no Function::Parameters; 45 | 46 | is proc { 'unk' }, 'unk'; 47 | 48 | is eval('fun foo($x) { $x; } 1'), undef; 49 | like $@, qr/syntax error/; 50 | } 51 | 52 | is proc () { 'bla' }->(), 'bla'; 53 | is method () { $self }->('der'), 'der'; 54 | 55 | no Function::Parameters 'proc'; 56 | is proc { 'unk2' }, 'unk2'; 57 | is method () { $self }->('der2'), 'der2'; 58 | } 59 | is proc () { 'bla3' }->(), 'bla3'; 60 | is eval('fun foo($x) { $x; } 1'), undef; 61 | like $@, qr/syntax error/; 62 | } 63 | -------------------------------------------------------------------------------- /t/lifetime.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | 4 | use Test::More tests => 12; 5 | 6 | use Function::Parameters { 7 | fun_cx => { defaults => 'function', install_sub => 'jamitin' }, 8 | fun_rx => { defaults => 'function', install_sub => 'jamitin', runtime => 1 }, 9 | }; 10 | 11 | use Hash::Util qw(fieldhash); 12 | 13 | my %watcher; 14 | BEGIN { fieldhash %watcher; } 15 | 16 | my $calls; 17 | BEGIN { $calls = 0; } 18 | 19 | sub jamitin { 20 | my ($name, $body) = @_; 21 | $watcher{$body} = $name; 22 | $calls++; 23 | } 24 | 25 | my $forceclosure; 26 | 27 | BEGIN { 28 | is $calls, 0; 29 | is_deeply \%watcher, {}; 30 | } 31 | 32 | BEGIN { 33 | jamitin 'via_sub_cx', sub { $forceclosure }; 34 | } 35 | 36 | BEGIN { 37 | is $calls, 1; 38 | is_deeply \%watcher, {}; 39 | } 40 | 41 | fun_cx via_fun_cx(@) { $forceclosure } 42 | 43 | BEGIN { 44 | is $calls, 2; 45 | is_deeply \%watcher, {}; 46 | } 47 | 48 | BEGIN { 49 | $calls = 0; 50 | } 51 | 52 | 53 | is $calls, 0; 54 | is_deeply \%watcher, {}; 55 | 56 | jamitin 'via_sub_rx', sub { $forceclosure }; 57 | 58 | is $calls, 1; 59 | is_deeply \%watcher, {}; 60 | 61 | fun_rx via_fun_rx(@) { $forceclosure } 62 | 63 | is $calls, 2; 64 | TODO: { 65 | local $TODO = 'bug/leak: runtime-installed subs are kept alive somehow'; 66 | is_deeply \%watcher, {}; 67 | } 68 | -------------------------------------------------------------------------------- /t/lineno.t: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use strict; 3 | 4 | use Test::More tests => 11; 5 | 6 | use Function::Parameters; 7 | 8 | fun actual_location_of_line_with($marker) { 9 | seek DATA, 0, 0 or die "seek DATA: $!"; 10 | my $loc = 0; 11 | while (my $line = readline DATA) { 12 | $loc++; 13 | index($line, $marker) >= 0 14 | and return $loc; 15 | } 16 | undef 17 | } 18 | 19 | fun test_loc($marker) { 20 | my $expected = actual_location_of_line_with $marker; 21 | defined $expected or die "$marker: something done fucked up"; 22 | my $got = (caller)[2]; 23 | is $got, $expected, "location of '$marker'"; 24 | } 25 | 26 | fun () { 27 | test_loc 'LX simple'; 28 | }->(); 29 | 30 | test_loc 'LX -- 1'; 31 | 32 | fun 33 | ( 34 | ) 35 | { 36 | test_loc 'LX creative formatting'; } 37 | -> 38 | ( 39 | ); 40 | 41 | test_loc 'LX -- 2'; 42 | 43 | fun () { 44 | fun () { 45 | test_loc 'LX nested'; 46 | }->() 47 | }->(); 48 | 49 | test_loc 'LX -- 3'; 50 | 51 | { 52 | #local $TODO = 'expressions break line numbers???'; 53 | 54 | 0 55 | , fun () { 56 | test_loc 'LX assign'; 57 | }->() 58 | ; 59 | 60 | test_loc 'LX -- 4'; 61 | } 62 | 63 | { 64 | #local $TODO = 'newlines in prototype/attributes'; 65 | 66 | fun wtf() :prototype( 67 | 68 | ) 69 | : 70 | { test_loc 'LX -- 5 (inner)' } 71 | 72 | test_loc 'LX -- 5 (bonus)'; 73 | wtf; 74 | test_loc 'LX -- 5 (outer)'; 75 | } 76 | 77 | __DATA__ 78 | -------------------------------------------------------------------------------- /t/method_cache.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | no warnings qw(once redefine); 4 | use strict; 5 | 6 | use Test::More tests => 2; 7 | 8 | use Function::Parameters { 9 | method => { defaults => 'method_strict', runtime => 1 }, 10 | }; 11 | 12 | # See commit 978a498e17ec54b6f1fc65f3375a62a68f321f99 in perl: 13 | # http://perl5.git.perl.org/perl.git/commitdiff/978a498e17ec5 14 | 15 | method Y::b() { 'b' } 16 | *X::b = *Y::b; 17 | @Z::ISA = 'X'; 18 | is +Z->b, 'b'; 19 | 20 | method Y::b() { 'c' } 21 | is +Z->b, 'c'; 22 | -------------------------------------------------------------------------------- /t/method_runtime.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More tests => 29; 6 | 7 | use Function::Parameters { 8 | fun => 'function_strict', 9 | method => { defaults => 'method_strict', runtime => 1 }, 10 | }; 11 | 12 | { 13 | package Foo; 14 | 15 | ::ok !defined &f1; 16 | method f1() {} 17 | ::ok defined &f1; 18 | 19 | ::ok !defined &f2; 20 | ::ok !defined &Bar::f2; 21 | method Bar::f2() {} 22 | ::ok !defined &f2; 23 | ::ok defined &Bar::f2; 24 | 25 | ::ok !defined &f3; 26 | if (@ARGV < 0) { method f3() {} } 27 | ::ok !defined &f3; 28 | } 29 | 30 | fun g1() { (caller 0)[3] } 31 | method g2() { (caller 0)[3] } 32 | fun Bar::g1() { (caller 0)[3] } 33 | method Bar::g2() { (caller 0)[3] } 34 | 35 | is g1, 'main::g1'; 36 | is 'main'->g2, 'main::g2'; 37 | is Bar::g1, 'Bar::g1'; 38 | is 'Bar'->g2, 'Bar::g2'; 39 | 40 | use Function::Parameters { fun_r => { defaults => 'function_strict', runtime => 1 } }; 41 | 42 | { 43 | package Foo_r; 44 | 45 | ::ok !defined &f1; 46 | fun_r f1() {} 47 | ::ok defined &f1; 48 | 49 | ::ok !defined &f2; 50 | ::ok !defined &Bar_r::f2; 51 | fun_r Bar_r::f2() {} 52 | ::ok !defined &f2; 53 | ::ok defined &Bar_r::f2; 54 | 55 | ::ok !defined &f3; 56 | if (@ARGV < 0) { fun_r f3() {} } 57 | ::ok !defined &f3; 58 | } 59 | 60 | fun h1() { (caller 0)[3] } 61 | fun_r h2() { (caller 0)[3] } 62 | fun Bar::h1() { (caller 0)[3] } 63 | fun_r Bar::h2() { (caller 0)[3] } 64 | 65 | is h1, 'main::h1'; 66 | is h2(), 'main::h2'; 67 | is Bar::h1, 'Bar::h1'; 68 | is Bar::h2(), 'Bar::h2'; 69 | 70 | fun_r p1($x, $y) :prototype($$) {} 71 | is prototype(\&p1), '$$'; 72 | is prototype('p1'), '$$'; 73 | is prototype('main::p1'), '$$'; 74 | 75 | fun_r Bar::p2($x, $y = 0) :prototype($;$) {} 76 | is prototype(\&Bar::p2), '$;$'; 77 | is prototype('Bar::p2'), '$;$'; 78 | -------------------------------------------------------------------------------- /t/name.t: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use strict; 3 | 4 | use Test::More tests => 12; 5 | 6 | use FindBin; 7 | 8 | use Function::Parameters { 9 | func => { 10 | name => 'required', 11 | }, 12 | 13 | f => { 14 | name => 'prohibited', 15 | }, 16 | 17 | method => { 18 | name => 'required', 19 | shift => '$this', 20 | }, 21 | }; 22 | 23 | func foo($x, $y, $z) { 24 | $x .= $z; 25 | return $y . $x . $y; 26 | } 27 | 28 | method bar($k, $d) { 29 | $d = $k . $d; 30 | return $d . $this->{$k} . $d; 31 | } 32 | 33 | is foo('a', 'b', 'c'), 'bacb'; 34 | is bar({ab => 'cd'}, 'ab', 'e'), 'abecdabe'; 35 | 36 | my $baz = f ($x) { $x * 2 + 1 }; 37 | is $baz->(11), 23; 38 | is $baz->(-0.5), 0; 39 | 40 | for my $fail ( 41 | map ["$FindBin::Bin/name_$_->[0].fail", @$_[1 .. $#$_]], 42 | ['1', qr/expect.*function.*name/], 43 | ['2', qr/expect.*parameter.*list/], 44 | ['3', qr/expect.*function.*name/], 45 | ['4', qr/Global symbol "\$self" requires explicit package name/] 46 | ) { 47 | my ($file, $pat) = @$fail; 48 | my $done = do $file; 49 | my $exc = $@; 50 | my $err = $!; 51 | 52 | is $done, undef, "faulty code doesn't load - $file"; 53 | $exc or die "$file: $err"; 54 | like $exc, $pat; 55 | } 56 | -------------------------------------------------------------------------------- /t/name_1.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters { 6 | func => { 7 | name => 'required', 8 | }, 9 | 10 | f => { 11 | name => 'prohibited', 12 | }, 13 | 14 | method => { 15 | name => 'required', 16 | shift => '$this', 17 | }, 18 | }; 19 | 20 | my $bad = func () { 1 }; 21 | -------------------------------------------------------------------------------- /t/name_2.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters { 6 | func => { 7 | name => 'required', 8 | }, 9 | 10 | f => { 11 | name => 'prohibited', 12 | }, 13 | 14 | method => { 15 | name => 'required', 16 | shift => '$this', 17 | }, 18 | }; 19 | 20 | f bad() { 21 | } 22 | -------------------------------------------------------------------------------- /t/name_3.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters { 6 | func => { 7 | name => 'required', 8 | }, 9 | 10 | f => { 11 | name => 'prohibited', 12 | }, 13 | 14 | method => { 15 | name => 'required', 16 | shift => '$this', 17 | }, 18 | }; 19 | 20 | my $bad = method () { $this }; 21 | -------------------------------------------------------------------------------- /t/name_4.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters { 6 | func => { 7 | name => 'required', 8 | }, 9 | 10 | f => { 11 | name => 'prohibited', 12 | }, 13 | 14 | method => { 15 | name => 'required', 16 | shift => '$this', 17 | }, 18 | }; 19 | 20 | method bad2() { 21 | my $what = $self; 22 | } 23 | -------------------------------------------------------------------------------- /t/precedence.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 11; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters; 9 | 10 | fun four() { 2 + 2 } fun five() { 1 + four } 11 | 12 | fun quantum(@) :prototype() {; 0xf00d 13 | } 14 | 15 | is four, 4, "basic sanity 1"; 16 | is five, 5, "basic sanity 2"; 17 | is quantum, 0xf00d, "basic sanity 3"; 18 | is quantum / 2 #/ 19 | , 0xf00d / 2, "basic sanity 4 - () proto"; 20 | 21 | is eval('my $x = fun forbidden() {}'), undef, "statements aren't expressions"; 22 | like $@, qr/expect.*parameter list/; 23 | 24 | is eval('my $x = { fun forbidden() {} }'), undef, "statements aren't expressions 2 - electric boogaloo"; 25 | like $@, qr/expect.*parameter list/; 26 | 27 | is fun () { join '.', five, four }->(), '5.4', "can immedicall anon subs"; 28 | 29 | is 0 * fun () {} + 42, 42, "* binds tighter than +"; 30 | is 0 * fun () { quantum / q#/ } 31 | # } + 42, 42, "* binds tighter than + 2 - electric boogaloo"; 32 | -------------------------------------------------------------------------------- /t/prototype.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use Test::More tests => 73; 3 | 4 | use warnings FATAL => 'all'; 5 | use strict; 6 | 7 | use Function::Parameters; 8 | 9 | is eval 'fun () :prototype([) {}', undef; 10 | like $@, qr/Illegal character in prototype/; 11 | 12 | is eval 'fun () :prototype(][[[[[[) {}', undef; 13 | like $@, qr/Illegal character in prototype/; 14 | 15 | is eval 'fun () :prototype(\;) {}', undef; 16 | like $@, qr/Illegal character after '\\' in prototype/; 17 | 18 | is eval 'fun () :prototype(\[_;@]) {}', undef; 19 | like $@, qr/Illegal character after '\\' in prototype/; 20 | 21 | is eval 'fun () :prototype(\+) {}', undef; 22 | like $@, qr/Illegal character after '\\' in prototype/; 23 | 24 | is eval 'fun () :prototype(\\\\) {}', undef; 25 | like $@, qr/Illegal character after '\\' in prototype/; 26 | 27 | is eval 'fun () :prototype([$]) {}', undef; 28 | like $@, qr/Illegal character in prototype/; 29 | 30 | is eval 'fun () :prototype(\[_$]) {}', undef; 31 | like $@, qr/Illegal character after '\\' in prototype/; 32 | 33 | is eval 'fun () :prototype(__) {}', undef; 34 | like $@, qr/Illegal character after '_' in prototype/; 35 | 36 | is eval 'fun () :prototype(_$) {}', undef; 37 | like $@, qr/Illegal character after '_' in prototype/; 38 | 39 | is eval 'fun () :prototype(_\@) {}', undef; 40 | like $@, qr/Illegal character after '_' in prototype/; 41 | 42 | { 43 | no warnings qw(illegalproto); 44 | 45 | ok eval 'fun () :prototype([) {}'; 46 | ok eval 'fun () :prototype(][[[[[[) {}'; 47 | ok eval 'fun () :prototype(\;) {}'; 48 | ok eval 'fun () :prototype(\[_;@]) {}'; 49 | ok eval 'fun () :prototype(\+) {}'; 50 | ok eval 'fun () :prototype(\\\\) {}'; 51 | ok eval 'fun () :prototype([$]) {}'; 52 | ok eval 'fun () :prototype(\[_$]) {}'; 53 | ok eval 'fun () :prototype(__) {}'; 54 | ok eval 'fun () :prototype(_$) {}'; 55 | ok eval 'fun () :prototype(_\@) {}'; 56 | } 57 | 58 | is eval 'fun () :prototype([) {}', undef; 59 | like $@, qr/Illegal character in prototype/; 60 | 61 | is eval 'fun () :prototype(][[[[[[) {}', undef; 62 | like $@, qr/Illegal character in prototype/; 63 | 64 | is eval 'fun () :prototype(\;) {}', undef; 65 | like $@, qr/Illegal character after '\\' in prototype/; 66 | 67 | is eval 'fun () :prototype(\[_;@]) {}', undef; 68 | like $@, qr/Illegal character after '\\' in prototype/; 69 | 70 | is eval 'fun () :prototype(\+) {}', undef; 71 | like $@, qr/Illegal character after '\\' in prototype/; 72 | 73 | is eval 'fun () :prototype(\\\\) {}', undef; 74 | like $@, qr/Illegal character after '\\' in prototype/; 75 | 76 | is eval 'fun () :prototype([$]) {}', undef; 77 | like $@, qr/Illegal character in prototype/; 78 | 79 | is eval 'fun () :prototype(\[_$]) {}', undef; 80 | like $@, qr/Illegal character after '\\' in prototype/; 81 | 82 | is eval 'fun () :prototype(__) {}', undef; 83 | like $@, qr/Illegal character after '_' in prototype/; 84 | 85 | is eval 'fun () :prototype(_$) {}', undef; 86 | like $@, qr/Illegal character after '_' in prototype/; 87 | 88 | is eval 'fun () :prototype(_\@) {}', undef; 89 | like $@, qr/Illegal character after '_' in prototype/; 90 | 91 | { 92 | no warnings qw(illegalproto); 93 | 94 | ok eval 'fun () :prototype([) {}'; 95 | ok eval 'fun () :prototype(][[[[[[) {}'; 96 | ok eval 'fun () :prototype(\;) {}'; 97 | ok eval 'fun () :prototype(\[_;@]) {}'; 98 | ok eval 'fun () :prototype(\+) {}'; 99 | ok eval 'fun () :prototype(\\\\) {}'; 100 | ok eval 'fun () :prototype([$]) {}'; 101 | ok eval 'fun () :prototype(\[_$]) {}'; 102 | ok eval 'fun () :prototype(__) {}'; 103 | ok eval 'fun () :prototype(_$) {}'; 104 | ok eval 'fun () :prototype(_\@) {}'; 105 | } 106 | 107 | is eval 'fun () :prototype($) prototype(@) {}', undef; 108 | like $@, qr/Can't redefine prototype/; 109 | 110 | 111 | ok eval 'fun () :prototype(_) {}'; 112 | ok eval 'fun () :prototype(_;) {}'; 113 | ok eval 'fun () :prototype(_;$) {}'; 114 | ok eval 'fun () :prototype(_@) {}'; 115 | ok eval 'fun () :prototype(_%) {}'; 116 | -------------------------------------------------------------------------------- /t/recursion.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More tests => 26; 6 | 7 | use Function::Parameters qw(:strict); 8 | 9 | fun foo_r($depth, $fst, $snd) { 10 | return [$fst, $snd, $snd - $fst] if $depth <= 0; 11 | $fst++; 12 | my $thd = foo_r $depth - 1, $fst + $snd, $fst * $snd; 13 | $snd++; 14 | return [$fst, $snd, $thd]; 15 | } 16 | 17 | fun foo_o($depth, $fst = 1, $snd = 2) { 18 | return [$fst, $snd, $snd - $fst] if $depth <= 0; 19 | $fst++; 20 | my $thd = foo_o $depth - 1, $fst + $snd, $fst * $snd; 21 | $snd++; 22 | return [$fst, $snd, $thd]; 23 | } 24 | 25 | fun foo_nr(:$depth, :$fst, :$snd) { 26 | return [$fst, $snd, $snd - $fst] if $depth <= 0; 27 | $fst++; 28 | my $thd = foo_nr snd => $fst * $snd, depth => $depth - 1, fst => $fst + $snd; 29 | $snd++; 30 | return [$fst, $snd, $thd]; 31 | } 32 | 33 | fun foo_no(:$depth, :$fst = 1, :$snd = 2) { 34 | return [$fst, $snd, $snd - $fst] if $depth <= 0; 35 | $fst++; 36 | my $thd = foo_no snd => $fst * $snd, depth => $depth - 1, fst => $fst + $snd; 37 | $snd++; 38 | return [$fst, $snd, $thd]; 39 | } 40 | 41 | for my $f ( 42 | \&foo_r, \&foo_o, 43 | map { my $f = $_; fun ($d, $x, $y) { $f->(depth => $d, snd => $y, fst => $x) } } 44 | \&foo_nr, \&foo_no 45 | ) { 46 | is_deeply $f->(0, 3, 5), [3, 5, 2]; 47 | is_deeply $f->(1, 3, 5), [4, 6, [9, 20, 11]]; 48 | is_deeply $f->(2, 3, 5), [4, 6, [10, 21, [30, 200, 170]]]; 49 | } 50 | 51 | fun slurpy(:$n, %rest) { [$n, \%rest] } 52 | 53 | { 54 | is_deeply slurpy(a => 1, b => 2, n => 9), [9, {a => 1, b => 2}]; 55 | my $sav1 = slurpy(n => 5); 56 | is_deeply $sav1, [5, {}]; 57 | my $sav2 = slurpy(n => 6, a => 3); 58 | is_deeply $sav2, [6, {a => 3}]; 59 | is_deeply $sav1, [5, {}]; 60 | is_deeply slurpy(b => 4, n => 7, hello => "world"), [7, {hello => "world", b => 4}]; 61 | is_deeply $sav1, [5, {}]; 62 | is_deeply $sav2, [6, {a => 3}]; 63 | } 64 | 65 | { 66 | { 67 | package TimelyDestruction; 68 | 69 | method new($class: $f) { 70 | bless {on_destroy => $f}, $class 71 | } 72 | 73 | method DESTROY() { 74 | $self->{on_destroy}(); 75 | } 76 | } 77 | 78 | use Function::Parameters qw(:lax); 79 | 80 | fun bar(:$n) { defined $n ? $n + 1 : "nope" } 81 | 82 | is bar(n => undef), "nope"; 83 | is bar(n => 2), 3; 84 | is bar, "nope"; 85 | 86 | my $dead = 0; 87 | { 88 | my $o = TimelyDestruction->new(fun () { $dead++ }); 89 | is bar(n => $o), $o + 1, "this juice is bangin yo"; 90 | } 91 | is $dead, 1; 92 | $dead = 999; 93 | is bar(n => 3), 4; 94 | is $dead, 999; 95 | } 96 | -------------------------------------------------------------------------------- /t/regress.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 21; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters qw(:lax); 9 | 10 | fun mk_counter($i) { 11 | fun () { $i++ } 12 | } 13 | 14 | method nop() {} 15 | fun fnop($x, $y, $z) { 16 | } 17 | 18 | is_deeply [nop], []; 19 | is_deeply [main->nop], []; 20 | is_deeply [nop 1], []; 21 | is scalar(nop), undef; 22 | is scalar(nop 2), undef; 23 | 24 | is_deeply [fnop], []; 25 | is_deeply [fnop 3, 4], []; 26 | is scalar(fnop), undef; 27 | is scalar(fnop 5, 6), undef; 28 | 29 | my $f = mk_counter 0; 30 | my $g = mk_counter 10; 31 | my $h = mk_counter 50; 32 | 33 | is $f->(), 0; 34 | is $g->(), 10; 35 | is $h->(), 50; 36 | is $f->(), 1; 37 | is $g->(), 11; 38 | is $h->(), 51; 39 | is $f->(), 2; 40 | is $f->(), 3; 41 | is $f->(), 4; 42 | is $g->(), 12; 43 | is $h->(), 52; 44 | is $g->(), 13; 45 | -------------------------------------------------------------------------------- /t/rename.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | use Function::Parameters { f => 'function' }; 6 | 7 | my $add = f ($x, $y) { $x + $y }; 8 | 9 | is $add->(2, 4), 6; 10 | 11 | use Function::Parameters { 12 | meth_b => 'method', 13 | func_b => 'function', 14 | }; 15 | 16 | func_b cat_b($x, $y) { 17 | $x . $y 18 | } 19 | 20 | meth_b tac_b($x) { 21 | $x . $self 22 | } 23 | 24 | is cat_b('ab', 'cde'), 'abcde'; 25 | is tac_b('ab', 'cde'), 'cdeab'; 26 | 27 | done_testing; 28 | -------------------------------------------------------------------------------- /t/strict.t: -------------------------------------------------------------------------------- 1 | use warnings; 2 | use strict; 3 | 4 | use Test::More tests => 10; 5 | 6 | use FindBin; 7 | 8 | for my $fail ( 9 | map ["$FindBin::Bin/strict_$_->[0].fail", @$_[1 .. $#$_]], 10 | ['1', qr/"\$z" can't appear after slurpy parameter "\@y\"/], 11 | ['2', qr/"\$y" can't appear after slurpy parameter "\@x\"/], 12 | ['3', qr/"\$z" can't appear after slurpy parameter "%y\"/], 13 | ['4', qr/"\@z" can't appear after slurpy parameter "\@y\"/], 14 | ['5', qr/Invalid.*rarity/], 15 | ) { 16 | my ($file, $pat) = @$fail; 17 | $@ = undef; 18 | my $done = do $file; 19 | my $exc = $@; 20 | my $err = $!; 21 | 22 | is $done, undef, "faulty code doesn't load - $file"; 23 | $exc or die "$file: $err" if $err; 24 | like $exc, $pat; 25 | } 26 | -------------------------------------------------------------------------------- /t/strict_1.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters; 6 | 7 | fun bad_1($x, @y, $z) {} 8 | 9 | 'ok' 10 | -------------------------------------------------------------------------------- /t/strict_2.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters; 6 | 7 | fun bad_2(@x, $y) {} 8 | 9 | 'ok' 10 | -------------------------------------------------------------------------------- /t/strict_3.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters; 6 | 7 | fun bad_3($x, %y, $z) {} 8 | 9 | 'ok' 10 | -------------------------------------------------------------------------------- /t/strict_4.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters; 6 | 7 | fun bad_4(@y, @z) {} 8 | 9 | 'ok' 10 | -------------------------------------------------------------------------------- /t/strict_5.fail: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings; 3 | use strict; 4 | 5 | use Function::Parameters { 6 | spike => { 7 | rarity => 'best', 8 | }, 9 | }; 10 | 11 | 'ok' 12 | -------------------------------------------------------------------------------- /t/stringy_h.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Function::Parameters; 6 | 7 | my @warnings; 8 | BEGIN { 9 | $SIG{__WARN__} = sub { 10 | push @warnings, $_[0]; 11 | }; 12 | } 13 | 14 | sub wget { 15 | splice @warnings 16 | } 17 | 18 | { 19 | BEGIN { $^H{'Function::Parameters/config'} .= ''; } 20 | if (0) {} 21 | if (0) {} 22 | } 23 | BEGIN { 24 | my @w = wget; 25 | is @w, 1; 26 | like $w[0], qr{^Function::Parameters: \$\^H\{'Function::Parameters/config'\} is not a reference; skipping: HASH\(}; 27 | } 28 | 29 | { 30 | no warnings 'Function::Parameters'; 31 | BEGIN { $^H{'Function::Parameters/config'} .= ''; } 32 | if (0) {} 33 | if (0) {} 34 | } 35 | BEGIN { 36 | my @w = wget; 37 | is @w, 0; 38 | is $w[0], undef; 39 | } 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /t/threads.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More 4 | eval { require threads; threads->import; 1 } 5 | ? (tests => 2) 6 | : (skip_all => "threads required for testing threads"); 7 | 8 | use warnings FATAL => 'all'; 9 | use strict; 10 | 11 | use Function::Parameters; 12 | 13 | fun concat3($x, $xxx, $xx) { 14 | my $helper = eval q{ 15 | fun ($x, $y) { $x . $y } 16 | }; 17 | return $x . $helper->($xxx, $xx); 18 | } 19 | 20 | my $thr = threads->create(fun ($val) { 21 | concat3 'first (', $val, ') last'; 22 | }, 'middle'); 23 | 24 | my $r1 = concat3 'foo', threads->tid, 'bar'; 25 | my $r2 = $thr->join; 26 | 27 | is $r1, 'foo0bar'; 28 | is $r2, 'first (middle) last'; 29 | -------------------------------------------------------------------------------- /t/threads2.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use Test::More 3 | eval { require threads; threads->import; 1 } 4 | ? (tests => 1) 5 | : (skip_all => "threads required for testing threads"); 6 | 7 | use warnings FATAL => 'all'; 8 | use strict; 9 | 10 | use threads::shared; 11 | 12 | my $nthreads = 5; 13 | 14 | my $xvar :shared = 0; 15 | 16 | for my $t (1 .. $nthreads) { 17 | threads->create(sub { 18 | lock $xvar; 19 | $xvar++; 20 | cond_wait $xvar while $xvar >= 0; 21 | require Function::Parameters; 22 | }); 23 | } 24 | 25 | { 26 | threads->yield; 27 | lock $xvar; 28 | if ($xvar < $nthreads) { 29 | redo; 30 | } 31 | 32 | $xvar = -1; 33 | cond_broadcast $xvar; 34 | } 35 | 36 | $_->join for threads->list; 37 | 38 | pass "we haven't crashed yet"; 39 | -------------------------------------------------------------------------------- /t/types_auto.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings qw(all FATAL uninitialized); 3 | use strict; 4 | 5 | use Test::More tests => 12; 6 | 7 | { 8 | package MyTC; 9 | 10 | use overload 11 | '~' => 'complement', 12 | '|' => 'union', 13 | '&' => 'intersection', 14 | '/' => 'alternative', 15 | '&{}' => 'apply'; 16 | 17 | sub new { 18 | my ($class, $name) = @_; 19 | bless { _name => $name }, $class 20 | } 21 | 22 | sub name { $_[0]{_name} } 23 | 24 | sub check { 1 } 25 | 26 | sub get_message { die "Internal error: get_message: ${\$_[0]->name}"; } 27 | 28 | sub complement { 29 | my ($x) = @_; 30 | ref($x)->new('~' . $x->name) 31 | } 32 | 33 | sub union { 34 | my ($x, $y) = @_; 35 | ref($x)->new('(' . $x->name . '|' . $y->name . ')') 36 | } 37 | 38 | sub intersection { 39 | my ($x, $y) = @_; 40 | ref($x)->new('(' . $x->name . '&' . $y->name . ')') 41 | } 42 | 43 | sub alternative { 44 | my ($x, $y) = @_; 45 | ref($x)->new('(' . $x->name . '/' . $y->name . ')') 46 | } 47 | 48 | sub apply { 49 | my $self = shift; 50 | sub { 51 | return $self if !@_; 52 | @_ == 1 or die "Internal error: apply->(@_)"; 53 | my @args = @{$_[0]}; 54 | ref($self)->new($self->name . '[' . join(',', map $_->name, @args) . ']') 55 | } 56 | } 57 | } 58 | 59 | use Function::Parameters; 60 | 61 | BEGIN { 62 | for my $suffix ('a' .. 't') { 63 | my $name = "T$suffix"; 64 | my $obj = MyTC->new($name); 65 | my $symbol = do { no strict 'refs'; \*$name }; 66 | *$symbol = sub { $obj->(@_) }; 67 | } 68 | } 69 | 70 | is eval 'fun (NoSuchType $x) {}', undef; 71 | like $@, qr/\AUndefined type name main::NoSuchType /; 72 | 73 | is eval 'fun (("NoSuchType") $x) {}', undef; 74 | like $@, qr/\AUndefined type name main::NoSuchType /; 75 | 76 | for my $f ( 77 | fun ( Ta[Tb] | ~Td | Tf [ (Tg), ~~ ~ Ti | (Ta | Tb & Tc & Td), Tj | Tk[Tl], To [ Tq, Tr ] | Tt ] & Ta / Tb | Tc / Td & Te $x) {}, 78 | fun ((' Ta[Tb] | ~Td | Tf [ (Tg), ~~ ~ Ti | (Ta | Tb & Tc & Td), Tj | Tk[Tl], To [ Tq, Tr ] | Tt ] & Ta / Tb | Tc / Td & Te ') $x) {}, 79 | ) { 80 | my $m = Function::Parameters::info $f; 81 | is my ($xi) = $m->positional_required, 1; 82 | is $xi->name, '$x'; 83 | my $t = $xi->type; 84 | is ref $t, 'MyTC'; 85 | is $t->name, '(((Ta[Tb]|~Td)|(Tf[Tg,(~~~Ti|(Ta|((Tb&Tc)&Td))),(Tj|Tk[Tl]),(To[Tq,Tr]|Tt)]&(Ta/Tb)))|((Tc/Td)&Te))'; 86 | } 87 | -------------------------------------------------------------------------------- /t/types_caller.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More tests => 20; 6 | 7 | { 8 | package MyTC; 9 | 10 | sub new { 11 | my $class = shift; 12 | bless {}, $class 13 | } 14 | 15 | sub check { 16 | 1 17 | } 18 | 19 | sub get_message { 20 | die "Internal error: get_message"; 21 | } 22 | } 23 | 24 | my ($reify_arg, @reify_caller); 25 | sub take_em { 26 | my $t = $reify_arg; 27 | $reify_arg = undef; 28 | $t, splice @reify_caller 29 | } 30 | 31 | use Function::Parameters { 32 | fun => { 33 | defaults => 'function_strict', 34 | reify_type => sub { 35 | @_ == 1 or die "WTF: (@_)"; 36 | $_[0] =~ /\ADie\[(.*)\]\z/s and die "$1\n"; 37 | $reify_arg = $_[0]; 38 | @reify_caller = caller; 39 | MyTC->new 40 | }, 41 | }, 42 | }; 43 | 44 | { 45 | my ($t, @c); 46 | BEGIN { ($t, @c) = take_em; } 47 | is $t, undef; 48 | is @c, 0; 49 | } 50 | 51 | { 52 | package SineWeave; 53 | #line 666 "abc.def" 54 | fun foo(time [ time [ time ] ] $x) {} 55 | #line 56 "t/types_caller.t" 56 | } 57 | 58 | { 59 | my ($t, @c); 60 | BEGIN { ($t, @c) = take_em; } 61 | is $t, 'time[time[time]]'; 62 | is $c[0], 'SineWeave'; 63 | is $c[1], 'abc.def'; 64 | is $c[2], 666; 65 | } 66 | 67 | { 68 | { 69 | package SineWeave::InEvalOutside; 70 | eval q{#line 500 "abc2.def" 71 | fun foo2(A[B] | C::D | E::F [ G, H::I, J | K[L], M::N::O [ P::Q, R ] | S::T ] $x) {} 72 | }; 73 | } 74 | is $@, ''; 75 | my ($t, @c) = take_em; 76 | is $t, 'A[B]|C::D|E::F[G,H::I,J|K[L],M::N::O[P::Q,R]|S::T]'; 77 | is $c[0], 'SineWeave::InEvalOutside'; 78 | is $c[1], 'abc2.def'; 79 | is $c[2], 500; 80 | } 81 | 82 | { 83 | { 84 | eval q{#line 500 "abc3.def" 85 | package SineWeave::InEvalInside; 86 | fun foo3(Any $x) {} 87 | }; 88 | } 89 | is $@, ''; 90 | my ($t, @c) = take_em; 91 | is $t, 'Any'; 92 | is $c[0], 'SineWeave::InEvalInside'; 93 | is $c[1], 'abc3.def'; 94 | is $c[2], 501; 95 | } 96 | 97 | { 98 | is eval q{ fun foo4(Die[blaue[Blume]] $x) {} 1 }, undef; 99 | is $@, "blaue[Blume]\n"; 100 | my ($t, @c) = take_em; 101 | is $t, undef; 102 | is @c, 0; 103 | } 104 | -------------------------------------------------------------------------------- /t/types_coerce.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings qw(all FATAL uninitialized); 3 | use strict; 4 | use Test::More tests => 15; 5 | use Test::Fatal; 6 | use Function::Parameters; 7 | 8 | { 9 | package MyTC_noco; 10 | 11 | method new($class: $good) { 12 | bless { good => $good }, $class 13 | } 14 | 15 | method coerce($value) { 16 | die "bad"; 17 | } 18 | 19 | method check($value) { 20 | $value eq $self->{good} 21 | } 22 | 23 | method get_message($value) { 24 | "'$value' ain't '$self->{good}'" 25 | } 26 | } 27 | 28 | { 29 | package MyTC; 30 | BEGIN { our @ISA = MyTC_noco::; } 31 | 32 | method has_coercion() { 33 | $self->{has_coercion} 34 | } 35 | 36 | method enable_coercion($flag = 1) { 37 | $self->{has_coercion} = $flag; 38 | } 39 | 40 | method new($class: $good, $coerce = 0) { 41 | my $self = $class->SUPER::new($good); 42 | $self->enable_coercion($coerce); 43 | $self 44 | } 45 | 46 | method coerce($value) { 47 | $value =~ s/\?+\z//; 48 | $value 49 | } 50 | } 51 | 52 | use constant { 53 | Type_A => MyTC_noco->new('Type_A:good'), 54 | Type_B => MyTC->new('Type_B:good'), 55 | Type_C => MyTC->new('Type_C:good', 1), 56 | }; 57 | 58 | fun constrained_0(Type_A $x, Type_B $y, Type_C $z) { [$x, $y, $z] } 59 | fun constrained_1((Type_A) $x, (Type_B) $y, (Type_C) $z) { [$x, $y, $z] } 60 | fun constrained_2(('Type_A') $x, ('Type_B') $y, ('Type_C') $z) { [$x, $y, $z] } 61 | 62 | is_deeply constrained_0('Type_A:good', 'Type_B:good', 'Type_C:good'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; 63 | is_deeply constrained_1('Type_A:good', 'Type_B:good', 'Type_C:good'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; 64 | is_deeply constrained_2('Type_A:good', 'Type_B:good', 'Type_C:good'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; 65 | 66 | like exception { constrained_0 'Type_A:good???', '-', '-' }, qr/\Q'Type_A:good???' ain't 'Type_A:good'/; 67 | like exception { constrained_1 'Type_A:good???', '-', '-' }, qr/\Q'Type_A:good???' ain't 'Type_A:good'/; 68 | like exception { constrained_2 'Type_A:good???', '-', '-' }, qr/\Q'Type_A:good???' ain't 'Type_A:good'/; 69 | 70 | like exception { constrained_0 'Type_A:good', 'Type_B:good???', '-', }, qr/\Q'Type_B:good???' ain't 'Type_B:good'/; 71 | like exception { constrained_1 'Type_A:good', 'Type_B:good???', '-', }, qr/\Q'Type_B:good???' ain't 'Type_B:good'/; 72 | like exception { constrained_2 'Type_A:good', 'Type_B:good???', '-', }, qr/\Q'Type_B:good???' ain't 'Type_B:good'/; 73 | 74 | like exception { constrained_0 'Type_A:good', 'Type_B:good', 'Type_C:bad??', }, qr/\Q'Type_C:bad' ain't 'Type_C:good'/; 75 | like exception { constrained_1 'Type_A:good', 'Type_B:good', 'Type_C:bad??', }, qr/\Q'Type_C:bad' ain't 'Type_C:good'/; 76 | like exception { constrained_2 'Type_A:good', 'Type_B:good', 'Type_C:bad??', }, qr/\Q'Type_C:bad' ain't 'Type_C:good'/; 77 | 78 | is_deeply constrained_0('Type_A:good', 'Type_B:good', 'Type_C:good???'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; 79 | is_deeply constrained_1('Type_A:good', 'Type_B:good', 'Type_C:good???'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; 80 | is_deeply constrained_2('Type_A:good', 'Type_B:good', 'Type_C:good???'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; 81 | -------------------------------------------------------------------------------- /t/types_custom.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More tests => 8; 6 | use Test::Fatal; 7 | 8 | use Function::Parameters qw(:strict); 9 | use Function::Parameters { 10 | def => { strict => 1 }, 11 | }; 12 | 13 | { 14 | package MyTC; 15 | 16 | method new( 17 | $class: 18 | $name, 19 | $check, 20 | $get_message = fun ($value) { 21 | "Validation failed for constraint '$name' with value '$value'" 22 | }, 23 | ) { 24 | bless { 25 | name => $name, 26 | check => $check, 27 | get_message => $get_message, 28 | }, $class 29 | } 30 | 31 | method check($value) { 32 | $self->{check}($value) 33 | } 34 | 35 | method get_message($value) { 36 | $self->{get_message}($value) 37 | } 38 | } 39 | 40 | use constant { 41 | TEvenNum => MyTC->new('even number' => fun ($n) { $n =~ /^[0-9]+\z/ && $n % 2 == 0 }), 42 | TShortStr => MyTC->new('short string' => fun ($s) { length($s) < 10 }), 43 | }; 44 | 45 | fun foo((TEvenNum) $x, (TShortStr) $y) { 46 | "$x/$y" 47 | } 48 | 49 | is foo(42, "hello"), "42/hello"; 50 | like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 51 | like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; 52 | like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 53 | 54 | def foo2((TEvenNum) $x, (TShortStr) $y) { 55 | "$x/$y" 56 | } 57 | 58 | is foo2(42, "hello"), "42/hello"; 59 | like exception { foo2 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 60 | like exception { foo2 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; 61 | like exception { foo2 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 62 | -------------------------------------------------------------------------------- /t/types_custom_2.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More tests => 4; 6 | use Test::Fatal; 7 | 8 | { 9 | package MyTC; 10 | 11 | use Function::Parameters qw(:strict); 12 | 13 | method new( 14 | $class: 15 | $name, 16 | $check, 17 | $get_message = fun ($value) { 18 | "Validation failed for constraint '$name' with value '$value'" 19 | }, 20 | ) { 21 | bless { 22 | name => $name, 23 | check => $check, 24 | get_message => $get_message, 25 | }, $class 26 | } 27 | 28 | method check($value) { 29 | $self->{check}($value) 30 | } 31 | 32 | method get_message($value) { 33 | $self->{get_message}($value) 34 | } 35 | } 36 | 37 | use Function::Parameters do { 38 | use Function::Parameters qw(:strict); 39 | 40 | my %Types = ( 41 | TEvenNum => MyTC->new('even number' => fun ($n) { $n =~ /^[0-9]+\z/ && $n % 2 == 0 }), 42 | TShortStr => MyTC->new('short string' => fun ($s) { length($s) < 10 }), 43 | Any => MyTC->new('any value' => fun ($a) { 1 }), 44 | ); 45 | +{ 46 | fun => { 47 | strict => 1, 48 | reify_type => sub { $Types{ $_[0] } || $Types{Any} }, 49 | }, 50 | } 51 | }; 52 | 53 | fun foo(TEvenNum $x, TShortStr $y) { 54 | "$x/$y" 55 | } 56 | 57 | is foo(42, "hello"), "42/hello"; 58 | like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 59 | like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; 60 | like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 61 | -------------------------------------------------------------------------------- /t/types_custom_3.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More tests => 8; 6 | 7 | { 8 | package TX; 9 | 10 | sub check { 1 } 11 | 12 | our $obj; 13 | BEGIN { $obj = bless {}, 'TX'; } 14 | } 15 | 16 | use Function::Parameters { 17 | fun => { 18 | strict => 1, 19 | reify_type => sub { 20 | my ($type) = @_; 21 | my $package = caller; 22 | if ($package ne $type) { 23 | my (undef, $file, $line) = @_; 24 | diag ""; 25 | diag "! $file : $line"; 26 | } 27 | is $package, $type; 28 | $TX::obj 29 | }, 30 | }, 31 | }; 32 | 33 | fun f1(main $x) {} 34 | fun Asdf::f1(main $x) {} 35 | 36 | { 37 | package Foo::Bar::Baz; 38 | 39 | fun f1(Foo::Bar::Baz $x) {} 40 | fun Ghjk::f1(Foo::Bar::Baz $x) {} 41 | 42 | package AAA; 43 | fun f1(AAA $x) {} 44 | fun main::f2(AAA $x) {} 45 | } 46 | 47 | fun f3(main $x) {} 48 | fun Ghjk::f2(main $x) {} 49 | -------------------------------------------------------------------------------- /t/types_custom_4.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More tests => 8; 6 | use Test::Fatal; 7 | 8 | use Function::Parameters qw(:strict), { def => { strict => 1 } }; 9 | 10 | { 11 | package MyTC; 12 | 13 | method new( 14 | $class: 15 | $name, 16 | $check, 17 | $get_message = fun ($value) { 18 | "Validation failed for constraint '$name' with value '$value'" 19 | }, 20 | ) { 21 | bless { 22 | name => $name, 23 | check => $check, 24 | get_message => $get_message, 25 | }, $class 26 | } 27 | 28 | method check($value) { 29 | $self->{check}($value) 30 | } 31 | 32 | method get_message($value) { 33 | $self->{get_message}($value) 34 | } 35 | } 36 | 37 | use constant { 38 | TEvenNum => MyTC->new('even number' => fun ($n) { $n =~ /^[0-9]+\z/ && $n % 2 == 0 }), 39 | TShortStr => MyTC->new('short string' => fun ($s) { length($s) < 10 }), 40 | }; 41 | 42 | fun foo(TEvenNum $x, TShortStr $y) { 43 | "$x/$y" 44 | } 45 | 46 | is foo(42, "hello"), "42/hello"; 47 | like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 48 | like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; 49 | like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 50 | 51 | def foo2(TEvenNum $x, TShortStr $y) { 52 | "$x/$y" 53 | } 54 | 55 | is foo2(42, "hello"), "42/hello"; 56 | like exception { foo2 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 57 | like exception { foo2 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; 58 | like exception { foo2 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; 59 | -------------------------------------------------------------------------------- /t/types_inline.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings qw(all FATAL uninitialized); 3 | use strict; 4 | use Test::More $^V ge v5.20.0 5 | ? (tests => 14) 6 | : (skip_all => sprintf("[perl-v%vd] this test throws syntax errors on perls before 5.20 and I don't understand why :shrug:", $^V)); 7 | use Test::Fatal; 8 | use Function::Parameters; 9 | 10 | BEGIN { 11 | package MyTC; 12 | 13 | method new( $class: 14 | :$incline = 0, 15 | :$file = undef, 16 | :$line = undef, 17 | :$broken = undef, 18 | ) { 19 | bless { 20 | incline => $incline, 21 | file => $file, 22 | line => $line, 23 | broken => $broken, 24 | }, $class 25 | } 26 | 27 | method can_be_inlined() { 28 | 1 29 | } 30 | 31 | method inline_check($var) { 32 | my $line = $self->{line}; 33 | my $file = $self->{file}; 34 | if (defined $file) { 35 | $line //= (caller)[2]; 36 | } 37 | my $header = defined $line ? qq{#line $line "$file"\n} : ""; 38 | my $garbage = ";\n" x $self->{incline}; 39 | my $error = $self->{broken} ? "]" : ""; 40 | $header . "do { $garbage defined($var) $error }" 41 | } 42 | 43 | method check($value) { 44 | die "check() shouldn't be called"; 45 | } 46 | 47 | method get_message($value) { 48 | "value is not defined" 49 | } 50 | } 51 | 52 | use constant { 53 | TDef => MyTC->new, 54 | TBroken => MyTC->new(broken => 1, incline => 99), 55 | TDefI7 => MyTC->new(incline => 7), 56 | TDefX => MyTC->new(file => "fake-file", line => 666_666), 57 | TDefXI2 => MyTC->new(file => "fake-file", line => 666_666, incline => 2), 58 | }; 59 | 60 | is eval(qq|#line 2 "~virtual~"\nfun (TBroken \$bad) {}|), undef, "broken type constraint doesn't compile"; 61 | like $@, qr/\bsyntax error at \(inline_check:~virtual~:2\) line 100\b/, "broken type constraint reports correct source location"; 62 | 63 | #line 62 "t/types_inline.t" 64 | fun foo0(TDef $x) { $x } 65 | 66 | is foo0('good'), 'good', "defined value passes inline check"; 67 | like exception { foo0(undef) }, qr/\AIn fun foo0: parameter 1 \(\$x\): value is not defined\b/, "undefined value throws"; 68 | is __FILE__ . ' ' . __LINE__, "t/types_inline.t 66", "source location OK"; 69 | 70 | #line 69 "t/types_inline.t" 71 | fun foo1(TDefI7 $x) { $x } 72 | 73 | is foo1('good'), 'good', "(+7) defined value passes inline check"; 74 | like exception { foo1(undef) }, qr/\AIn fun foo1: parameter 1 \(\$x\): value is not defined\b/, "(+7) undefined value throws"; 75 | is __FILE__ . ' ' . __LINE__, "t/types_inline.t 73", "(+7) source location OK"; 76 | 77 | #line 76 "t/types_inline.t" 78 | fun foo2(TDefX $x) { $x } 79 | 80 | is foo2('good'), 'good', "(X) defined value passes inline check"; 81 | like exception { foo2(undef) }, qr/\AIn fun foo2: parameter 1 \(\$x\): value is not defined\b/, "(X) undefined value throws"; 82 | is __FILE__ . ' ' . __LINE__, "t/types_inline.t 80", "(X) source location OK"; 83 | 84 | #line 83 "t/types_inline.t" 85 | fun foo3(TDefXI2 $x) { $x } 86 | 87 | is foo3('good'), 'good', "(X+2) defined value passes inline check"; 88 | like exception { foo3(undef) }, qr/\AIn fun foo3: parameter 1 \(\$x\): value is not defined\b/, "(X+2) undefined value throws"; 89 | is __FILE__ . ' ' . __LINE__, "t/types_inline.t 87", "(X+2) source location OK"; 90 | -------------------------------------------------------------------------------- /t/types_moose.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More 6 | eval { require Moose } 7 | ? (tests => 49) 8 | : (skip_all => "Moose required for testing types") 9 | ; 10 | use Test::Fatal; 11 | 12 | use Function::Parameters { 13 | fun => { defaults => 'function', reify_type => 'moose' }, 14 | method => { defaults => 'method', reify_type => 'moose' }, 15 | }; 16 | 17 | fun foo(Int $n, CodeRef $f, $x) { 18 | $x = $f->($x) for 1 .. $n; 19 | $x 20 | } 21 | 22 | is foo(0, fun (@) {}, undef), undef; 23 | is foo(0, fun (@) {}, "o hai"), "o hai"; 24 | is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; 25 | is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; 26 | 27 | { 28 | my $info = Function::Parameters::info \&foo; 29 | is $info->invocant, undef; 30 | is $info->slurpy, undef; 31 | is $info->positional_optional, 0; 32 | is $info->named_required, 0; 33 | is $info->named_optional, 0; 34 | my @req = $info->positional_required; 35 | is @req, 3; 36 | is $req[0]->name, '$n'; 37 | ok $req[0]->type->equals('Int'); 38 | is $req[1]->name, '$f'; 39 | ok $req[1]->type->equals('CodeRef'); 40 | is $req[2]->name, '$x'; 41 | is $req[2]->type, undef; 42 | } 43 | 44 | like exception { foo("ermagerd", fun (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; 45 | like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; 46 | 47 | fun bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } 48 | 49 | is bar(21), 42; 50 | { 51 | my $info = Function::Parameters::info \&bar; 52 | is $info->invocant, undef; 53 | is $info->slurpy, undef; 54 | is $info->positional_optional, 0; 55 | is $info->named_required, 0; 56 | is $info->named_optional, 0; 57 | my @req = $info->positional_required; 58 | is @req, 1; 59 | is $req[0]->name, '$whoa'; 60 | ok $req[0]->type->equals('Int'); 61 | } 62 | 63 | { 64 | my $info = Function::Parameters::info(fun ( ArrayRef [ Int | CodeRef ]@nom) {}); 65 | is $info->invocant, undef; 66 | is $info->positional_required, 0; 67 | is $info->positional_optional, 0; 68 | is $info->named_required, 0; 69 | is $info->named_optional, 0; 70 | my $slurpy = $info->slurpy; 71 | is $slurpy->name, '@nom'; 72 | ok $slurpy->type->equals(Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int|CodeRef]')); 73 | } 74 | 75 | { 76 | my $phase = 'runtime'; 77 | BEGIN { $phase = 'A'; } 78 | fun 79 | baz 80 | ( 81 | ( 82 | is 83 | ( 84 | $phase 85 | ++ 86 | , 87 | 'A' 88 | ) 89 | , 90 | 'Int' 91 | ) 92 | : 93 | $marco 94 | , 95 | ( 96 | is 97 | ( 98 | $phase 99 | ++ 100 | , 101 | 'B' 102 | ) 103 | , 104 | q 105 | $ArrayRef[Str]$ 106 | ) 107 | : 108 | $polo 109 | ) 110 | { 111 | [ 112 | $marco 113 | , 114 | $polo 115 | ] 116 | } 117 | BEGIN { is $phase, 'C'; } 118 | is $phase, 'runtime'; 119 | 120 | is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; 121 | 122 | my $info = Function::Parameters::info \&baz; 123 | is $info->invocant, undef; 124 | is $info->slurpy, undef; 125 | is $info->positional_required, 0; 126 | is $info->positional_optional, 0; 127 | is $info->named_optional, 0; 128 | my @req = $info->named_required; 129 | is @req, 2; 130 | is $req[0]->name, '$marco'; 131 | ok $req[0]->type->equals('Int'); 132 | is $req[1]->name, '$polo'; 133 | ok $req[1]->type->equals('ArrayRef[Str]'); 134 | } 135 | -------------------------------------------------------------------------------- /t/types_moose_2.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More 6 | eval { require Moose::Util } 7 | ? (tests => 49) 8 | : (skip_all => "Moose required for testing types") 9 | ; 10 | use Test::Fatal; 11 | 12 | use Function::Parameters { 13 | fun => { defaults => 'function', reify_type => 'moose' }, 14 | method => { defaults => 'method', reify_type => 'moose' }, 15 | }; 16 | 17 | fun foo(('Int') $n, ('CodeRef') $f, $x) { 18 | $x = $f->($x) for 1 .. $n; 19 | $x 20 | } 21 | 22 | is foo(0, fun (@) {}, undef), undef; 23 | is foo(0, fun (@) {}, "o hai"), "o hai"; 24 | is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; 25 | is foo(3, fun (('Str') $x) { "($x)" }, 1.5), "(((1.5)))"; 26 | 27 | { 28 | my $info = Function::Parameters::info \&foo; 29 | is $info->invocant, undef; 30 | is $info->slurpy, undef; 31 | is $info->positional_optional, 0; 32 | is $info->named_required, 0; 33 | is $info->named_optional, 0; 34 | my @req = $info->positional_required; 35 | is @req, 3; 36 | is $req[0]->name, '$n'; 37 | ok $req[0]->type->equals('Int'); 38 | is $req[1]->name, '$f'; 39 | ok $req[1]->type->equals('CodeRef'); 40 | is $req[2]->name, '$x'; 41 | is $req[2]->type, undef; 42 | } 43 | 44 | like exception { foo("ermagerd", fun (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; 45 | like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; 46 | 47 | fun bar( 48 | ( 49 | do { 50 | require Moose; 51 | (Function::Parameters::info(\&foo)->positional_required)[0]->type 52 | } 53 | ) $whoa 54 | ) { $whoa * 2 } 55 | 56 | is bar(21), 42; 57 | { 58 | my $info = Function::Parameters::info \&bar; 59 | is $info->invocant, undef; 60 | is $info->slurpy, undef; 61 | is $info->positional_optional, 0; 62 | is $info->named_required, 0; 63 | is $info->named_optional, 0; 64 | my @req = $info->positional_required; 65 | is @req, 1; 66 | is $req[0]->name, '$whoa'; 67 | ok $req[0]->type->equals('Int'); 68 | } 69 | 70 | { 71 | my $info = Function::Parameters::info(fun ( (q~ArrayRef [ Int | CodeRef ]~ )@nom) {}); 72 | is $info->invocant, undef; 73 | is $info->positional_required, 0; 74 | is $info->positional_optional, 0; 75 | is $info->named_required, 0; 76 | is $info->named_optional, 0; 77 | my $slurpy = $info->slurpy; 78 | is $slurpy->name, '@nom'; 79 | ok $slurpy->type->equals(Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int|CodeRef]')); 80 | } 81 | 82 | { 83 | my $phase = 'runtime'; 84 | BEGIN { $phase = 'A'; } 85 | fun 86 | baz 87 | ( 88 | ( 89 | is 90 | ( 91 | $phase 92 | ++ 93 | , 94 | 'A' 95 | ) 96 | , 97 | 'Int' 98 | ) 99 | : 100 | $marco 101 | , 102 | ( 103 | is 104 | ( 105 | $phase 106 | ++ 107 | , 108 | 'B' 109 | ) 110 | , 111 | q 112 | $ArrayRef[Str]$ 113 | ) 114 | : 115 | $polo 116 | ) 117 | { 118 | [ 119 | $marco 120 | , 121 | $polo 122 | ] 123 | } 124 | BEGIN { is $phase, 'C'; } 125 | is $phase, 'runtime'; 126 | 127 | is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; 128 | 129 | my $info = Function::Parameters::info \&baz; 130 | is $info->invocant, undef; 131 | is $info->slurpy, undef; 132 | is $info->positional_required, 0; 133 | is $info->positional_optional, 0; 134 | is $info->named_optional, 0; 135 | my @req = $info->named_required; 136 | is @req, 2; 137 | is $req[0]->name, '$marco'; 138 | ok $req[0]->type->equals('Int'); 139 | is $req[1]->name, '$polo'; 140 | ok $req[1]->type->equals('ArrayRef[Str]'); 141 | } 142 | -------------------------------------------------------------------------------- /t/types_moose_3.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More 6 | eval { require Moose } 7 | ? (tests => 49) 8 | : (skip_all => "Moose required for testing types") 9 | ; 10 | use Test::Fatal; 11 | 12 | use Function::Parameters { 13 | def => { strict => 1, reify_type => 'moose' }, 14 | }; 15 | 16 | def foo(Int $n, CodeRef $f, $x) { 17 | $x = $f->($x) for 1 .. $n; 18 | $x 19 | } 20 | 21 | is foo(0, def (@) {}, undef), undef; 22 | is foo(0, def (@) {}, "o hai"), "o hai"; 23 | is foo(3, def ($x) { "($x)" }, 1.5), "(((1.5)))"; 24 | is foo(3, def (Str $x) { "($x)" }, 1.5), "(((1.5)))"; 25 | 26 | { 27 | my $info = Function::Parameters::info \&foo; 28 | is $info->invocant, undef; 29 | is $info->slurpy, undef; 30 | is $info->positional_optional, 0; 31 | is $info->named_required, 0; 32 | is $info->named_optional, 0; 33 | my @req = $info->positional_required; 34 | is @req, 3; 35 | is $req[0]->name, '$n'; 36 | ok $req[0]->type->equals('Int'); 37 | is $req[1]->name, '$f'; 38 | ok $req[1]->type->equals('CodeRef'); 39 | is $req[2]->name, '$x'; 40 | is $req[2]->type, undef; 41 | } 42 | 43 | like exception { foo("ermagerd", def (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; 44 | like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; 45 | 46 | def bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } 47 | 48 | is bar(21), 42; 49 | { 50 | my $info = Function::Parameters::info \&bar; 51 | is $info->invocant, undef; 52 | is $info->slurpy, undef; 53 | is $info->positional_optional, 0; 54 | is $info->named_required, 0; 55 | is $info->named_optional, 0; 56 | my @req = $info->positional_required; 57 | is @req, 1; 58 | is $req[0]->name, '$whoa'; 59 | ok $req[0]->type->equals('Int'); 60 | } 61 | 62 | { 63 | my $info = Function::Parameters::info(def ( ArrayRef [ Int | CodeRef ]@nom) {}); 64 | is $info->invocant, undef; 65 | is $info->positional_required, 0; 66 | is $info->positional_optional, 0; 67 | is $info->named_required, 0; 68 | is $info->named_optional, 0; 69 | my $slurpy = $info->slurpy; 70 | is $slurpy->name, '@nom'; 71 | ok $slurpy->type->equals(Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int|CodeRef]')); 72 | } 73 | 74 | { 75 | my $phase = 'runtime'; 76 | BEGIN { $phase = 'A'; } 77 | def 78 | baz 79 | ( 80 | ( 81 | is 82 | ( 83 | $phase 84 | ++ 85 | , 86 | 'A' 87 | ) 88 | , 89 | 'Int' 90 | ) 91 | : 92 | $marco 93 | , 94 | ( 95 | is 96 | ( 97 | $phase 98 | ++ 99 | , 100 | 'B' 101 | ) 102 | , 103 | q 104 | $ArrayRef[Str]$ 105 | ) 106 | : 107 | $polo 108 | ) 109 | { 110 | [ 111 | $marco 112 | , 113 | $polo 114 | ] 115 | } 116 | BEGIN { is $phase, 'C'; } 117 | is $phase, 'runtime'; 118 | 119 | is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; 120 | 121 | my $info = Function::Parameters::info \&baz; 122 | is $info->invocant, undef; 123 | is $info->slurpy, undef; 124 | is $info->positional_required, 0; 125 | is $info->positional_optional, 0; 126 | is $info->named_optional, 0; 127 | my @req = $info->named_required; 128 | is @req, 2; 129 | is $req[0]->name, '$marco'; 130 | ok $req[0]->type->equals('Int'); 131 | is $req[1]->name, '$polo'; 132 | ok $req[1]->type->equals('ArrayRef[Str]'); 133 | } 134 | -------------------------------------------------------------------------------- /t/types_moosex.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More 6 | eval { require MooseX::Types } 7 | ? (tests => 49) 8 | : (skip_all => "MooseX::Types required for testing types") 9 | ; 10 | use Test::Fatal; 11 | use MooseX::Types::Moose qw(Int Str ArrayRef CodeRef); 12 | 13 | use Function::Parameters qw(:strict); 14 | 15 | 16 | fun foo((Int) $n, (CodeRef) $f, $x) { 17 | $x = $f->($x) for 1 .. $n; 18 | $x 19 | } 20 | 21 | is foo(0, fun (@) {}, undef), undef; 22 | is foo(0, fun (@) {}, "o hai"), "o hai"; 23 | is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; 24 | is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; 25 | 26 | { 27 | my $info = Function::Parameters::info \&foo; 28 | is $info->invocant, undef; 29 | is $info->slurpy, undef; 30 | is $info->positional_optional, 0; 31 | is $info->named_required, 0; 32 | is $info->named_optional, 0; 33 | my @req = $info->positional_required; 34 | is @req, 3; 35 | is $req[0]->name, '$n'; 36 | ok $req[0]->type->equals(Int); 37 | is $req[1]->name, '$f'; 38 | ok $req[1]->type->equals(CodeRef); 39 | is $req[2]->name, '$x'; 40 | is $req[2]->type, undef; 41 | } 42 | 43 | like exception { foo("ermagerd", fun (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; 44 | like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; 45 | 46 | fun bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } 47 | 48 | is bar(21), 42; 49 | { 50 | my $info = Function::Parameters::info \&bar; 51 | is $info->invocant, undef; 52 | is $info->slurpy, undef; 53 | is $info->positional_optional, 0; 54 | is $info->named_required, 0; 55 | is $info->named_optional, 0; 56 | my @req = $info->positional_required; 57 | is @req, 1; 58 | is $req[0]->name, '$whoa'; 59 | ok $req[0]->type->equals(Int); 60 | } 61 | 62 | { 63 | my $info = Function::Parameters::info(fun ( ( ArrayRef [ Int | CodeRef ])@nom) {}); 64 | is $info->invocant, undef; 65 | is $info->positional_required, 0; 66 | is $info->positional_optional, 0; 67 | is $info->named_required, 0; 68 | is $info->named_optional, 0; 69 | my $slurpy = $info->slurpy; 70 | is $slurpy->name, '@nom'; 71 | ok $slurpy->type->equals(ArrayRef[Int|CodeRef]); 72 | } 73 | 74 | { 75 | my $phase = 'runtime'; 76 | BEGIN { $phase = 'A'; } 77 | fun 78 | baz 79 | ( 80 | ( 81 | is 82 | ( 83 | $phase 84 | ++ 85 | , 86 | 'A' 87 | ) 88 | , 89 | Int 90 | ) 91 | : 92 | $marco 93 | , 94 | ( 95 | is 96 | ( 97 | $phase 98 | ++ 99 | , 100 | 'B' 101 | ) 102 | , 103 | 104 | ArrayRef[Str] 105 | ) 106 | : 107 | $polo 108 | ) 109 | { 110 | [ 111 | $marco 112 | , 113 | $polo 114 | ] 115 | } 116 | BEGIN { is $phase, 'C'; } 117 | is $phase, 'runtime'; 118 | 119 | is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; 120 | 121 | my $info = Function::Parameters::info \&baz; 122 | is $info->invocant, undef; 123 | is $info->slurpy, undef; 124 | is $info->positional_required, 0; 125 | is $info->positional_optional, 0; 126 | is $info->named_optional, 0; 127 | my @req = $info->named_required; 128 | is @req, 2; 129 | is $req[0]->name, '$marco'; 130 | ok $req[0]->type->equals(Int); 131 | is $req[1]->name, '$polo'; 132 | ok $req[1]->type->equals(ArrayRef[Str]); 133 | } 134 | -------------------------------------------------------------------------------- /t/types_moosex_2.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More 6 | eval { require MooseX::Types } 7 | ? (tests => 34) 8 | : (skip_all => "MooseX::Types required for testing types") 9 | ; 10 | use Test::Fatal; 11 | use MooseX::Types::Moose qw(Int Str ArrayRef CodeRef); 12 | 13 | use Function::Parameters qw(:strict); 14 | 15 | 16 | fun foo(Int $n, CodeRef $f, $x) { 17 | $x = $f->($x) for 1 .. $n; 18 | $x 19 | } 20 | 21 | is foo(0, fun (@) {}, undef), undef; 22 | is foo(0, fun (@) {}, "o hai"), "o hai"; 23 | is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; 24 | is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; 25 | 26 | { 27 | my $info = Function::Parameters::info \&foo; 28 | is $info->invocant, undef; 29 | is $info->slurpy, undef; 30 | is $info->positional_optional, 0; 31 | is $info->named_required, 0; 32 | is $info->named_optional, 0; 33 | my @req = $info->positional_required; 34 | is @req, 3; 35 | is $req[0]->name, '$n'; 36 | ok $req[0]->type->equals(Int); 37 | is $req[1]->name, '$f'; 38 | ok $req[1]->type->equals(CodeRef); 39 | is $req[2]->name, '$x'; 40 | is $req[2]->type, undef; 41 | } 42 | 43 | like exception { foo("ermagerd", fun (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; 44 | like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; 45 | 46 | fun bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } 47 | 48 | is bar(21), 42; 49 | { 50 | my $info = Function::Parameters::info \&bar; 51 | is $info->invocant, undef; 52 | is $info->slurpy, undef; 53 | is $info->positional_optional, 0; 54 | is $info->named_required, 0; 55 | is $info->named_optional, 0; 56 | my @req = $info->positional_required; 57 | is @req, 1; 58 | is $req[0]->name, '$whoa'; 59 | ok $req[0]->type->equals(Int); 60 | } 61 | 62 | { 63 | my $info = Function::Parameters::info(fun ( ArrayRef [ Int | CodeRef ]@nom) {}); 64 | is $info->invocant, undef; 65 | is $info->positional_required, 0; 66 | is $info->positional_optional, 0; 67 | is $info->named_required, 0; 68 | is $info->named_optional, 0; 69 | my $slurpy = $info->slurpy; 70 | is $slurpy->name, '@nom'; 71 | ok $slurpy->type->equals(ArrayRef[Int|CodeRef]); 72 | } 73 | -------------------------------------------------------------------------------- /t/types_msg.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More tests => 13; 6 | use Test::Fatal; 7 | 8 | use Function::Parameters qw(:std :modifiers); 9 | 10 | { 11 | package DefinedType; 12 | 13 | method new($class:) { bless {}, $class } 14 | 15 | method check($x) { defined $x } 16 | 17 | method get_message($ ) { "UNDEFINED" } 18 | } 19 | 20 | use constant Defined => DefinedType->new; 21 | 22 | my %stash; 23 | fun around($name, $coderef) { 24 | $stash{$name} = $coderef; 25 | } 26 | 27 | fun foo(Defined $x, $whatevs, Defined $y, Defined @z) {} 28 | like exception { foo(undef, undef, undef, undef) }, qr{\A\QIn fun foo: parameter 1 (\E\$x\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 29 | like exception { foo('def', undef, undef, undef) }, qr{\A\QIn fun foo: parameter 3 (\E\$y\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 30 | like exception { foo('def', undef, 'def', undef) }, qr{\A\QIn fun foo: parameter 4 (\E\@z\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 31 | like exception { foo('def', undef, 'def', 'def', undef) }, qr{\A\QIn fun foo: parameter 4 (\E\@z\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 32 | is exception { foo('def', undef, 'def') }, undef; 33 | 34 | method bar(Defined $this: Defined $x) {} 35 | like exception { bar(undef, undef) }, qr{\A\QIn method bar: invocant (\E\$this\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 36 | like exception { bar('def', undef) }, qr{\A\QIn method bar: parameter 1 (\E\$x\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 37 | is exception { bar('def', 'def') }, undef; 38 | 39 | around baz(Defined $self, Defined $orig: Defined $x, Defined $y) {} 40 | like exception { $stash{baz}(undef, undef, undef, undef) }, qr{\A\QIn around baz: invocant 1 (\E\$self\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 41 | like exception { $stash{baz}('def', undef, undef, undef) }, qr{\A\QIn around baz: invocant 2 (\E\$orig\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 42 | like exception { $stash{baz}('def', 'def', undef, undef) }, qr{\A\QIn around baz: parameter 1 (\E\$x\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 43 | like exception { $stash{baz}('def', 'def', 'def', undef) }, qr{\A\QIn around baz: parameter 2 (\E\$y\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; 44 | is exception { $stash{baz}('def', 'def', 'def', 'def') }, undef; 45 | -------------------------------------------------------------------------------- /t/types_parse.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More; 6 | 7 | use Function::Parameters qw(:strict); 8 | 9 | ok !eval 'fun foo(X[['; 10 | like $@, qr/missing type name/; 11 | 12 | done_testing; 13 | -------------------------------------------------------------------------------- /t/unicode.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use utf8; 3 | use Test::More tests => 19; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters qw(:lax); 9 | 10 | fun hörps($x) { $x * 2 } 11 | fun drau($spın̈al_tap) { $spın̈al_tap * 3 } 12 | fun ääää($éééééé) { $éééééé * 4 } 13 | 14 | is hörps(10), 20; 15 | is drau(11), 33; 16 | is ääää(12), 48; 17 | 18 | is eval('fun á(){} 1'), 1; 19 | is á(42), undef; 20 | 21 | is eval('fun ́(){} 1'), undef; 22 | like $@, qr/ parameter list/; 23 | 24 | is eval(q), undef; 25 | like $@, qr/ parameter list/; 26 | 27 | is eval('fun ::hi(){} 1'), 1; 28 | is hi(42), undef; 29 | 30 | is eval('fun 123(){} 1'), undef; 31 | like $@, qr/ parameter list/; 32 | 33 | is eval('fun main::234(){} 1'), undef; 34 | like $@, qr/ parameter list/; 35 | 36 | is eval('fun m123(){} 1'), 1; 37 | is m123(42), undef; 38 | 39 | is eval('fun ::m234(){} 1'), 1; 40 | is m234(42), undef; 41 | -------------------------------------------------------------------------------- /t/unicode2.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use utf8; 3 | use Test::More tests => 25; 4 | 5 | use warnings FATAL => 'all'; 6 | use strict; 7 | 8 | use Function::Parameters { pŕöç => 'function_strict' }; 9 | 10 | pŕöç hörps($x) { $x * 2 } 11 | pŕöç drau($spın̈al_tap) { $spın̈al_tap * 3 } 12 | pŕöç ääää($éééééé) { $éééééé * 4 } 13 | 14 | is hörps(10), 20; 15 | is drau(11), 33; 16 | is ääää(12), 48; 17 | 18 | is eval('pŕöç á(){} 1'), 1; 19 | is á(), undef; 20 | 21 | is eval('pŕöç ́(){} 1'), undef; 22 | like $@, qr/pŕöç.* parameter list/s; 23 | 24 | is eval(q), undef; 25 | like $@, qr/pŕöç.* parameter list/s; 26 | 27 | is eval('pŕöç ::hi($z){} 1'), 1; 28 | is hi(42), undef; 29 | 30 | is eval('pŕöç 123(){} 1'), undef; 31 | like $@, qr/pŕöç.* parameter list/s; 32 | 33 | is eval('pŕöç main::234(){} 1'), undef; 34 | like $@, qr/pŕöç.* parameter list/s; 35 | 36 | is eval('pŕöç m123($z){} 1'), 1; 37 | is m123(42), undef; 38 | 39 | is eval('pŕöç ::m234($z){} 1'), 1; 40 | is m234(42), undef; 41 | 42 | is eval { ääää }, undef; 43 | like $@, qr/pŕöç.*ääää/s; 44 | 45 | for my $info (Function::Parameters::info \&ääää) { 46 | is $info->keyword, 'pŕöç'; 47 | is join(' ', $info->positional_required), '$éééééé'; 48 | } 49 | 50 | for my $info (Function::Parameters::info \&drau) { 51 | is $info->keyword, 'pŕöç'; 52 | is join(' ', $info->positional_required), '$spın̈al_tap'; 53 | } 54 | -------------------------------------------------------------------------------- /xt/foreign/Fun/anon.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | use Function::Parameters; 7 | 8 | my $fun = fun ($x, $y) { $x * $y }; 9 | 10 | is($fun->(3, 4), 12); 11 | 12 | my $fun2 = fun ($z, $w = 10) { $z / $w }; 13 | 14 | is($fun2->(60), 6); 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /xt/foreign/Fun/basic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | use Function::Parameters; 7 | 8 | fun mul ($x, $y) { 9 | return $x * $y; 10 | } 11 | 12 | is(mul(3, 4), 12); 13 | 14 | fun sum (@nums) { 15 | my $sum; 16 | for my $num (@nums) { 17 | $sum += $num; 18 | } 19 | return $sum; 20 | } 21 | 22 | is(sum(1, 2, 3, 4), 10); 23 | 24 | { 25 | package Foo; 26 | use Function::Parameters; 27 | fun foo() { } 28 | } 29 | 30 | ok(exists $Foo::{foo}); 31 | 32 | done_testing; 33 | -------------------------------------------------------------------------------- /xt/foreign/Fun/closure-proto.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | use Test::More; 6 | 7 | use Function::Parameters; 8 | 9 | { 10 | my $x = 10; 11 | 12 | fun bar ($y) { 13 | $x * $y 14 | } 15 | } 16 | 17 | is(bar(3), 30); 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /xt/foreign/Fun/compile-time.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | use Function::Parameters; 7 | 8 | is(foo(), "FOO"); 9 | 10 | fun foo() { "FOO" } 11 | 12 | done_testing; 13 | -------------------------------------------------------------------------------- /xt/foreign/Fun/defaults.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | 6 | use Function::Parameters qw(:lax); 7 | 8 | fun foo ($x, $y = 5) { 9 | return $x + $y; 10 | } 11 | 12 | is(foo(3, 4), 7); 13 | is(foo(3), 8); 14 | { 15 | my $warning; 16 | local $SIG{__WARN__} = sub { $warning = $_[0] }; 17 | is(foo, 5); 18 | like($warning, qr/Use of uninitialized value \$x in addition \(\+\)/); 19 | } 20 | 21 | fun bar ($baz, $quux = foo(1) * 2, $blorg = sub { return "ran sub, got " . $_[0] }) { 22 | $blorg->($baz + $quux); 23 | } 24 | 25 | is(bar(3, 4, sub { $_[0] }), 7); 26 | is(bar(5, 6), "ran sub, got 11"); 27 | is(bar(7), "ran sub, got 19"); 28 | { 29 | my $warning; 30 | local $SIG{__WARN__} = sub { $warning = $_[0] }; 31 | is(bar, "ran sub, got 12"); 32 | like($warning, qr/Use of uninitialized value \$baz in addition \(\+\)/); 33 | } 34 | 35 | fun baz ($a, $b = our $FOO) { 36 | return "$a $b"; 37 | } 38 | 39 | { 40 | no warnings 'misc'; # 'not imported' warning because we use $FOO later 41 | eval '$FOO'; 42 | like($@, qr/Global symbol "\$FOO" requires explicit package name/, "doesn't leak scope"); 43 | } 44 | 45 | our $FOO = "abc"; 46 | is(baz("123"), "123 abc"); 47 | 48 | fun goorch ($x, $y = []) { 49 | return $y 50 | } 51 | 52 | my $goorch_y_1 = goorch( 10 ); 53 | my $goorch_y_2 = goorch( 10 ); 54 | 55 | isnt($goorch_y_1, $goorch_y_2, '... not the same reference'); 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /xt/foreign/Fun/name.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | use Carp; 7 | 8 | my $file = __FILE__; 9 | my $line = __LINE__; 10 | 11 | { 12 | package Foo; 13 | use Function::Parameters; 14 | fun foo ($x, $y) { 15 | Carp::confess "$x $y"; 16 | } 17 | 18 | eval { 19 | foo("abc", "123"); 20 | }; 21 | 22 | my $line_confess = $line + 6; 23 | my $line_foo = $line + 10; 24 | 25 | ::like($@, qr/^abc 123 at \Q$file\E line $line_confess\.?\n\tFoo::foo\((["'])abc\1, 123\) called at \Q$file\E line $line_foo/); 26 | } 27 | 28 | SKIP: { skip "Sub::Name required", 1 unless eval { require Sub::Name }; 29 | 30 | { 31 | package Bar; 32 | use Function::Parameters; 33 | *bar = Sub::Name::subname(bar => fun ($a, $b) { Carp::confess($a + $b) }); 34 | 35 | eval { 36 | bar(4, 5); 37 | }; 38 | 39 | my $line_confess = $line + 24; 40 | my $line_bar = $line + 27; 41 | 42 | ::like($@, qr/^9 at \Q$file\E line $line_confess\.?\n\tBar::bar\(4, 5\) called at \Q$file\E line $line_bar/); 43 | } 44 | 45 | } 46 | 47 | done_testing; 48 | -------------------------------------------------------------------------------- /xt/foreign/Fun/package.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | use Function::Parameters; 7 | 8 | fun Foo::foo ($x, $y) { 9 | $x + $y; 10 | } 11 | 12 | ok(!main->can('foo')); 13 | ok(Foo->can('foo')); 14 | is(Foo::foo(1, 2), 3); 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /xt/foreign/Fun/recursion.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | BEGIN { 7 | if (!eval { require 5.016; 1 }) { 8 | plan skip_all => "This test requires 5.16"; 9 | } 10 | } 11 | 12 | use 5.016; 13 | 14 | use Function::Parameters; 15 | 16 | fun fact ($n) { 17 | if ($n < 2) { 18 | return 1; 19 | } 20 | return $n * __SUB__->($n - 1); 21 | } 22 | 23 | is(fact(5), 120); 24 | 25 | is(fun ($n = 8) { $n < 2 ? 1 : $n * __SUB__->($n - 1) }->(), 40320); 26 | 27 | fun fact2 ($n) { 28 | if ($n < 2) { 29 | return 1; 30 | } 31 | return $n * fact2($n - 1); 32 | } 33 | 34 | is(fact2(5), 120); 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /xt/foreign/Fun/slurpy-syntax-errors.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | use Function::Parameters; 7 | 8 | { 9 | eval 'fun ( $foo, @bar, $baz ) { return [] }'; 10 | ok $@, '... got an error'; 11 | } 12 | 13 | { 14 | eval 'fun ( $foo, %bar, $baz ) { return {} }'; 15 | ok $@, '... got an error'; 16 | } 17 | 18 | { 19 | eval 'fun ( $foo, @bar, %baz ) { return [] }'; 20 | ok $@, '... got an error'; 21 | } 22 | 23 | { 24 | eval 'fun ( $foo, %bar, @baz ) { return {} }'; 25 | ok $@, '... got an error'; 26 | } 27 | 28 | done_testing; 29 | -------------------------------------------------------------------------------- /xt/foreign/Fun/slurpy.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | use Function::Parameters; 7 | 8 | fun test_array ( $foo, @bar ) { 9 | return [ $foo, @bar ]; 10 | } 11 | 12 | fun test_hash ( $foo, %bar ) { 13 | return { foo => $foo, %bar }; 14 | } 15 | 16 | is_deeply( test_array( 1, 2 .. 10 ), [ 1, 2 .. 10 ], '... slurpy array worked' ); 17 | is_deeply( test_hash( 1, ( two => 2, three => 3 ) ), { foo => 1, two => 2, three => 3 }, '... slurpy hash worked' ); 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /xt/foreign/Fun/state.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | use Test::More; 6 | 7 | use 5.10.0; 8 | use Function::Parameters; 9 | 10 | fun bar ($y) { 11 | state $x = 10; 12 | $x * $y; 13 | } 14 | 15 | is(bar(3), 30); 16 | 17 | done_testing; 18 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures-Simple/02-use.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More tests => 7; 6 | BEGIN { use_ok 'Function::Parameters' } 7 | 8 | { 9 | package My::Obj; 10 | use Function::Parameters qw(:strict); 11 | 12 | method make($class: %opts) { 13 | bless {%opts}, $class; 14 | } 15 | method first() : lvalue { 16 | $self->{first}; 17 | } 18 | method second() { 19 | $self->first + 1; 20 | } 21 | method nth($inc) { 22 | $self->first + $inc; 23 | } 24 | } 25 | 26 | my $o = My::Obj->make(first => 1); 27 | is $o->first, 1; 28 | is $o->second, 2; 29 | is $o->nth(10), 11; 30 | 31 | $o->first = 10; 32 | 33 | is $o->first, 10; 34 | is $o->second, 11; 35 | is $o->nth(10), 20; 36 | 37 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures-Simple/03-config.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More tests => 3; 6 | 7 | # testing that we can install several different keywords into the same scope 8 | { 9 | package Monster; 10 | 11 | use Function::Parameters; 12 | use Function::Parameters { 13 | action => { defaults => 'method', shift => '$monster' }, 14 | constructor => { defaults => 'method', shift => '$species' }, 15 | function => 'function', 16 | }; 17 | 18 | constructor spawn (@) { 19 | bless {@_}, $species; 20 | } 21 | 22 | action speak (@words) { 23 | return join ' ', $monster->{name}, $monster->{voices}, @words; 24 | } 25 | 26 | action attack ($me: $you) { 27 | $you->take_damage($me->{strength}); 28 | } 29 | 30 | method take_damage ($hits) { 31 | $self->{hitpoints} = calculate_damage($self->{hitpoints}, $hits); 32 | if($self->{hitpoints} <= 0) { 33 | $self->{is_dead} = 1; 34 | } 35 | } 36 | 37 | function calculate_damage ($hitpoints, $damage) { 38 | return $hitpoints - $damage; 39 | } 40 | } 41 | 42 | package main; 43 | my $hellhound = Monster->spawn( name => "Hellhound", voices => "barks", strength => 22, hitpoints => 100 ); 44 | is $hellhound->speak(qw(arf arf)), 'Hellhound barks arf arf'; 45 | 46 | my $human = Monster->spawn( name => 'human', voices => 'whispers', strength => 4, hitpoints => 16 ); 47 | $hellhound->attack($human); 48 | is $human->{is_dead}, 1; 49 | is $human->{hitpoints}, -6; 50 | 51 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures-Simple/RT80505.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 2; 5 | 6 | { 7 | package My::Obj; 8 | use Function::Parameters qw(:strict); 9 | method new () { 10 | bless {}, $self; 11 | } 12 | method foo ( 13 | $x, # the X 14 | $y, # the Y 15 | ) { 16 | return $x * $y; 17 | } 18 | my $bar = method ( 19 | $P, # comment 20 | $Q, # comment 21 | ) { # comment 22 | $P + $Q 23 | }; 24 | } 25 | 26 | my $o = My::Obj->new; 27 | is $o->foo(4, 5), 20, "should allow comments and newlines in proto"; 28 | is __LINE__, 28, "should leave line number intact"; 29 | 30 | __END__ 31 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures-Simple/RT80507.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Function::Parameters qw(:strict); 5 | use Test::More tests => 2; 6 | 7 | { 8 | my $uniq = 0; 9 | 10 | method fresh_name() { 11 | $self->prefix . $uniq++ 12 | } 13 | } 14 | 15 | method prefix() { 16 | $self->{prefix} 17 | } 18 | 19 | my $o = bless {prefix => "foo_" }, main::; 20 | is $o->fresh_name, 'foo_0'; 21 | 22 | #TODO: { 23 | # local $TODO = 'do not know how to handle the scope change in line 7'; 24 | is __LINE__, 24; 25 | #} 26 | 27 | __END__ 28 | 29 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures-Simple/RT80508.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 1; 5 | 6 | { 7 | package My::Obj; 8 | use Function::Parameters qw(:strict); 9 | 10 | method with_space ( $this : $that ) { 11 | return ($this, $that); 12 | } 13 | } 14 | 15 | is_deeply [ My::Obj->with_space (1) ], [ 'My::Obj', 1 ], 'space between invocant name and colon should parse'; 16 | 17 | __END__ 18 | 19 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures-Simple/RT80510.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 2; 5 | 6 | use Function::Parameters qw(:lax); 7 | 8 | fun empty ($x) {} 9 | 10 | is scalar empty(1), undef, "empty func returns nothing (scalar context)"; 11 | is_deeply [empty(1,2)], [], "empty func returns nothing (list context)"; 12 | 13 | __END__ 14 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/anon.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More 'no_plan'; 6 | 7 | { 8 | package Stuff; 9 | 10 | use Test::More; 11 | use Function::Parameters qw(:strict); 12 | 13 | method echo($arg) { 14 | return $arg 15 | } 16 | 17 | my $method = method ($arg) { 18 | return $self->echo($arg) 19 | }; 20 | 21 | is( Stuff->$method("foo"), "foo" ); 22 | } 23 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/array_param.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More tests => 3; 6 | 7 | { 8 | package Bla; 9 | use Test::More; 10 | use Function::Parameters qw(:strict); 11 | 12 | method new ($class:) { 13 | bless {}, $class; 14 | } 15 | 16 | method array_param_at_end ($a, $b, @c) { 17 | return "$a|$b|@c"; 18 | } 19 | 20 | eval q{ 21 | method two_array_params ($a, @b, @c) {} 22 | }; 23 | like($@, qr{\btwo_array_params\b.+\@c\b.+\@b\b}, "Two array params"); 24 | 25 | eval q{ 26 | method two_slurpy_params ($a, %b, $c, @d, $e) {} 27 | }; 28 | like($@, qr{\btwo_slurpy_params\b.+\$c\b.+%b\b}, "Two slurpy params"); 29 | } 30 | 31 | is(Bla->new->array_param_at_end(1, 2, 3, 4), "1|2|3 4", "Array parameter at end"); 32 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/at_underscore.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More; 6 | 7 | { 8 | package Foo; 9 | use Function::Parameters qw(:strict); 10 | 11 | fun foo(@) { return @_ } 12 | method bar(@) { return @_ } 13 | } 14 | 15 | is_deeply [Foo::foo()], []; 16 | is_deeply [Foo::foo(23, 42)], [23, 42]; 17 | is_deeply [Foo->bar()], []; 18 | is_deeply [Foo->bar(23, 42)], [23, 42]; 19 | 20 | done_testing; 21 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/attributes.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More 'no_plan'; 6 | 7 | use attributes; 8 | 9 | { 10 | package Stuff; 11 | 12 | use Test::More; 13 | use Function::Parameters qw(:strict); 14 | 15 | method echo($arg) { 16 | return $arg; 17 | } 18 | 19 | is( Stuff->echo(42), 42 ); 20 | is_deeply( [attributes::get \&echo], ['method'] ); 21 | } 22 | 23 | 24 | { 25 | package Foo; 26 | 27 | use Test::More; 28 | use Function::Parameters qw(:strict); 29 | 30 | my $code = fun () : method {}; 31 | is_deeply( [attributes::get $code], ['method'] ); 32 | } 33 | 34 | 35 | { 36 | package Things; 37 | 38 | use Function::Parameters qw(:strict); 39 | 40 | my $attrs; 41 | my $cb_called; 42 | 43 | sub MODIFY_CODE_ATTRIBUTES { 44 | my ($pkg, $code, @attrs) = @_; 45 | $cb_called = 1; 46 | $attrs = \@attrs; 47 | return (); 48 | } 49 | 50 | method moo($foo, $bar) : Bar Baz(fubar) { 51 | } 52 | 53 | # Torture test for the attribute handling. 54 | method foo() 55 | : 56 | Bar 57 | :Moo(:Ko{oh) 58 | : Baz(fu{bar:): { return {} } 59 | 60 | ::ok($cb_called, 'attribute handler got called'); 61 | ::is_deeply($attrs, [qw/Bar Moo(:Ko{oh) Baz(fu{bar:)/], '... with the right attributes'); 62 | } 63 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/begin.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | package Foo; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use Test::More; 9 | use Test::Fatal; 10 | 11 | use Function::Parameters { method => { defaults => 'method', runtime => 0 } }; 12 | 13 | 14 | our $phase; 15 | BEGIN { $phase = 'compile-time' } 16 | INIT { $phase = 'run-time' } 17 | 18 | 19 | sub method_defined 20 | { 21 | my ($method) = @_; 22 | 23 | local $Test::Builder::Level = $Test::Builder::Level + 1; 24 | is exception { Foo->$method }, undef, "method $method is defined at $phase"; 25 | } 26 | 27 | sub method_undefined 28 | { 29 | my ($method) = @_; 30 | 31 | local $Test::Builder::Level = $Test::Builder::Level + 1; 32 | like exception { Foo->$method }, qr/Can't locate object method/, "method $method is undefined at $phase"; 33 | } 34 | 35 | 36 | # The default configuration with compile at BEGIN on. 37 | method top_level_default() {} 38 | 39 | # Turn it off. 40 | use Function::Parameters { method => { defaults => 'method', runtime => 1 } }; 41 | method top_level_off() {} 42 | 43 | # And on again. 44 | use Function::Parameters { method => { defaults => 'method', runtime => 0 } }; 45 | method top_level_on() {} 46 | 47 | # Now turn it off inside a lexical scope 48 | { 49 | use Function::Parameters { method => { defaults => 'method', runtime => 1 } }; 50 | method inner_scope_off() {} 51 | } 52 | 53 | # And it's restored. 54 | method outer_scope_on() {} 55 | 56 | 57 | # at compile-time, some should be defined and others shouldn't be 58 | BEGIN { 59 | method_defined('top_level_default'); 60 | method_undefined('top_level_off'); 61 | method_defined('top_level_on'); 62 | method_undefined('inner_scope_off'); 63 | method_defined('outer_scope_on'); 64 | } 65 | 66 | # by run-time, they should _all_ be defined 67 | method_defined('top_level_default'); 68 | method_defined('top_level_off'); 69 | method_defined('top_level_on'); 70 | method_defined('inner_scope_off'); 71 | method_defined('outer_scope_on'); 72 | 73 | 74 | done_testing; 75 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/caller.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | # Test that caller() works 6 | 7 | { 8 | package Foo; 9 | 10 | use Test::More 'no_plan'; 11 | 12 | use Function::Parameters qw(:strict); 13 | 14 | sub sub_caller { 15 | my($self, $level) = @_; 16 | #line 13 17 | return caller($level); 18 | } 19 | 20 | 21 | sub sub_caller2 { 22 | my($self, $level) = @_; 23 | #line 20 24 | return $self->sub_caller($level); 25 | } 26 | 27 | 28 | method method_caller($level) { 29 | #line 13 30 | return caller($level); 31 | } 32 | 33 | 34 | method method_caller2($level) { 35 | #line 20 36 | return $self->method_caller($level); 37 | } 38 | 39 | #line 36 40 | my @expected = Foo->sub_caller2(0); 41 | my @expected2 = Foo->sub_caller2(1); 42 | 43 | #line 36 44 | my @have = Foo->method_caller2(0); 45 | my @have2 = Foo->method_caller2(1); 46 | 47 | $expected[3] = 'Foo::method_caller'; 48 | $expected2[3] = 'Foo::method_caller2'; 49 | 50 | is_deeply([@have[0..7]], [@expected[0..7]]); 51 | is_deeply([@have2[0..7]], [@expected2[0..7]]); 52 | 53 | # hints and bitmask change and are twitchy so I'm just going to 54 | # check that they're there. 55 | isnt $have[8], undef; 56 | isnt $have2[8], undef; 57 | isnt $have[9], undef; 58 | isnt $have2[9], undef; 59 | } 60 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/comments.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More 6 | eval { require Moose } 7 | ? (tests => 5) 8 | : (skip_all => "Moose required for testing types") 9 | ; 10 | use Test::Fatal; 11 | 12 | use Function::Parameters { 13 | fun => { defaults => 'function', reify_type => 'moose' }, 14 | method => { defaults => 'method', reify_type => 'moose' }, 15 | }; 16 | 17 | 18 | is exception 19 | { 20 | eval q{ 21 | fun foo ( 22 | Int :$foo, # this is foo 23 | Int :$bar # this is bar 24 | ) 25 | { 26 | } 27 | 28 | 1; 29 | } or die; 30 | }, undef, 31 | 'survives comments within the signature itself'; 32 | 33 | is exception 34 | { 35 | eval q{ 36 | fun bar ( Int :$foo, Int :$bar ) # this is a signature 37 | { 38 | } 39 | 40 | 1; 41 | } or die; 42 | }, undef, 43 | 'survives comments between signature and open brace'; 44 | 45 | #SKIP: 46 | #{ 47 | # eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; 48 | # 49 | is exception 50 | { 51 | eval q{ 52 | # use MooseX::Declare; 53 | # use Method::Signatures::Modifiers; 54 | 55 | package Foo 56 | { 57 | method bar ( Int :$foo, Int :$bar ) # this is a signature 58 | { 59 | } 60 | } 61 | 62 | 1; 63 | } or die; 64 | }, undef, 65 | 'survives comments between signature and open brace'; 66 | #} 67 | 68 | 69 | #TODO: { 70 | # local $TODO = "closing paren in comment: rt.cpan.org 81364"; 71 | 72 | is exception 73 | { 74 | # # When this fails, it produces 'Variable "$bar" is not imported' 75 | # # This is expected to fail, don't bother the user. 76 | # no warnings; 77 | eval q{ 78 | fun special_comment ( 79 | $foo, # ) 80 | $bar 81 | ) 82 | { 42 } 83 | 1; 84 | } or die; 85 | }, undef, 86 | 'closing paren in comment'; 87 | is eval q[special_comment("this", "that")], 42; 88 | #} 89 | 90 | #done_testing(); 91 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/defaults.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More 'no_plan'; 6 | 7 | { 8 | package Stuff; 9 | 10 | use Test::More; 11 | use Function::Parameters qw(:strict); 12 | 13 | method add($this = 23, $that = 42) { 14 | return $this + $that; 15 | } 16 | 17 | method minus($this = 23, $that = 42) { 18 | return $this - $that; 19 | } 20 | 21 | is( Stuff->add(), 23 + 42 ); 22 | is( Stuff->add(99), 99 + 42 ); 23 | is( Stuff->add(2,3), 5 ); 24 | 25 | is( Stuff->minus(), 23 - 42 ); 26 | is( Stuff->minus(99), 99 - 42 ); 27 | is( Stuff->minus(2, 3), 2 - 3 ); 28 | 29 | 30 | # Test that undef overrides defaults 31 | method echo($message = "what?") { 32 | return $message 33 | } 34 | 35 | is( Stuff->echo(), "what?" ); 36 | is( Stuff->echo(undef), undef ); 37 | is( Stuff->echo("who?"), 'who?' ); 38 | 39 | 40 | # Test that you can reference earlier args in a default 41 | method copy_cat($this, $that = $this) { 42 | return $that; 43 | } 44 | 45 | is( Stuff->copy_cat("wibble"), "wibble" ); 46 | is( Stuff->copy_cat(23, 42), 42 ); 47 | } 48 | 49 | 50 | { 51 | package Bar; 52 | use Test::More; 53 | use Function::Parameters qw(:strict); 54 | 55 | method hello($msg = "Hello, world!") { 56 | return $msg; 57 | } 58 | 59 | is( Bar->hello, "Hello, world!" ); 60 | is( Bar->hello("Greetings!"), "Greetings!" ); 61 | 62 | 63 | method hi($msg = q,Hi,) { 64 | return $msg; 65 | } 66 | 67 | is( Bar->hi, "Hi" ); 68 | is( Bar->hi("Yo"), "Yo" ); 69 | 70 | 71 | # method list(@args = (1,2,3)) { 72 | # return @args; 73 | # } 74 | # 75 | # is_deeply [Bar->list()], [1,2,3]; 76 | 77 | 78 | method code($num, $code = sub { $num + 2 }) { 79 | return $code->(); 80 | } 81 | 82 | is( Bar->code(42), 44 ); 83 | } 84 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/error_interruption.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use FindBin; 6 | use lib "$FindBin::Bin/lib"; 7 | 8 | use Test::More do { 9 | # Trying to load modules (for parameter types) after a syntax error can 10 | # fail, hiding the real error message. To properly test this, we need to 11 | # know Moose is available, but we can't load it up front. 12 | my $have_moose; 13 | for my $dir (@INC) { 14 | if (-r "$dir/Moose/Util/TypeConstraints.pm") { 15 | $have_moose = 1; 16 | last; 17 | } 18 | } 19 | $have_moose 20 | ? () 21 | : (skip_all => "Moose required for testing types") 22 | }; 23 | use Test::Fatal; 24 | 25 | like exception { require BarfyDie }, 26 | qr/requires explicit package name/, 27 | "F:P doesn't interrupt real compilation error"; 28 | 29 | done_testing(); 30 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/func.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More tests => 1; 6 | 7 | use Function::Parameters qw(:strict); 8 | 9 | fun echo($arg) { 10 | return $arg; 11 | } 12 | 13 | is echo(42), 42, "basic func"; 14 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/into.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | # Importing always affects the currently compiling scope. 6 | 7 | package Foo; 8 | 9 | use Test::More 'no_plan'; 10 | 11 | BEGIN { 12 | package Bar; 13 | require Function::Parameters; 14 | Function::Parameters->import; 15 | } 16 | 17 | is( Foo->foo(42), 42 ); 18 | 19 | method foo ($arg) { 20 | return $arg; 21 | } 22 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/invocant.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Test that you can change the invocant. 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use Test::More 9 | eval { require Moose } 10 | ? (tests => 6) 11 | : (skip_all => "Moose required for testing types") 12 | ; 13 | 14 | our $skip_no_invocants; 15 | 16 | { 17 | package Stuff; 18 | 19 | use Test::More; 20 | use Function::Parameters { 21 | fun => { defaults => 'function', reify_type => 'moose' }, 22 | method => { defaults => 'method', reify_type => 'moose' }, 23 | }; 24 | 25 | sub new { bless {}, __PACKAGE__ } 26 | 27 | method bar($arg) { 28 | return ref $arg || $arg; 29 | } 30 | 31 | method invocant($class:) { 32 | $class->bar(0); 33 | } 34 | 35 | method with_arg($class: $arg) { 36 | $class->bar($arg); 37 | } 38 | 39 | method without_space($class:$arg) { 40 | $class->bar($arg); 41 | } 42 | 43 | eval q{ 44 | 45 | method no_invocant_class_type(Foo::Bar $arg) { 46 | $self->bar($arg); 47 | } 48 | 49 | method no_invocant_named_param(Foo :$arg) { 50 | $self->bar($arg); 51 | } 52 | 53 | }; 54 | is $@, '', 'compiles without invocant'; 55 | } 56 | 57 | { 58 | package Foo; 59 | sub new { bless {}, __PACKAGE__ } 60 | } 61 | 62 | { 63 | package Foo::Bar; 64 | sub new { bless {}, __PACKAGE__ } 65 | } 66 | 67 | 68 | is( Stuff->invocant, 0 ); 69 | is( Stuff->with_arg(42), 42 ); 70 | is( Stuff->without_space(42), 42 ); 71 | 72 | my $stuff = Stuff->new; 73 | is( $stuff->no_invocant_class_type(Foo::Bar->new), 'Foo::Bar' ); 74 | is( $stuff->no_invocant_named_param(arg => Foo->new), 'Foo' ); 75 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/larna.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More; 6 | 7 | use Function::Parameters qw(:strict); 8 | 9 | { 10 | my $a; 11 | ok eval q{ $a = [ fun () {}, 1 ]; 1 }, 'anonymous function in list is okay' 12 | or diag "eval error: $@"; 13 | is ref $a->[0], "CODE"; 14 | is $a->[1], 1; 15 | } 16 | 17 | { 18 | my $a; 19 | ok eval q{ $a = [ method () {}, 1 ]; 1 }, 'anonymous method in list is okay' 20 | or diag "eval error: $@"; 21 | is ref $a->[0], "CODE"; 22 | is $a->[1], 1; 23 | } 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/lib/Bad.pm: -------------------------------------------------------------------------------- 1 | package Bad; 2 | 3 | use strict; 4 | use warnings; 5 | use Function::Parameters qw(:strict); 6 | 7 | ## $info->{} should be $info{} 8 | method meth1 ($foo) { 9 | my %info; 10 | $info->{xpto} = 1; 11 | } 12 | 13 | method meth2 ($bar) {} 14 | 15 | 'ok' 16 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/lib/BarfyDie.pm: -------------------------------------------------------------------------------- 1 | # For use with t/error_interruption.t 2 | 3 | package BarfyDie; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Function::Parameters qw(:strict); 9 | 10 | 11 | # This _should_ produce a simple error like the following: 12 | # Global symbol "$foo" requires explicit package name at t/lib/BarfyDie.pm line 13. 13 | $foo = 'hi!'; 14 | 15 | # And, without the signature below, it would. 16 | # For that matter, if you compile this by itself, it still does. 17 | # However, when you require this file from inside an eval, Method::Signature's parser() method will 18 | # eat the error unless we localize $@ there. So this verifies that we're doing that. 19 | 20 | method foo (Str $bar) 21 | { 22 | } 23 | 24 | 25 | 1; 26 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/lib/MooseLoadTest.pm: -------------------------------------------------------------------------------- 1 | # package for t/typeload_moose.t 2 | # (see comments there for why check_paramized_sref is here) 3 | 4 | package Foo::Bar; 5 | 6 | use Moose; 7 | use Function::Parameters { 8 | fun => { defaults => 'function', reify_type => 'moose' }, 9 | method => { defaults => 'method', reify_type => 'moose' }, 10 | }; 11 | 12 | method check_int (Int $bar) {}; 13 | method check_paramized_sref (ScalarRef[Num] $bar) {}; 14 | 15 | 1; 16 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/method.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | use Test::More 'no_plan'; 5 | 6 | { 7 | package Foo; 8 | use Function::Parameters qw(:strict); 9 | 10 | method new (%args) { 11 | return bless {%args}, $self; 12 | } 13 | 14 | method set ($key, $val) { 15 | return $self->{$key} = $val; 16 | } 17 | 18 | method get ($key) { 19 | return $self->{$key}; 20 | } 21 | 22 | method no_proto(@) { 23 | return($self, @_); 24 | } 25 | 26 | method empty_proto() { 27 | return($self, @_); 28 | } 29 | 30 | # method echo(@_) { 31 | # return($self, @_); 32 | # } 33 | 34 | method caller($height = 0) { 35 | return (CORE::caller($height))[0..2]; 36 | } 37 | 38 | #line 39 39 | method warn($foo = undef) { 40 | my $warning = ''; 41 | local $SIG{__WARN__} = sub { $warning = join '', @_; }; 42 | CORE::warn "Testing warn"; 43 | 44 | return $warning; 45 | } 46 | 47 | # Method with the same name as a loaded class. 48 | method strict () { 49 | 42 50 | } 51 | } 52 | 53 | my $obj = Foo->new( foo => 42, bar => 23 ); 54 | isa_ok $obj, "Foo"; 55 | is $obj->get("foo"), 42; 56 | is $obj->get("bar"), 23; 57 | 58 | $obj->set(foo => 99); 59 | is $obj->get("foo"), 99; 60 | 61 | is_deeply [$obj->no_proto], [$obj]; 62 | for my $method (qw(empty_proto)) { 63 | is_deeply [$obj->$method], [$obj]; 64 | ok !eval { $obj->$method(23); 1 }; 65 | like $@, qr{\QToo many arguments}; 66 | } 67 | 68 | #is_deeply [$obj->echo(1,2,3)], [$obj,1,2,3], "echo"; 69 | 70 | is_deeply [$obj->caller], [__PACKAGE__, $0, __LINE__], 'caller works'; 71 | 72 | is $obj->warn, "Testing warn at $0 line 42.\n"; 73 | 74 | is eval { $obj->strict }, 42; 75 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/named.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | 5 | use Test::More; 6 | 7 | { 8 | package Foo; 9 | 10 | use Test::More; 11 | use Test::Fatal;; 12 | use Function::Parameters qw(:strict); 13 | 14 | method formalize($text, :$justify = "left", :$case = undef) { 15 | my %params; 16 | $params{text} = $text; 17 | $params{justify} = $justify; 18 | $params{case} = $case if defined $case; 19 | 20 | return \%params; 21 | } 22 | 23 | is_deeply( Foo->formalize( "stuff" ), { text => "stuff", justify => "left" } ); 24 | 25 | like exception { Foo->formalize( "stuff", wibble => 23 ) }, qr/\bnamed\b.+\bwibble\b/; 26 | 27 | method foo( :$arg ) { 28 | return $arg; 29 | } 30 | 31 | is( Foo->foo( arg => 42 ), 42 ); 32 | like exception { foo() }, qr/Too few arguments/; 33 | 34 | 35 | # Compile time errors need internal refactoring before I can get file, line and method 36 | # information. 37 | eval q{ 38 | method wrong( :$named, $pos ) {} 39 | }; 40 | like $@, qr/\bpositional\b.+\$pos\b.+\bnamed\b.+\$named\b/; 41 | 42 | eval q{ 43 | method wrong( $foo, :$named, $bar ) {} 44 | }; 45 | like $@, qr/\bpositional\b.+\$bar\b.+\bnamed\b.+\$named\b/; 46 | 47 | eval q{ 48 | method wrong( $foo, $bar = undef, :$named ) {} 49 | }; 50 | like $@, qr/\boptional positional\b.+\$bar\b.+\brequired named\b.+\$named\b/; 51 | } 52 | 53 | 54 | done_testing(); 55 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/odd_number.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings FATAL => 'all'; 4 | use strict; 5 | 6 | use Test::More tests => 1; 7 | use Test::Fatal; 8 | 9 | use Function::Parameters qw(:strict); 10 | 11 | package Foo { 12 | method foo(:$name, :$value) { 13 | return $name, $value; 14 | } 15 | } 16 | 17 | like exception { Foo->foo(name => 42, value =>) }, qr/Too few arguments.+ line 17/; 18 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/one_line.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use warnings FATAL => 'all'; 3 | use strict; 4 | use Test::More tests => 1; 5 | 6 | { 7 | package Thing; 8 | 9 | use Function::Parameters qw(:strict); 10 | method foo() {"wibble"} 11 | 12 | ::is( Thing->foo, "wibble" ); 13 | } 14 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/optional.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Test the $arg = undef optional syntax. 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use Test::More; 9 | 10 | { 11 | package Stuff; 12 | 13 | use Test::More; 14 | use Test::Fatal; 15 | use Function::Parameters qw(:strict); 16 | 17 | method whatever($this = undef) { 18 | return $this; 19 | } 20 | 21 | is( Stuff->whatever(23), 23 ); 22 | 23 | method things($this = 99) { 24 | return $this; 25 | } 26 | 27 | is( Stuff->things(), 99 ); 28 | 29 | method some_optional($that, $this = undef) { 30 | return $that + ($this || 0); 31 | } 32 | 33 | is( Stuff->some_optional(18, 22), 18 + 22 ); 34 | is( Stuff->some_optional(18), 18 ); 35 | 36 | 37 | method named_params(:$this = undef, :$that = undef) {} 38 | 39 | is exception { Stuff->named_params(this => 0) }, undef, 'can leave out some named params'; 40 | is exception { Stuff->named_params( ) }, undef, 'can leave out all named params'; 41 | 42 | 43 | # are slurpy parameters optional by default? 44 | # (throwing in a default just for a little feature interaction test) 45 | method slurpy_param($this, $that = 0, @other) {} 46 | 47 | my @a = (); 48 | is exception { Stuff->slurpy_param(0, 0, @a) }, undef, 'can pass empty array to slurpy param'; 49 | is exception { Stuff->slurpy_param(0, 0 ) }, undef, 'can omit slurpy param altogether'; 50 | is exception { Stuff->slurpy_param(0 ) }, undef, 'can omit other optional params as well as slurpy param'; 51 | } 52 | 53 | 54 | done_testing; 55 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/paren_on_own_line.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | package Foo; 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use Function::Parameters qw(:strict); 9 | use Test::More 'no_plan'; 10 | 11 | # The problem goes away inside an eval STRING. 12 | method foo( 13 | $arg 14 | ) 15 | { 16 | return $arg; 17 | } 18 | 19 | is $@, ''; 20 | is( Foo->foo(42), 42 ); 21 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/paren_plus_open_block.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | package Foo; 7 | 8 | use Test::More "no_plan"; 9 | use Function::Parameters qw(:strict); 10 | 11 | method foo( 12 | $arg 13 | ) 14 | { 15 | return $arg 16 | } 17 | 18 | is( Foo->foo(23), 23 ); 19 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/required.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More; 7 | 8 | 9 | { 10 | package Stuff; 11 | 12 | use Test::More; 13 | use Test::Fatal; 14 | use Function::Parameters qw(:strict); 15 | 16 | method whatever($this) { 17 | return $this; 18 | } 19 | 20 | is( Stuff->whatever(23), 23 ); 21 | 22 | like exception { Stuff->whatever() }, qr/Too few arguments/; 23 | 24 | method some_optional($that, $this = 22) { 25 | return $that + $this 26 | } 27 | 28 | is( Stuff->some_optional(18), 18 + 22 ); 29 | 30 | like exception { Stuff->some_optional() }, qr/Too few arguments/; 31 | } 32 | 33 | 34 | done_testing(); 35 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/simple.plx: -------------------------------------------------------------------------------- 1 | package Foo; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Function::Parameters; 7 | 8 | method echo($msg) { 9 | return $msg 10 | } 11 | 12 | print Foo->echo(42); 13 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/slurpy.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Test slurpy parameters 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use Test::More; 9 | #use Test::Exception; 10 | 11 | { 12 | package Stuff; 13 | use Function::Parameters qw(:strict); 14 | use Test::More; 15 | 16 | method slurpy(@that) { return \@that } 17 | method slurpy_required(@that) { return \@that } 18 | method slurpy_last($this, @that) { return $this, \@that; } 19 | 20 | ok !eval q[fun slurpy_first(@that, $this) { return $this, \@that; }]; 21 | like $@, qr{\$this\b.+\@that\b}; 22 | # TODO: { 23 | # local $TODO = "error message incorrect inside an eval"; 24 | 25 | # like $@, qr{Stuff::}; 26 | like $@, qr{\bslurpy_first\b}; 27 | # } 28 | 29 | ok !eval q[fun slurpy_middle($this, @that, $other) { return $this, \@that, $other }]; 30 | like $@, qr{\$other\b.+\@that\b}; 31 | # TODO: { 32 | # local $TODO = "error message incorrect inside an eval"; 33 | 34 | # like $@, qr{Stuff::}; 35 | like $@, qr{\bslurpy_middle\b}; 36 | # } 37 | 38 | ok !eval q[fun slurpy_positional(:@that) { return \@that; }]; 39 | like $@, qr{\bnamed\b.+\@that\b.+\barray\b}; 40 | 41 | # TODO: { 42 | # local $TODO = "error message incorrect inside an eval"; 43 | 44 | # like $@, qr{Stuff::}; 45 | like $@, qr{\bslurpy_positional\b}; 46 | # } 47 | 48 | ok !eval q[fun slurpy_two($this, @that, @other) { return $this, \@that, \@other }]; 49 | like $@, qr{\@other\b.+\@that\b}; 50 | } 51 | 52 | 53 | note "Optional slurpy params accept 0 length list"; { 54 | is_deeply [Stuff->slurpy()], [[]]; 55 | is_deeply [Stuff->slurpy_last(23)], [23, []]; 56 | } 57 | 58 | #note "Required slurpy params require an argument"; { 59 | # throws_ok { Stuff->slurpy_required() } 60 | # qr{slurpy_required\Q()\E, missing required argument \@that at \Q$0\E line @{[__LINE__ - 1]}}; 61 | #} 62 | 63 | 64 | done_testing; 65 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/syntax_errors.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More; 6 | 7 | use FindBin; 8 | use lib "$FindBin::Bin/lib"; 9 | 10 | ok !eval { require Bad }; 11 | #TODO: { 12 | # local $TODO = "The user should see the actual syntax error"; 13 | like $@, qr{^Global symbol "\$info" requires explicit package name}m; 14 | 15 | # like($@, qr{^PPI failed to find statement for '\$bar'}m, 16 | # 'Bad syntax generates stack trace'); 17 | #} 18 | 19 | done_testing(); 20 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/too_many_args.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More; 7 | 8 | use Function::Parameters qw(:strict); 9 | 10 | fun no_sig(@) { return @_ } 11 | fun no_args() { return @_ } 12 | fun one_arg($foo) { return $foo } 13 | fun two_args($foo, $bar) { return ($foo, $bar) } 14 | fun array_at_end($foo, @stuff) { return ($foo, @stuff) } 15 | fun one_named(:$foo) { return $foo; } 16 | fun one_named_one_positional($bar, :$foo) { return($foo, $bar) } 17 | 18 | note "too many arguments"; { 19 | is_deeply [no_sig(42)], [42]; 20 | 21 | 22 | ok !eval { no_args(42); 1 }, "no args"; 23 | like $@, qr{Too many arguments}; 24 | 25 | ok !eval { one_arg(23, 42); 1 }, "one arg"; 26 | like $@, qr{Too many arguments}; 27 | 28 | ok !eval { two_args(23, 42, 99); 1 }, "two args"; 29 | like $@, qr{Too many arguments}; 30 | 31 | is_deeply [array_at_end(23, 42, 99)], [23, 42, 99], "array at end"; 32 | } 33 | 34 | 35 | note "with positionals"; { 36 | is one_named(foo => 42), 42; 37 | is one_named(foo => 23, foo => 42), 42; 38 | 39 | 40 | 41 | is_deeply [one_named_one_positional(23, foo => 42)], [42, 23]; 42 | is_deeply [one_named_one_positional(23, foo => 42, foo => 23)], [23, 23]; 43 | 44 | } 45 | 46 | 47 | done_testing; 48 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/trailing_comma.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Make sure we allow a trailing comma. 4 | 5 | use strict; 6 | use warnings FATAL => 'all'; 7 | 8 | use Test::More; 9 | 10 | use Function::Parameters qw(:strict); 11 | 12 | fun foo($foo, $bar,) { 13 | return [$foo, $bar]; 14 | } 15 | 16 | is_deeply foo(23, 42), [23, 42]; 17 | 18 | done_testing; 19 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/typeload_moose.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | use FindBin; 6 | use lib "$FindBin::Bin/lib"; 7 | 8 | use Test::More; 9 | use Test::Fatal; 10 | 11 | 12 | SKIP: 13 | { 14 | eval { require Moose } or skip "Moose required for testing Moose types", 1; 15 | 16 | require MooseLoadTest; 17 | 18 | my $foobar = Foo::Bar->new; 19 | 20 | # can't check for type module not being loaded here, because Moose will drag it in 21 | 22 | 23 | $foobar->check_int(42); 24 | 25 | # now we should have loaded Moose to do our type checking 26 | 27 | like $INC{'Moose/Util/TypeConstraints.pm'}, qr{Moose/Util/TypeConstraints\.pm$}, 'loaded Moose'; 28 | 29 | 30 | # tests for ScalarRef[X] have to live here, because they only work with Moose 31 | 32 | my $method = 'check_paramized_sref'; 33 | my $bad_ref = \'thing'; 34 | is exception { $foobar->$method(\42) }, undef, 'call with good value for paramized_sref passes'; 35 | like exception { $foobar->$method($bad_ref) }, 36 | qr/\bcheck_paramized_sref\b.+\$bar\b.+ScalarRef\[Num\]/, 37 | 'call with bad value for paramized_sref dies'; 38 | } 39 | 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /xt/foreign/Method-Signatures/typeload_notypes.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | 6 | use Test::More; 7 | 8 | 9 | { 10 | package Foo::Bar; 11 | 12 | use strict; 13 | use warnings; 14 | 15 | use Function::Parameters qw(:strict); 16 | 17 | method new ($class:) { bless {}, $class; } 18 | 19 | # not using a type here, so we won't expect Moose to get loaded 20 | method foo1 ($bar) {}; 21 | } 22 | 23 | my $foobar = Foo::Bar->new; 24 | 25 | # at this point, Moose should not be loaded 26 | 27 | is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; 28 | 29 | 30 | $foobar->foo1(42); 31 | 32 | # _still_ should have no Moose because we haven't requested any type checking 33 | 34 | is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; 35 | 36 | 37 | done_testing; 38 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/attributes.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More tests => 2; 6 | 7 | use attributes; 8 | use Function::Parameters qw(:strict); 9 | 10 | my $attrs; 11 | my $cb_called; 12 | 13 | sub MODIFY_CODE_ATTRIBUTES { 14 | my ($pkg, $code, @attrs) = @_; 15 | $cb_called = 1; 16 | $attrs = \@attrs; 17 | return (); 18 | } 19 | 20 | method moo ($a, $b) : Bar Baz(fubar) { 21 | } 22 | 23 | method foo() 24 | : 25 | Bar 26 | :Moo(:Ko{oh) 27 | : Baz(fu{bar:): { return {} } 28 | 29 | ok($cb_called, 'attribute handler got called'); 30 | is_deeply($attrs, [qw/Bar Moo(:Ko{oh) Baz(fu{bar:)/], '... with the right attributes'); 31 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/caller.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings FATAL => 'all'; 3 | use Test::More tests => 1; 4 | 5 | { 6 | package TestClass; 7 | 8 | use Function::Parameters qw(:strict); 9 | 10 | use Carp (); 11 | 12 | method callstack_inner($class:) { 13 | return Carp::longmess("Callstack is"); 14 | } 15 | 16 | method callstack($class:) { 17 | return $class->callstack_inner; 18 | } 19 | } 20 | 21 | my $callstack = TestClass->callstack(); 22 | 23 | unlike $callstack, qr/Test::Class::.*?__ANON__/, "No anon methods in call chain"; 24 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/closure.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More 5 | eval { require Moose } 6 | ? (tests => 7) 7 | : (skip_all => "Moose required for testing types") 8 | ; 9 | 10 | { 11 | package Foo; 12 | 13 | use Moose; 14 | use Function::Parameters { 15 | fun => { defaults => 'function', reify_type => 'moose' }, 16 | method => { defaults => 'method', reify_type => 'moose' }, 17 | }; 18 | 19 | for my $meth (qw/foo bar baz/) { 20 | Foo->meta->add_method("anon_$meth" => method (Str $bar) { 21 | $meth . $bar 22 | }); 23 | 24 | eval qq{ 25 | method str_$meth (Str \$bar) { 26 | \$meth . \$bar 27 | } 28 | }; 29 | die $@ if $@; 30 | } 31 | } 32 | 33 | can_ok('Foo', map { ("anon_$_", "str_$_") } qw/foo bar baz/); 34 | 35 | my $foo = Foo->new; 36 | 37 | for my $meth (qw/foo bar baz/) { 38 | is($foo->${\"anon_$meth"}('bar'), $meth . 'bar'); 39 | is($foo->${\"str_$meth"}('bar'), $meth . 'bar'); 40 | } 41 | 42 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/errors.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | use FindBin; 7 | use lib "$FindBin::Bin/lib"; 8 | 9 | eval "use InvalidCase01;"; 10 | ok($@, "Got an error"); 11 | 12 | #TODO: { 13 | # 14 | #local $TODO = 'Devel::Declare and Eval::Closure have unresolved issues' 15 | # if Eval::Closure->VERSION > 0.06; 16 | 17 | like($@, 18 | qr/^Global symbol "\$op" requires explicit package name .*?\bInvalidCase01.pm line 8\b/, 19 | "Sane error message for syntax error"); 20 | 21 | #} 22 | 23 | 24 | { 25 | my $warnings = ""; 26 | local $SIG{__WARN__} = sub { $warnings .= $_[0] }; 27 | 28 | eval "use Redefined;"; 29 | is($@, '', "No error"); 30 | like($warnings, qr/^Subroutine meth1 redefined at .*?\bRedefined.pm line 9\b/, 31 | "Redefined method warning"); 32 | } 33 | 34 | done_testing; 35 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/eval.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | 5 | use Test::More tests => 3; # last test to print 6 | use Function::Parameters qw(:strict); 7 | 8 | 9 | my $evalcode = do { 10 | local $/ = undef; 11 | ; 12 | }; 13 | 14 | ok( 15 | do { 16 | my $r = eval $evalcode; 17 | die $@ if not $r; 18 | 1; 19 | }, 20 | 'Basic Eval Moose' 21 | ); 22 | 23 | my $foo = foo->new({}); 24 | is ($foo->example (), 1, 'First method declared'); 25 | is ($foo->example2(), 2, 'Second method declared (after injected semicolon)'); 26 | 27 | __DATA__ 28 | { 29 | package foo; 30 | 31 | use Function::Parameters qw(:strict); 32 | method new($class: $init) { bless $init, $class } 33 | method example() { 1 } # look Ma, no semicolon! 34 | method example2() { 2 } 35 | } 36 | 1; 37 | 38 | 39 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/lib/InvalidCase01.pm: -------------------------------------------------------------------------------- 1 | package InvalidCase01; 2 | use strict; 3 | use warnings; no warnings 'syntax'; 4 | use Function::Parameters qw(:strict); 5 | use Carp qw/croak/; 6 | 7 | method meth1(@){ 8 | croak "Binary operator $op expects 2 children, got " . $#$_ 9 | if @{$_} > 3; 10 | } 11 | 12 | method meth2(){ { 13 | "a" "b" 14 | } 15 | 16 | method meth3() {} 17 | 1; 18 | 19 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/Long/Name/Space.pm: -------------------------------------------------------------------------------- 1 | package My::Annoyingly::Long::Name::Space; 2 | use Moose; 3 | 1; 4 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/lib/Redefined.pm: -------------------------------------------------------------------------------- 1 | package Redefined; 2 | use strict; 3 | use warnings; 4 | use Function::Parameters qw(:strict); 5 | use Carp qw/croak/; 6 | 7 | method meth1() {} 8 | 9 | method meth1() {} 10 | 11 | # this one should not trigger a redfined warning 12 | sub meth2 {} 13 | method meth2() {} 14 | 15 | # This one shouldn't either 16 | method meth3() {} 17 | { no warnings 'redefine'; 18 | method meth3() {} 19 | } 20 | 1; 21 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/list.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More 5 | eval { require Moose } 6 | ? (tests => 25) 7 | : (skip_all => "Moose required for testing types") 8 | ; 9 | use Test::Fatal; 10 | use Function::Parameters { 11 | fun => { defaults => 'function', reify_type => 'moose' }, 12 | method => { defaults => 'method', reify_type => 'moose' }, 13 | }; 14 | 15 | my $o = bless {} => 'Foo'; 16 | 17 | { 18 | my %meths = ( 19 | rest_list => method ($foo, $bar, @rest) { 20 | return join q{,}, @rest; 21 | }, 22 | rest_named => method ($foo, $bar, %rest) { 23 | return join q{,}, map { $_ => $rest{$_} } sort keys %rest; 24 | }, 25 | ); 26 | 27 | for my $meth_name (keys %meths) { 28 | my $meth = $meths{$meth_name}; 29 | like(exception { $o->$meth() }, qr/Too few arguments/, "$meth_name dies without args"); 30 | like(exception { $o->$meth('foo') }, qr/Too few arguments/, "$meth_name dies with one arg"); 31 | 32 | is(exception { 33 | is($o->$meth('foo', 'bar'), q{}, "$meth_name - empty \@rest list"); 34 | }, undef, '...and validates'); 35 | 36 | is(exception { 37 | is($o->$meth('foo', 'bar', 1 .. 6), q{1,2,3,4,5,6}, 38 | "$meth_name - non-empty \@rest list"); 39 | }, undef, '...and validates'); 40 | } 41 | } 42 | 43 | { 44 | my $meth = method (Str $foo, Int $bar, Int @rest) { 45 | return join q{,}, @rest; 46 | }; 47 | 48 | is(exception { 49 | is($o->$meth('foo', 42), q{}, 'empty @rest list passed through'); 50 | }, undef, '...and validates'); 51 | 52 | is(exception { 53 | is($o->$meth('foo', 42, 23, 13), q{23,13}, 'non-empty int @rest list passed through'); 54 | }, undef, '...and validates'); 55 | 56 | like(exception { 57 | $o->$meth('foo', 42, 'moo', 13, 'non-empty str @rest list passed through'); 58 | }, qr/\@rest\b.+\bValidation failed/, "...and doesn't validate"); 59 | } 60 | 61 | { 62 | my $meth = method (ArrayRef[Int] @foo) { 63 | return join q{,}, map { @{ $_ } } @foo; 64 | }; 65 | 66 | is(exception { 67 | is($o->$meth([42, 23], [12], [18]), '42,23,12,18', 'int lists passed through'); 68 | }, undef, '...and validates'); 69 | 70 | like(exception { 71 | $o->$meth([42, 23], 12, [18]); 72 | }, qr/Validation failed/, "int doesn't validate against int list"); 73 | } 74 | 75 | { 76 | my $meth = method (Str $foo, Int @_rest) {}; 77 | is(exception { $meth->($o, 'foo') }, undef, 'empty unnamed list validates'); 78 | is(exception { $meth->($o, 'foo', 42) }, undef, '1 element of unnamed list validates'); 79 | is(exception { $meth->($o, 'foo', 42, 23) }, undef, '2 elements of unnamed list validates'); 80 | } 81 | 82 | { 83 | eval 'my $meth = method (:$foo, :@bar) { }'; 84 | like $@, qr/\bnamed\b.+\bbar\b.+\barray\b/, 85 | 'arrays or hashes cannot be named'; 86 | 87 | eval 'my $meth = method ($foo, @bar, :$baz) { }'; 88 | like $@, qr/"\$baz\" can't appear after slurpy parameter "\@bar"/, 89 | 'named parameters cannot be combined with slurpy positionals'; 90 | } 91 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/named_defaults.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | 6 | { 7 | package Foo; 8 | 9 | use Function::Parameters qw(:strict); 10 | 11 | method new($class:) { bless {}, $class } 12 | method bar (:$baz = 42) { $baz } 13 | } 14 | 15 | my $o = Foo->new; 16 | is($o->bar, 42); 17 | is($o->bar(baz => 0xaffe), 0xaffe); 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/no_signature.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | { 8 | package Foo; 9 | use Function::Parameters qw(:strict); 10 | method new($class:) { bless {}, $class } 11 | method bar(@) { 42 } 12 | } 13 | 14 | my $foo = Foo->new; 15 | 16 | is(exception { 17 | $foo->bar 18 | }, undef, 'method without signature succeeds when called without args'); 19 | 20 | is(exception { 21 | $foo->bar(42) 22 | }, undef, 'method without signature succeeds when called with args'); 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/precedence.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 4; 5 | 6 | use Function::Parameters qw(:strict); 7 | 8 | my @methods = (method () { 1 }, method () { 2 }, method () { 3 }); 9 | is(scalar @methods, 3); 10 | 11 | isa_ok($_, 'CODE') for @methods; 12 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/sigs-optional.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 4; 5 | 6 | { 7 | package Optional; 8 | use Function::Parameters qw(:strict); 9 | method foo ($class: $arg = undef) { 10 | $arg; 11 | } 12 | 13 | method bar ($class: $hr = {}) { 14 | ++$hr->{bar}; 15 | } 16 | } 17 | 18 | is( Optional->foo(), undef); 19 | is( Optional->foo(1), 1); 20 | is( Optional->bar(), 1); 21 | is( Optional->bar({bar=>1}), 2); 22 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/too_many_args.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | { 8 | package Foo; 9 | use Function::Parameters qw(:strict); 10 | 11 | method new($class:) { bless {}, $class } 12 | method foo ($bar) { $bar } 13 | } 14 | 15 | my $o = Foo->new; 16 | is(exception { $o->foo(42) }, undef); 17 | like(exception { $o->foo(42, 23) }, qr/Too many arguments/); 18 | 19 | done_testing; 20 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/type_alias.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More 5 | eval { require Moose; require aliased } 6 | ? (tests => 2) 7 | : (skip_all => "Moose, aliased required for testing types") 8 | ; 9 | use Test::Fatal; 10 | 11 | use FindBin; 12 | use lib "$FindBin::Bin/lib"; 13 | 14 | { 15 | package TestClass; 16 | use Moose; 17 | use Function::Parameters { 18 | fun => { defaults => 'function', reify_type => 'moose' }, 19 | method => { defaults => 'method', reify_type => 'moose' }, 20 | }; 21 | 22 | use aliased 'My::Annoyingly::Long::Name::Space', 'Shortcut'; 23 | 24 | ::is(::exception { method alias_sig ((Shortcut) $affe) { } }, 25 | undef, 'method with aliased type constraint compiles'); 26 | } 27 | 28 | my $o = TestClass->new; 29 | my $affe = My::Annoyingly::Long::Name::Space->new; 30 | 31 | is(exception { 32 | $o->alias_sig($affe); 33 | }, undef, 'calling method with aliased type constraint'); 34 | 35 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/types.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More 5 | eval { require Moose; require MooseX::Types } 6 | ? (tests => 4) 7 | : (skip_all => "Moose, MooseX::Types required for testing types") 8 | ; 9 | use Test::Fatal; 10 | 11 | { 12 | package MyTypes; 13 | use MooseX::Types::Moose qw/Str/; 14 | use Moose::Util::TypeConstraints; 15 | use MooseX::Types -declare => [qw/CustomType/]; 16 | 17 | BEGIN { 18 | subtype CustomType, 19 | as Str, 20 | where { length($_) == 2 }; 21 | } 22 | } 23 | 24 | { 25 | package TestClass; 26 | use Function::Parameters qw(:strict); 27 | BEGIN { MyTypes->import('CustomType') }; 28 | use MooseX::Types::Moose qw/ArrayRef/; 29 | #use namespace::clean; 30 | 31 | method foo ((CustomType) $bar) { } 32 | 33 | method bar ((ArrayRef[CustomType]) $baz) { } 34 | } 35 | 36 | my $o = bless {} => 'TestClass'; 37 | 38 | is(exception { $o->foo('42') }, undef); 39 | ok(exception { $o->foo('bar') }); 40 | 41 | is(exception { $o->bar(['42', '23']) }, undef); 42 | ok(exception { $o->bar(['foo', 'bar']) }); 43 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/undef_method_arg.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | { 8 | package Foo; 9 | use Function::Parameters qw(:strict); 10 | 11 | method new($class:) { bless {}, $class } 12 | 13 | method m1(:$bar ) { } 14 | method m2(:$bar = undef) { } 15 | method m3(:$bar ) { } 16 | 17 | method m4( $bar ) { } 18 | method m5( $bar = undef) { } 19 | method m6( $bar ) { } 20 | } 21 | 22 | my $foo = Foo->new; 23 | 24 | is(exception { $foo->m1(bar => undef) }, undef, 'Explicitly pass undef to named implicit required arg'); 25 | is(exception { $foo->m2(bar => undef) }, undef, 'Explicitly pass undef to named explicit optional arg'); 26 | is(exception { $foo->m3(bar => undef) }, undef, 'Explicitly pass undef to named implicit required arg'); 27 | 28 | is(exception { $foo->m4(undef) }, undef, 'Explicitly pass undef to implicit required arg'); 29 | is(exception { $foo->m5(undef) }, undef, 'Explicitly pass undef to explicit required arg'); 30 | is(exception { $foo->m6(undef) }, undef, 'Explicitly pass undef to implicit required arg'); 31 | 32 | done_testing; 33 | -------------------------------------------------------------------------------- /xt/foreign/MooseX-Method-Signatures/undef_method_arg2.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More 5 | eval { 6 | require Moose; 7 | require Test::Deep; 8 | } 9 | ? (tests => 4) 10 | : (skip_all => "Moose, Test::Deep required for testing types") 11 | ; 12 | 13 | # assigned to by each 'foo' method 14 | my $captured_args; 15 | 16 | { 17 | package Named; 18 | 19 | use Moose; 20 | use Function::Parameters { 21 | fun => { defaults => 'function', reify_type => 'moose' }, 22 | method => { defaults => 'method', reify_type => 'moose' }, 23 | }; 24 | 25 | # use Data::Dumper; 26 | 27 | method foo ( 28 | Str :$foo_a, 29 | Maybe[Str] :$foo_b = undef) { 30 | $captured_args = \@_; 31 | } 32 | } 33 | 34 | 35 | { 36 | package Positional; 37 | use Moose; 38 | use Function::Parameters { 39 | fun => { defaults => 'function', reify_type => 'moose' }, 40 | method => { defaults => 'method', reify_type => 'moose' }, 41 | }; 42 | 43 | # use Data::Dumper; 44 | 45 | method foo ( 46 | Str $foo_a, 47 | Maybe[Str] $foo_b = undef) { 48 | $captured_args = \@_; 49 | } 50 | } 51 | 52 | 53 | use Test::Deep; 54 | #use Data::Dumper; 55 | 56 | 57 | 58 | my $positional = Positional->new; 59 | $positional->foo('str', undef); 60 | 61 | cmp_deeply( 62 | $captured_args, 63 | [ 64 | #noclass({}), 65 | 'str', 66 | undef, 67 | ], 68 | 'positional: explicit undef shows up in @_ correctly', 69 | ); 70 | 71 | $positional->foo('str'); 72 | 73 | cmp_deeply( 74 | $captured_args, 75 | [ 76 | #noclass({}), 77 | 'str', 78 | ], 79 | 'positional: omitting an argument results in no entry in @_', 80 | ); 81 | 82 | my $named = Named->new; 83 | $named->foo(foo_a => 'str', foo_b => undef); 84 | 85 | cmp_deeply( 86 | $captured_args, 87 | [ 88 | #noclass({}), 89 | foo_a => 'str', 90 | foo_b => undef, 91 | ], 92 | 'named: explicit undef shows up in @_ correctly', 93 | ); 94 | 95 | $named->foo(foo_a => 'str'); 96 | 97 | #TODO: { 98 | # local $TODO = 'this fails... should work the same as for positional args.'; 99 | cmp_deeply( 100 | $captured_args, 101 | [ 102 | #noclass({}), 103 | foo_a => 'str', 104 | ], 105 | 'named: omitting an argument results in no entry in @_', 106 | ); 107 | 108 | #print "### named captured args: ", Dumper($captured_args); 109 | #} 110 | 111 | 112 | 113 | 114 | -------------------------------------------------------------------------------- /xt/foreign/signatures/anon.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 1; 5 | 6 | use Function::Parameters; 7 | 8 | my $foo = fun ($bar, $baz) { return "${bar}-${baz}" }; 9 | 10 | is($foo->(qw/bar baz/), 'bar-baz'); 11 | -------------------------------------------------------------------------------- /xt/foreign/signatures/basic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 5; 5 | 6 | use Function::Parameters; 7 | 8 | fun foo ($bar) { $bar } 9 | 10 | fun korv ($wurst, $_unused, $birne) { 11 | return "${wurst}-${birne}"; 12 | } 13 | 14 | fun array ($scalar, @array) { 15 | return $scalar + @array; 16 | } 17 | 18 | fun hash (%hash) { 19 | return keys %hash; 20 | } 21 | 22 | fun Name::space ($moo) { $moo } 23 | 24 | is(foo('baz'), 'baz'); 25 | is(korv(qw/a b c/), 'a-c'); 26 | is(array(10, 1..10), 20); 27 | is_deeply( 28 | [sort(hash(foo => 1, bar => 2))], 29 | [sort(qw/foo bar/)], 30 | ); 31 | 32 | is(Name::space('kooh'), 'kooh'); 33 | -------------------------------------------------------------------------------- /xt/foreign/signatures/eval.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 8; 5 | 6 | use Function::Parameters; 7 | 8 | eval 'fun foo ($bar) { $bar }'; 9 | ok(!$@, 'signatures parse in eval'); 10 | diag $@ if $@; 11 | ok(\&foo, 'fun declared in eval'); 12 | is(foo(42), 42, 'eval signature works'); 13 | 14 | no Function::Parameters; 15 | 16 | $SIG{__WARN__} = sub {}; 17 | eval 'fun bar ($baz) { $baz }'; 18 | like($@, qr/requires explicit package name/, 'string eval disabled'); 19 | 20 | { 21 | use Function::Parameters; 22 | 23 | eval 'fun bar ($baz) { $baz }'; 24 | ok(!$@, 'signatures parse in eval'); 25 | diag $@ if $@; 26 | ok(\&bar, 'fun declared in eval'); 27 | is(bar(42), 42, 'eval signature works'); 28 | } 29 | 30 | $SIG{__WARN__} = sub {}; 31 | eval 'fun moo ($kooh) { $kooh }'; 32 | like($@, qr/requires explicit package name/, 'string eval disabled'); 33 | -------------------------------------------------------------------------------- /xt/foreign/signatures/proto.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | use Test::More tests => 7; 5 | 6 | use vars qw/@warnings/; 7 | BEGIN { $SIG{__WARN__} = sub { push @warnings, @_ } } 8 | 9 | BEGIN { is(@warnings, 0, 'no warnings yet') } 10 | 11 | use Function::Parameters; 12 | 13 | fun with_proto ($x, $y, $z) : prototype($$$) { 14 | return $x + $y + $z; 15 | } 16 | 17 | { 18 | my $foo; 19 | fun with_lvalue () : prototype() lvalue { $foo } 20 | } 21 | 22 | is(prototype('with_proto'), '$$$', ':proto attribute'); 23 | 24 | is(prototype('with_lvalue'), '', ':proto with other attributes'); 25 | with_lvalue = 1; 26 | is(with_lvalue, 1, 'other attributes still there'); 27 | 28 | BEGIN { is(@warnings, 0, 'no warnings with correct :proto declarations') } 29 | 30 | fun invalid_proto ($x) : prototype(invalid) { $x } 31 | 32 | BEGIN { 33 | #TODO: { 34 | # local $TODO = ':proto checks not yet implemented'; 35 | is(@warnings, 1, 'warning with illegal :proto'); 36 | like( 37 | $warnings[0], 38 | qr/Illegal character in prototype for fun invalid_proto : invalid at /, 39 | 'warning looks sane', 40 | ); 41 | #} 42 | } 43 | 44 | #eval 'sub foo ($bar) : proto { $bar }'; 45 | #like($@, qr/proto attribute requires argument/); 46 | -------------------------------------------------------------------------------- /xt/foreign/signatures/weird.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Test::More tests => 2; 5 | 6 | use Function::Parameters; 7 | 8 | fun 9 | foo 10 | ($bar, $baz) 11 | { return q{($bar, $baz) is }.qq{("$bar", "$baz")} } 12 | 13 | my $moo 14 | = 15 | fun 16 | ($bar, $baz) 17 | { return q{($bar, $baz) is }.qq{("$bar", "$baz")} }; 18 | 19 | is(foo(qw/affe zomtec/), '($bar, $baz) is ("affe", "zomtec")'); 20 | is($moo->(qw/korv wurst/), '($bar, $baz) is ("korv", "wurst")'); 21 | 22 | 1; 23 | -------------------------------------------------------------------------------- /xt/pod.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::Pod 1.22; 6 | 7 | all_pod_files_ok(); 8 | --------------------------------------------------------------------------------