Function-Parameters-2.002004/0000755000175000017500000000000014454414615014625 5ustar maukemaukeFunction-Parameters-2.002004/Makefile_PL_settings.plx0000644000175000017500000000265414410657431021406 0ustar maukemaukeuse strict; use warnings; { my $broken; if (eval { require Moose }) { if (!eval { package A_Moose_User; Moose->import; 1 }) { $broken = 'import'; } } elsif ($@ !~ /^Can't locate Moose\.pm /) { $broken = 'require'; } if ($broken) { print STDERR <<"EOT"; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!! Error: You seem to have Moose but I can't "use" it ($broken dies). !!! !!! This would cause confusing test errors, so I'm bailing out. Sorry. !!! !!! Maybe try upgrading Moose? !!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! The exception was: $@ EOT exit 1; } } return { NAME => 'Function::Parameters', AUTHOR => q{Lukas Mai }, MIN_PERL_VERSION => '5.14.0', CONFIGURE_REQUIRES => {}, BUILD_REQUIRES => {}, TEST_REQUIRES => { 'constant' => 0, 'strict' => 0, 'utf8' => 0, 'FindBin' => 0, 'Hash::Util' => 0.07, 'Test::More' => 0, 'Test::Fatal' => 0, }, PREREQ_PM => { 'Carp' => 0, 'Scalar::Util' => 0, 'XSLoader' => 0, 'warnings' => 0, }, depend => { '$(OBJECT)' => join(' ', glob 'hax/*.c.inc'), }, REPOSITORY => [ github => 'mauke' ], HARNESS_OPTIONS => ['j4'], }; Function-Parameters-2.002004/Makefile.PL0000644000175000017500000001105614412107546016576 0ustar maukemaukeuse strict; use warnings; use ExtUtils::MakeMaker; use File::Spec (); use File::Find (); sub MY::postamble { my ($self, %args) = @_; if ((my $harness_options = delete $args{HARNESS_OPTIONS}) && $self->can('is_make_type')) { my $value = join ':', @$harness_options; if ($self->is_make_type('gmake')) { $args{text} .= "export HARNESS_OPTIONS := $value\n"; } elsif ($self->is_make_type('nmake')) { $args{text} .= "!if [set HARNESS_OPTIONS=$value]\n!endif\n"; } } $args{text} || '' } sub find_tests_recursively_in { my ($dir) = @_; -d $dir or die "$dir is not a directory"; my %seen; my $wanted = sub { /\.t\z/ or return; my $directories = (File::Spec->splitpath($File::Find::name))[1]; my $depth = grep $_ ne '', File::Spec->splitdir($directories); $seen{$depth} = 1; }; File::Find::find($wanted, $dir); join ' ', map { $dir . '/*' x $_ . '.t' } sort { $a <=> $b } keys %seen } $::MAINT_MODE = !-f 'META.yml'; my $settings_file = 'Makefile_PL_settings.plx'; my %settings = %{do "./$settings_file" or die "Internal error: can't do $settings_file: ", $@ || $!}; (do './maint/eumm-fixup.pl' || die $@ || $!)->(\%settings) if $::MAINT_MODE; { $settings{depend}{Makefile} .= " $settings_file"; $settings{LICENSE} ||= 'perl'; $settings{PL_FILES} ||= {}; $settings{CONFIGURE_REQUIRES}{strict} ||= 0; $settings{CONFIGURE_REQUIRES}{warnings} ||= 0; $settings{CONFIGURE_REQUIRES}{'File::Find'} ||= 0; $settings{CONFIGURE_REQUIRES}{'File::Spec'} ||= 0; for ($settings{CONFIGURE_REQUIRES}{'ExtUtils::MakeMaker'}) { $_ = '7.0' if !$_ || $_ < 7; } my $module_file = $settings{NAME}; $module_file =~ s!::!/!g; $module_file = "lib/$module_file.pm"; $settings{VERSION_FROM} ||= $module_file; $settings{ABSTRACT_FROM} ||= $module_file; $settings{test}{TESTS} ||= do { my $extra_test_dirs = delete $settings{EXTRA_TEST_DIRS}; join ' ', map find_tests_recursively_in($_), 't', @{$extra_test_dirs || []} }; $settings{DISTNAME} ||= do { my $name = $settings{NAME}; $name =~ s!::!-!g; $name }; $settings{clean}{FILES} ||= "$settings{DISTNAME}-*"; $settings{dist}{COMPRESS} ||= 'gzip -9f'; $settings{dist}{SUFFIX} ||= '.gz'; my $version = $settings{VERSION} || MM->parse_version($settings{VERSION_FROM}); if ($version =~ s/-TRIAL[0-9]*\z//) { $settings{META_MERGE}{release_status} ||= 'unstable'; $settings{META_MERGE}{version} ||= $version; $settings{XS_VERSION} ||= $version; } $settings{META_MERGE}{'meta-spec'}{version} ||= 2; $settings{META_MERGE}{dynamic_config} ||= 0; push @{$settings{META_MERGE}{no_index}{directory}}, 'xt'; if (my $dev = delete $settings{DEVELOP_REQUIRES}) { @{$settings{META_MERGE}{prereqs}{develop}{requires}}{keys %$dev} = values %$dev; } if (my $rec = delete $settings{RECOMMENDS}) { @{$settings{META_MERGE}{prereqs}{runtime}{recommends}}{keys %$rec} = values %$rec; } if (my $sug = delete $settings{SUGGESTS}) { @{$settings{META_MERGE}{prereqs}{runtime}{suggests}}{keys %$sug} = values %$sug; } if (my $repo = delete $settings{REPOSITORY}) { if (ref($repo) eq 'ARRAY') { my ($type, @args) = @$repo; if ($type eq 'github') { my ($account, $project) = @args; $project ||= '%d'; $project =~ s{%(L?)(.)}{ my $x = $2 eq '%' ? '%' : $2 eq 'd' ? $settings{DISTNAME} : $2 eq 'm' ? $settings{NAME} : die "Internal error: unknown placeholder %$1$2"; $1 ? lc($x) : $x }seg; my $addr = "github.com/$account/$project"; $repo = { type => 'git', url => "git://$addr", web => "https://$addr", }; } else { die "Internal error: unknown REPOSITORY type '$type'"; } } ref($repo) eq 'HASH' or die "Internal error: REPOSITORY must be a hashref, not $repo"; @{$settings{META_MERGE}{resources}{repository}}{keys %$repo} = values %$repo; } if (my $harness_options = delete $settings{HARNESS_OPTIONS}) { $settings{postamble}{HARNESS_OPTIONS} = $harness_options; } } WriteMakefile %settings; Function-Parameters-2.002004/META.json0000664000175000017500000000371514454414615016256 0ustar maukemauke{ "abstract" : "define functions and methods with parameter lists (\"subroutine signatures\")", "author" : [ "Lukas Mai " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Function-Parameters", "no_index" : { "directory" : [ "t", "inc", "xt" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "7.0", "File::Find" : "0", "File::Spec" : "0", "strict" : "0", "warnings" : "0" } }, "develop" : { "requires" : { "Moose" : "0", "MooseX::Types" : "0", "Pod::Markdown" : "3.005", "Pod::Text" : "4.09", "Sub::Name" : "0", "Test::Deep" : "0", "Test::Pod" : "1.22", "aliased" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Scalar::Util" : "0", "XSLoader" : "0", "perl" : "5.014000", "warnings" : "0" } }, "test" : { "requires" : { "FindBin" : "0", "Hash::Util" : "0.07", "Test::Fatal" : "0", "Test::More" : "0", "constant" : "0", "strict" : "0", "utf8" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/mauke/Function-Parameters", "web" : "https://github.com/mauke/Function-Parameters" } }, "version" : "2.002004", "x_serialization_backend" : "JSON::PP version 4.16" } Function-Parameters-2.002004/t/0000755000175000017500000000000014454414615015070 5ustar maukemaukeFunction-Parameters-2.002004/t/03-compiles.t0000644000175000017500000000215314410647303017303 0ustar maukemauke#!perl use Test::More tests => 10; use warnings FATAL => 'all'; use strict; use Function::Parameters { clathod => 'classmethod' }; clathod id_1() { $class } clathod id_2 ( ) : #hello prototype( $ ) {@_ == 0 or return; $class } clathod## id_3 ## ( ## # ) ##AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA { ## $class## } ## clathod add($y) { $class + $y } clathod mymap(@args) :prototype(&@) { my @res; for (@args) { push @res, $class->($_); } @res } clathod fac_1() { $class < 2 ? 1 : $class * fac_1 $class - 1 } clathod fac_2() :prototype($) { $class < 2 ? 1 : $class * fac_2 $class - 1 } ok id_1 1; ok id_1(1), 'basic sanity'; ok id_2 1, 'simple prototype'; ok id_3(1), 'definition over multiple lines'; is add(2, 2), 4, '2 + 2 = 4'; is add(39, 3), 42, '39 + 3 = 42'; is_deeply [mymap { $_ * 2 } 2, 3, 5, 9], [4, 6, 10, 18], 'mymap works'; is fac_1(5), 120, 'fac_1'; is fac_2 6, 720, 'fac_2'; is clathod ($y) { $class . $y }->(clathod () { $class + 1 }->(3), clathod () { $class * 2 }->(1)), '42', 'anonyfun'; Function-Parameters-2.002004/t/name_2.fail0000644000175000017500000000037513235057757017101 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters { func => { name => 'required', }, f => { name => 'prohibited', }, method => { name => 'required', shift => '$this', }, }; f bad() { } Function-Parameters-2.002004/t/strict_5.fail0000644000175000017500000000016613235057757017472 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters { spike => { rarity => 'best', }, }; 'ok' Function-Parameters-2.002004/t/install.t0000644000175000017500000000356213235057757016737 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 22; use constant MODIFIERS => qw( before after around augment override ); use Function::Parameters qw(:modifiers :std), { map +("${_}_c" => { defaults => $_, runtime => 0 }), MODIFIERS }; is eval 'before () {}', undef; like $@, qr/\bexpecting a function name\b/; my $test_pkg; { package NotMain; BEGIN { $test_pkg = __PACKAGE__; } my $TRACE; fun TRACE($str) { $TRACE .= " $str"; } fun getT() { my $r = $TRACE; $TRACE = ''; $r } BEGIN { for my $m (::MODIFIERS) { my $sym = do { no strict 'refs'; \*$m }; *$sym = fun ($name, $body) { TRACE "$m($name)"; $body->('A', 'B', 'C'); }; } } BEGIN { ::is getT, undef; } ::is getT, ''; around_c k_1($x) { TRACE "k_1($orig, $self, $x | @_)"; } around k_2($x) { TRACE "k_2($orig, $self, $x | @_)"; } BEGIN { ::is getT, ' around(k_1) k_1(A, B, C | C)'; } ::is getT, ' around(k_2) k_2(A, B, C | C)'; before_c k_3($x, $y) { TRACE "k_3($self, $x, $y | @_)"; } before k_4($x, $y) { TRACE "k_4($self, $x, $y | @_)"; } BEGIN { ::is getT, ' before(k_3) k_3(A, B, C | B C)'; } ::is getT, ' before(k_4) k_4(A, B, C | B C)'; after_c k_5($x, $y) { TRACE "k_5($self, $x, $y | @_)"; } after k_6($x, $y) { TRACE "k_6($self, $x, $y | @_)"; } BEGIN { ::is getT, ' after(k_5) k_5(A, B, C | B C)'; } ::is getT, ' after(k_6) k_6(A, B, C | B C)'; } BEGIN { for my $i (1 .. 6) { my $m = "k_$i"; is $test_pkg->can($m), undef, "$test_pkg->can($m) is undef at compile time"; } } for my $i (1 .. 6) { my $m = "k_$i"; is $test_pkg->can($m), undef, "$test_pkg->can($m) is undef at runtime"; } Function-Parameters-2.002004/t/precedence.t0000644000175000017500000000150413235057757017360 0ustar maukemauke#!perl use Test::More tests => 11; use warnings FATAL => 'all'; use strict; use Function::Parameters; fun four() { 2 + 2 } fun five() { 1 + four } fun quantum(@) :prototype() {; 0xf00d } is four, 4, "basic sanity 1"; is five, 5, "basic sanity 2"; is quantum, 0xf00d, "basic sanity 3"; is quantum / 2 #/ , 0xf00d / 2, "basic sanity 4 - () proto"; is eval('my $x = fun forbidden() {}'), undef, "statements aren't expressions"; like $@, qr/expect.*parameter list/; is eval('my $x = { fun forbidden() {} }'), undef, "statements aren't expressions 2 - electric boogaloo"; like $@, qr/expect.*parameter list/; is fun () { join '.', five, four }->(), '5.4', "can immedicall anon subs"; is 0 * fun () {} + 42, 42, "* binds tighter than +"; is 0 * fun () { quantum / q#/ } # } + 42, 42, "* binds tighter than + 2 - electric boogaloo"; Function-Parameters-2.002004/t/regress.t0000644000175000017500000000123413235057757016735 0ustar maukemauke#!perl use Test::More tests => 21; use warnings FATAL => 'all'; use strict; use Function::Parameters qw(:lax); fun mk_counter($i) { fun () { $i++ } } method nop() {} fun fnop($x, $y, $z) { } is_deeply [nop], []; is_deeply [main->nop], []; is_deeply [nop 1], []; is scalar(nop), undef; is scalar(nop 2), undef; is_deeply [fnop], []; is_deeply [fnop 3, 4], []; is scalar(fnop), undef; is scalar(fnop 5, 6), undef; my $f = mk_counter 0; my $g = mk_counter 10; my $h = mk_counter 50; is $f->(), 0; is $g->(), 10; is $h->(), 50; is $f->(), 1; is $g->(), 11; is $h->(), 51; is $f->(), 2; is $f->(), 3; is $f->(), 4; is $g->(), 12; is $h->(), 52; is $g->(), 13; Function-Parameters-2.002004/t/02-compiles.t0000644000175000017500000000206514410647303017304 0ustar maukemauke#!perl use Test::More tests => 10; use warnings FATAL => 'all'; use strict; use Function::Parameters; method id_1() { $self } method id_2 ( ) : #hello prototype( $ ) {@_ == 0 or return; $self } method## id_3 ## ( ## # ) ##AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA { ## $self ## } ## method add($y) { $self + $y } method mymap(@args) :prototype(&@) { my @res; for (@args) { push @res, $self->($_); } @res } method fac_1() { $self < 2 ? 1 : $self * fac_1 $self - 1 } method fac_2() :prototype($) { $self < 2 ? 1 : $self * fac_2 $self - 1 } ok id_1 1; ok id_1(1), 'basic sanity'; ok id_2 1, 'simple prototype'; ok id_3(1), 'definition over multiple lines'; is add(2, 2), 4, '2 + 2 = 4'; is add(39, 3), 42, '39 + 3 = 42'; is_deeply [mymap { $_ * 2 } 2, 3, 5, 9], [4, 6, 10, 18], 'mymap works'; is fac_1(5), 120, 'fac_1'; is fac_2 6, 720, 'fac_2'; is method ($y) { $self . $y }->(method () { $self + 1 }->(3), method () { $self * 2 }->(1)), '42', 'anonyfun'; Function-Parameters-2.002004/t/types_parse.t0000644000175000017500000000026013235057757017617 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More; use Function::Parameters qw(:strict); ok !eval 'fun foo(X[['; like $@, qr/missing type name/; done_testing; Function-Parameters-2.002004/t/types_caller.t0000644000175000017500000000360314406543317017744 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 20; { package MyTC; sub new { my $class = shift; bless {}, $class } sub check { 1 } sub get_message { die "Internal error: get_message"; } } my ($reify_arg, @reify_caller); sub take_em { my $t = $reify_arg; $reify_arg = undef; $t, splice @reify_caller } use Function::Parameters { fun => { defaults => 'function_strict', reify_type => sub { @_ == 1 or die "WTF: (@_)"; $_[0] =~ /\ADie\[(.*)\]\z/s and die "$1\n"; $reify_arg = $_[0]; @reify_caller = caller; MyTC->new }, }, }; { my ($t, @c); BEGIN { ($t, @c) = take_em; } is $t, undef; is @c, 0; } { package SineWeave; #line 666 "abc.def" fun foo(time [ time [ time ] ] $x) {} #line 56 "t/types_caller.t" } { my ($t, @c); BEGIN { ($t, @c) = take_em; } is $t, 'time[time[time]]'; is $c[0], 'SineWeave'; is $c[1], 'abc.def'; is $c[2], 666; } { { package SineWeave::InEvalOutside; eval q{#line 500 "abc2.def" fun foo2(A[B] | C::D | E::F [ G, H::I, J | K[L], M::N::O [ P::Q, R ] | S::T ] $x) {} }; } is $@, ''; my ($t, @c) = take_em; is $t, 'A[B]|C::D|E::F[G,H::I,J|K[L],M::N::O[P::Q,R]|S::T]'; is $c[0], 'SineWeave::InEvalOutside'; is $c[1], 'abc2.def'; is $c[2], 500; } { { eval q{#line 500 "abc3.def" package SineWeave::InEvalInside; fun foo3(Any $x) {} }; } is $@, ''; my ($t, @c) = take_em; is $t, 'Any'; is $c[0], 'SineWeave::InEvalInside'; is $c[1], 'abc3.def'; is $c[2], 501; } { is eval q{ fun foo4(Die[blaue[Blume]] $x) {} 1 }, undef; is $@, "blaue[Blume]\n"; my ($t, @c) = take_em; is $t, undef; is @c, 0; } Function-Parameters-2.002004/t/strict_4.fail0000644000175000017500000000013013235057757017460 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters; fun bad_4(@y, @z) {} 'ok' Function-Parameters-2.002004/t/name_4.fail0000644000175000017500000000043113235057757017074 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters { func => { name => 'required', }, f => { name => 'prohibited', }, method => { name => 'required', shift => '$this', }, }; method bad2() { my $what = $self; } Function-Parameters-2.002004/t/recursion.t0000644000175000017500000000444213235057757017300 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 26; use Function::Parameters qw(:strict); fun foo_r($depth, $fst, $snd) { return [$fst, $snd, $snd - $fst] if $depth <= 0; $fst++; my $thd = foo_r $depth - 1, $fst + $snd, $fst * $snd; $snd++; return [$fst, $snd, $thd]; } fun foo_o($depth, $fst = 1, $snd = 2) { return [$fst, $snd, $snd - $fst] if $depth <= 0; $fst++; my $thd = foo_o $depth - 1, $fst + $snd, $fst * $snd; $snd++; return [$fst, $snd, $thd]; } fun foo_nr(:$depth, :$fst, :$snd) { return [$fst, $snd, $snd - $fst] if $depth <= 0; $fst++; my $thd = foo_nr snd => $fst * $snd, depth => $depth - 1, fst => $fst + $snd; $snd++; return [$fst, $snd, $thd]; } fun foo_no(:$depth, :$fst = 1, :$snd = 2) { return [$fst, $snd, $snd - $fst] if $depth <= 0; $fst++; my $thd = foo_no snd => $fst * $snd, depth => $depth - 1, fst => $fst + $snd; $snd++; return [$fst, $snd, $thd]; } for my $f ( \&foo_r, \&foo_o, map { my $f = $_; fun ($d, $x, $y) { $f->(depth => $d, snd => $y, fst => $x) } } \&foo_nr, \&foo_no ) { is_deeply $f->(0, 3, 5), [3, 5, 2]; is_deeply $f->(1, 3, 5), [4, 6, [9, 20, 11]]; is_deeply $f->(2, 3, 5), [4, 6, [10, 21, [30, 200, 170]]]; } fun slurpy(:$n, %rest) { [$n, \%rest] } { is_deeply slurpy(a => 1, b => 2, n => 9), [9, {a => 1, b => 2}]; my $sav1 = slurpy(n => 5); is_deeply $sav1, [5, {}]; my $sav2 = slurpy(n => 6, a => 3); is_deeply $sav2, [6, {a => 3}]; is_deeply $sav1, [5, {}]; is_deeply slurpy(b => 4, n => 7, hello => "world"), [7, {hello => "world", b => 4}]; is_deeply $sav1, [5, {}]; is_deeply $sav2, [6, {a => 3}]; } { { package TimelyDestruction; method new($class: $f) { bless {on_destroy => $f}, $class } method DESTROY() { $self->{on_destroy}(); } } use Function::Parameters qw(:lax); fun bar(:$n) { defined $n ? $n + 1 : "nope" } is bar(n => undef), "nope"; is bar(n => 2), 3; is bar, "nope"; my $dead = 0; { my $o = TimelyDestruction->new(fun () { $dead++ }); is bar(n => $o), $o + 1, "this juice is bangin yo"; } is $dead, 1; $dead = 999; is bar(n => 3), 4; is $dead, 999; } Function-Parameters-2.002004/t/types_auto.t0000644000175000017500000000425514411246756017461 0ustar maukemauke#!perl use warnings qw(all FATAL uninitialized); use strict; use Test::More tests => 12; { package MyTC; use overload '~' => 'complement', '|' => 'union', '&' => 'intersection', '/' => 'alternative', '&{}' => 'apply'; sub new { my ($class, $name) = @_; bless { _name => $name }, $class } sub name { $_[0]{_name} } sub check { 1 } sub get_message { die "Internal error: get_message: ${\$_[0]->name}"; } sub complement { my ($x) = @_; ref($x)->new('~' . $x->name) } sub union { my ($x, $y) = @_; ref($x)->new('(' . $x->name . '|' . $y->name . ')') } sub intersection { my ($x, $y) = @_; ref($x)->new('(' . $x->name . '&' . $y->name . ')') } sub alternative { my ($x, $y) = @_; ref($x)->new('(' . $x->name . '/' . $y->name . ')') } sub apply { my $self = shift; sub { return $self if !@_; @_ == 1 or die "Internal error: apply->(@_)"; my @args = @{$_[0]}; ref($self)->new($self->name . '[' . join(',', map $_->name, @args) . ']') } } } use Function::Parameters; BEGIN { for my $suffix ('a' .. 't') { my $name = "T$suffix"; my $obj = MyTC->new($name); my $symbol = do { no strict 'refs'; \*$name }; *$symbol = sub { $obj->(@_) }; } } is eval 'fun (NoSuchType $x) {}', undef; like $@, qr/\AUndefined type name main::NoSuchType /; is eval 'fun (("NoSuchType") $x) {}', undef; like $@, qr/\AUndefined type name main::NoSuchType /; for my $f ( fun ( Ta[Tb] | ~Td | Tf [ (Tg), ~~ ~ Ti | (Ta | Tb & Tc & Td), Tj | Tk[Tl], To [ Tq, Tr ] | Tt ] & Ta / Tb | Tc / Td & Te $x) {}, fun ((' Ta[Tb] | ~Td | Tf [ (Tg), ~~ ~ Ti | (Ta | Tb & Tc & Td), Tj | Tk[Tl], To [ Tq, Tr ] | Tt ] & Ta / Tb | Tc / Td & Te ') $x) {}, ) { my $m = Function::Parameters::info $f; is my ($xi) = $m->positional_required, 1; is $xi->name, '$x'; my $t = $xi->type; is ref $t, 'MyTC'; 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))'; } Function-Parameters-2.002004/t/threads.t0000644000175000017500000000107613235057757016721 0ustar maukemauke#!perl use Test::More eval { require threads; threads->import; 1 } ? (tests => 2) : (skip_all => "threads required for testing threads"); use warnings FATAL => 'all'; use strict; use Function::Parameters; fun concat3($x, $xxx, $xx) { my $helper = eval q{ fun ($x, $y) { $x . $y } }; return $x . $helper->($xxx, $xx); } my $thr = threads->create(fun ($val) { concat3 'first (', $val, ') last'; }, 'middle'); my $r1 = concat3 'foo', threads->tid, 'bar'; my $r2 = $thr->join; is $r1, 'foo0bar'; is $r2, 'first (middle) last'; Function-Parameters-2.002004/t/unicode.t0000644000175000017500000000140213235057757016706 0ustar maukemauke#!perl use utf8; use Test::More tests => 19; use warnings FATAL => 'all'; use strict; use Function::Parameters qw(:lax); fun hörps($x) { $x * 2 } fun drau($spın̈al_tap) { $spın̈al_tap * 3 } fun ääää($éééééé) { $éééééé * 4 } is hörps(10), 20; is drau(11), 33; is ääää(12), 48; is eval('fun á(){} 1'), 1; is á(42), undef; is eval('fun ́(){} 1'), undef; like $@, qr/ parameter list/; is eval(q), undef; like $@, qr/ parameter list/; is eval('fun ::hi(){} 1'), 1; is hi(42), undef; is eval('fun 123(){} 1'), undef; like $@, qr/ parameter list/; is eval('fun main::234(){} 1'), undef; like $@, qr/ parameter list/; is eval('fun m123(){} 1'), 1; is m123(42), undef; is eval('fun ::m234(){} 1'), 1; is m234(42), undef; Function-Parameters-2.002004/t/types_custom_3.t0000644000175000017500000000146513235057757020251 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 8; { package TX; sub check { 1 } our $obj; BEGIN { $obj = bless {}, 'TX'; } } use Function::Parameters { fun => { strict => 1, reify_type => sub { my ($type) = @_; my $package = caller; if ($package ne $type) { my (undef, $file, $line) = @_; diag ""; diag "! $file : $line"; } is $package, $type; $TX::obj }, }, }; fun f1(main $x) {} fun Asdf::f1(main $x) {} { package Foo::Bar::Baz; fun f1(Foo::Bar::Baz $x) {} fun Ghjk::f1(Foo::Bar::Baz $x) {} package AAA; fun f1(AAA $x) {} fun main::f2(AAA $x) {} } fun f3(main $x) {} fun Ghjk::f2(main $x) {} Function-Parameters-2.002004/t/strict_2.fail0000644000175000017500000000013013235057757017456 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters; fun bad_2(@x, $y) {} 'ok' Function-Parameters-2.002004/t/01-compiles.t0000644000175000017500000000201414410647303017275 0ustar maukemauke#!perl use Test::More tests => 10; use warnings FATAL => 'all'; use strict; use Function::Parameters; fun id_1($x) { $x } fun id_2 ( $x ) : #hello prototype( $ ) {@_ == 1 or return; $x } fun id_3 ## ( $x ## ) ##AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA { ## $x ## } ## fun add($x, $y) { $x + $y } fun mymap($fun, @args) :prototype(&@) { my @res; for (@args) { push @res, $fun->($_); } @res } fun fac_1($n) { $n < 2 ? 1 : $n * fac_1 $n - 1 } fun fac_2($n) :prototype($) { $n < 2 ? 1 : $n * fac_2 $n - 1 } ok id_1 1; ok id_1(1), 'basic sanity'; ok id_2 1, 'simple prototype'; ok id_3(1), 'definition over multiple lines'; is add(2, 2), 4, '2 + 2 = 4'; is add(39, 3), 42, '39 + 3 = 42'; is_deeply [mymap { $_ * 2 } 2, 3, 5, 9], [4, 6, 10, 18], 'mymap works'; is fac_1(5), 120, 'fac_1'; is fac_2 6, 720, 'fac_2'; is fun ($x, $y) { $x . $y }->(fun ($foo) { $foo + 1 }->(3), fun ($bar) { $bar * 2 }->(1)), '42', 'anonyfun'; Function-Parameters-2.002004/t/lifetime.t0000644000175000017500000000205213235057757017060 0ustar maukemaukeuse strict; use warnings FATAL => 'all'; use Test::More tests => 12; use Function::Parameters { fun_cx => { defaults => 'function', install_sub => 'jamitin' }, fun_rx => { defaults => 'function', install_sub => 'jamitin', runtime => 1 }, }; use Hash::Util qw(fieldhash); my %watcher; BEGIN { fieldhash %watcher; } my $calls; BEGIN { $calls = 0; } sub jamitin { my ($name, $body) = @_; $watcher{$body} = $name; $calls++; } my $forceclosure; BEGIN { is $calls, 0; is_deeply \%watcher, {}; } BEGIN { jamitin 'via_sub_cx', sub { $forceclosure }; } BEGIN { is $calls, 1; is_deeply \%watcher, {}; } fun_cx via_fun_cx(@) { $forceclosure } BEGIN { is $calls, 2; is_deeply \%watcher, {}; } BEGIN { $calls = 0; } is $calls, 0; is_deeply \%watcher, {}; jamitin 'via_sub_rx', sub { $forceclosure }; is $calls, 1; is_deeply \%watcher, {}; fun_rx via_fun_rx(@) { $forceclosure } is $calls, 2; TODO: { local $TODO = 'bug/leak: runtime-installed subs are kept alive somehow'; is_deeply \%watcher, {}; } Function-Parameters-2.002004/t/named_params.t0000644000175000017500000002424013235057757017714 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 134; use Test::Fatal; use Function::Parameters qw(:strict); sub compile_fail { my ($src, $re, $name) = @_; my $tb = Test::More->builder; $tb->is_eq(eval $src, undef); $tb->like($@, $re, $name || ()); } compile_fail 'fun (:$n1, $p1) {}', qr/\bpositional\b.+\bnamed\b/; compile_fail 'fun (@rest, :$n1) {}', qr/"\$n1" can't appear after slurpy parameter "\@rest"/; compile_fail 'fun (:$n1, :$n1) {}', qr/\$n1\b.+\btwice\b/; compile_fail 'method (:$ni:) {}', qr/\binvocant\b.+\$ni\b.+\bnamed\b/; fun name_1(:$n1) { [$n1, @_] } like exception { name_1 }, qr/Too few arguments/; like exception { name_1 'n1' }, qr/Too few arguments/; like exception { name_1 'asdf' }, qr/Too few arguments/; like exception { name_1 n1 => 0, huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply name_1(n1 => undef), [undef, n1 => undef]; is_deeply name_1(n1 => 'a'), ['a', n1 => 'a']; is_deeply name_1(n1 => 'a', n1 => 'b'), ['b', n1 => 'a', n1 => 'b']; is_deeply name_1(n1 => 'a', n1 => undef), [undef, n1 => 'a', n1 => undef]; fun name_0_1(:$n1 = 'd') { [$n1, @_] } is_deeply name_0_1, ['d']; like exception { name_0_1 'n1' }, qr/Odd number/; like exception { name_0_1 'asdf' }, qr/Odd number/; like exception { name_0_1 huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply name_0_1(n1 => 'a'), ['a', n1 => 'a']; is_deeply name_0_1(n1 => 'a', n1 => 'b'), ['b', n1 => 'a', n1 => 'b']; is_deeply name_0_1(n1 => 'a', n1 => undef), [undef, n1 => 'a', n1 => undef]; fun pos_1_name_1($p1, :$n1) { [$p1, $n1, @_] } like exception { pos_1_name_1 }, qr/Too few arguments/; like exception { pos_1_name_1 42 }, qr/Too few arguments/; like exception { pos_1_name_1 42, 'n1' }, qr/Too few arguments/; like exception { pos_1_name_1 42, 'asdf' }, qr/Too few arguments/; like exception { pos_1_name_1 42, n1 => 0, huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply pos_1_name_1(42, n1 => undef), [42, undef, 42, n1 => undef]; is_deeply pos_1_name_1(42, n1 => 'a'), [42, 'a', 42, n1 => 'a']; is_deeply pos_1_name_1(42, n1 => 'a', n1 => 'b'), [42, 'b', 42, n1 => 'a', n1 => 'b']; is_deeply pos_1_name_1(42, n1 => 'a', n1 => undef), [42, undef, 42, n1 => 'a', n1 => undef]; compile_fail 'fun pos_0_1_name_1($p1 = "e", :$n1) { [$p1, $n1, @_] }', qr/\boptional positional\b.+\brequired named\b/; fun pos_1_name_0_1($p1, :$n1 = 'd') { [$p1, $n1, @_] } like exception { pos_1_name_0_1 }, qr/Too few arguments/; is_deeply pos_1_name_0_1(42), [42, 'd', 42]; like exception { pos_1_name_0_1 42, 'n1' }, qr/Odd number/; like exception { pos_1_name_0_1 42, 'asdf' }, qr/Odd number/; like exception { pos_1_name_0_1 42, huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply pos_1_name_0_1(42, n1 => undef), [42, undef, 42, n1 => undef]; is_deeply pos_1_name_0_1(42, n1 => 'a'), [42, 'a', 42, n1 => 'a']; is_deeply pos_1_name_0_1(42, n1 => 'a', n1 => 'b'), [42, 'b', 42, n1 => 'a', n1 => 'b']; is_deeply pos_1_name_0_1(42, n1 => 'a', n1 => undef), [42, undef, 42, n1 => 'a', n1 => undef]; fun pos_0_1_name_0_1($p1 = 'e', :$n1 = 'd') { [$p1, $n1, @_] } is_deeply pos_0_1_name_0_1, ['e', 'd']; is_deeply pos_0_1_name_0_1(42), [42, 'd', 42]; like exception { pos_0_1_name_0_1 42, 'n1' }, qr/Odd number/; like exception { pos_0_1_name_0_1 42, 'asdf' }, qr/Odd number/; like exception { pos_0_1_name_0_1 42, huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply pos_0_1_name_0_1(42, n1 => undef), [42, undef, 42, n1 => undef]; is_deeply pos_0_1_name_0_1(42, n1 => 'a'), [42, 'a', 42, n1 => 'a']; is_deeply pos_0_1_name_0_1(42, n1 => 'a', n1 => 'b'), [42, 'b', 42, n1 => 'a', n1 => 'b']; is_deeply pos_0_1_name_0_1(42, n1 => 'a', n1 => undef), [42, undef, 42, n1 => 'a', n1 => undef]; fun name_1_slurp(:$n1, @rest) { [$n1, \@rest, @_] } like exception { name_1_slurp }, qr/Too few arguments/; like exception { name_1_slurp 'n1' }, qr/Too few arguments/; like exception { name_1_slurp 'asdf' }, qr/Too few arguments/; like exception { name_1_slurp huh => 1 }, qr/missing named\b.+\bn1\b/; is_deeply name_1_slurp(n1 => 'a'), ['a', [], n1 => 'a']; like exception { name_1_slurp n1 => 'a', 'n1' }, qr/Odd number/; is_deeply name_1_slurp(n1 => 'a', foo => 'bar'), ['a', [foo => 'bar'], n1 => 'a', foo => 'bar']; is_deeply name_1_slurp(foo => 'bar', n1 => 'a', foo => 'quux'), ['a', [foo => 'quux'], foo => 'bar', n1 => 'a', foo => 'quux']; fun name_0_1_slurp(:$n1 = 'd', @rest) { [$n1, \@rest, @_] } is_deeply name_0_1_slurp, ['d', []]; like exception { name_0_1_slurp 'n1' }, qr/Odd number/; like exception { name_0_1_slurp 'asdf' }, qr/Odd number/; is_deeply name_0_1_slurp(n1 => 'a'), ['a', [], n1 => 'a']; like exception { name_0_1_slurp n1 => 'a', 'n1' }, qr/Odd number/; is_deeply name_0_1_slurp(a => 'b'), ['d', [a => 'b'], a => 'b']; is_deeply name_0_1_slurp(n1 => 'a', foo => 'bar'), ['a', [foo => 'bar'], n1 => 'a', foo => 'bar']; is_deeply name_0_1_slurp(foo => 'bar', n1 => 'a', foo => 'quux'), ['a', [foo => 'quux'], foo => 'bar', n1 => 'a', foo => 'quux']; fun name_2(:$n1, :$n2) { [$n1, $n2, @_] } like exception { name_2 }, qr/Too few arguments/; like exception { name_2 'n1' }, qr/Too few arguments/; like exception { name_2 'asdf' }, qr/Too few arguments/; like exception { name_2 huh => 1 }, qr/Too few arguments/; like exception { name_2 n1 => 'a' }, qr/Too few arguments/; like exception { name_2 n1 => 'a', n1 => 'b' }, qr/missing named\b.+\bn2\b/; like exception { name_2 n2 => 'a' }, qr/Too few arguments/; like exception { name_2 n2 => 'a', n2 => 'b' }, qr/missing named\b.+\bn1\b/; like exception { name_2 n1 => 'a', 'n2' }, qr/Too few arguments/; like exception { name_2 n1 => 'a', 'asdf' }, qr/Too few arguments/; like exception { name_2 n2 => 'b', n1 => 'a', huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply name_2(n2 => 42, n1 => undef), [undef, 42, n2 => 42, n1 => undef]; is_deeply name_2(n2 => 42, n1 => 'a'), ['a', 42, n2 => 42, n1 => 'a']; is_deeply name_2(n2 => 42, n1 => 'a', n1 => 'b'), ['b', 42, n2 => 42, n1 => 'a', n1 => 'b']; is_deeply name_2(n2 => 42, n1 => 'a', n1 => undef), [undef, 42, n2 => 42, n1 => 'a', n1 => undef]; is_deeply name_2(n1 => undef, n2 => 42), [undef, 42, n1 => undef, n2 => 42]; is_deeply name_2(n1 => 'a', n2 => 42), ['a', 42, n1 => 'a', n2 => 42]; is_deeply name_2(n1 => 'a', n1 => 'b', n2 => 42), ['b', 42, n1 => 'a', n1 => 'b', n2 => 42]; is_deeply name_2(n1 => 'a', n2 => 42, n1 => undef), [undef, 42, n1 => 'a', n2 => 42, n1 => undef]; fun name_1_2(:$n1, :$n2 = 'f') { [$n1, $n2, @_] } like exception { name_1_2 }, qr/Too few arguments/; like exception { name_1_2 'n1' }, qr/Too few arguments/; like exception { name_1_2 'asdf' }, qr/Too few arguments/; like exception { name_1_2 n1 => 0, huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply name_1_2(n1 => 'a'), ['a', 'f', n1 => 'a']; is_deeply name_1_2(n1 => 'a', n1 => 'b'), ['b', 'f', n1 => 'a', n1 => 'b']; like exception { name_1_2 n2 => 'a' }, qr/missing named\b.+\bn1\b/; like exception { name_1_2 n2 => 'a', n2 => 'b' }, qr/missing named\b.+\bn1\b/; like exception { name_1_2 n1 => 'a', 'n2' }, qr/Odd number/; like exception { name_1_2 n1 => 'a', 'asdf' }, qr/Odd number/; like exception { name_1_2 n2 => 'b', n1 => 'a', huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply name_1_2(n2 => 42, n1 => undef), [undef, 42, n2 => 42, n1 => undef]; is_deeply name_1_2(n2 => 42, n1 => 'a'), ['a', 42, n2 => 42, n1 => 'a']; is_deeply name_1_2(n2 => 42, n1 => 'a', n1 => 'b'), ['b', 42, n2 => 42, n1 => 'a', n1 => 'b']; is_deeply name_1_2(n2 => 42, n1 => 'a', n1 => undef), [undef, 42, n2 => 42, n1 => 'a', n1 => undef]; is_deeply name_1_2(n1 => undef, n2 => 42), [undef, 42, n1 => undef, n2 => 42]; is_deeply name_1_2(n1 => 'a', n2 => 42), ['a', 42, n1 => 'a', n2 => 42]; is_deeply name_1_2(n1 => 'a', n1 => 'b', n2 => 42), ['b', 42, n1 => 'a', n1 => 'b', n2 => 42]; is_deeply name_1_2(n1 => 'a', n2 => 42, n1 => undef), [undef, 42, n1 => 'a', n2 => 42, n1 => undef]; fun name_0_2(:$n1 = 'd', :$n2 = 'f') { [$n1, $n2, @_] } is_deeply name_0_2, ['d', 'f']; like exception { name_0_2 'n1' }, qr/Odd number/; like exception { name_0_2 'asdf' }, qr/Odd number/; like exception { name_0_2 huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply name_0_2(n1 => 'a'), ['a', 'f', n1 => 'a']; is_deeply name_0_2(n1 => 'a', n1 => 'b'), ['b', 'f', n1 => 'a', n1 => 'b']; is_deeply name_0_2(n2 => 'a'), ['d', 'a', n2 => 'a']; is_deeply name_0_2(n2 => 'a', n2 => 'b'), ['d', 'b', n2 => 'a', n2 => 'b']; like exception { name_0_2 n1 => 'a', 'n2' }, qr/Odd number/; like exception { name_0_2 n1 => 'a', 'asdf' }, qr/Odd number/; like exception { name_0_2 n2 => 'b', n1 => 'a', huh => 1 }, qr/\bnamed\b.+\bhuh\b/; is_deeply name_0_2(n2 => 42, n1 => undef), [undef, 42, n2 => 42, n1 => undef]; is_deeply name_0_2(n2 => 42, n1 => 'a'), ['a', 42, n2 => 42, n1 => 'a']; is_deeply name_0_2(n2 => 42, n1 => 'a', n1 => 'b'), ['b', 42, n2 => 42, n1 => 'a', n1 => 'b']; is_deeply name_0_2(n2 => 42, n1 => 'a', n1 => undef), [undef, 42, n2 => 42, n1 => 'a', n1 => undef]; is_deeply name_0_2(n1 => undef, n2 => 42), [undef, 42, n1 => undef, n2 => 42]; is_deeply name_0_2(n1 => 'a', n2 => 42), ['a', 42, n1 => 'a', n2 => 42]; is_deeply name_0_2(n1 => 'a', n1 => 'b', n2 => 42), ['b', 42, n1 => 'a', n1 => 'b', n2 => 42]; is_deeply name_0_2(n1 => 'a', n2 => 42, n1 => undef), [undef, 42, n1 => 'a', n2 => 42, n1 => undef]; fun pos_1_2_name_0_3_slurp($p1, $p2 = 'E', :$n1 = undef, :$n2 = 'A', :$n3 = 'F', @rest) { [$p1, $p2, $n1, $n2, $n3, {@rest}, @_] } like exception { pos_1_2_name_0_3_slurp }, qr/Too few/; is_deeply pos_1_2_name_0_3_slurp('a'), ['a', 'E', undef, 'A', 'F', {}, 'a']; is_deeply pos_1_2_name_0_3_slurp('a', 'b'), ['a', 'b', undef, 'A', 'F', {}, 'a', 'b']; like exception { pos_1_2_name_0_3_slurp 'a', 'b', 'c' }, qr/Odd number/; is_deeply pos_1_2_name_0_3_slurp('a', 'b', 'c', 'd'), ['a', 'b', undef, 'A', 'F', {'c', 'd'}, 'a', 'b', 'c', 'd']; like exception { pos_1_2_name_0_3_slurp 'a', 'b', 'c', 'd', 'e' }, qr/Odd number/; is_deeply pos_1_2_name_0_3_slurp('a', 'b', 'c', 'd', 'e', 'f'), ['a', 'b', undef, 'A', 'F', {'c', 'd', 'e', 'f'}, 'a', 'b', 'c', 'd', 'e', 'f']; is_deeply pos_1_2_name_0_3_slurp('a', 'b', n2 => 'c', n1 => 'd'), ['a', 'b', 'd', 'c', 'F', {}, 'a', 'b', n2 => 'c', n1 => 'd']; is_deeply pos_1_2_name_0_3_slurp('a', 'b', n2 => 'c', beans => 'legume', n1 => 'd'), ['a', 'b', 'd', 'c', 'F', {beans => 'legume'}, 'a', 'b', n2 => 'c', beans => 'legume', n1 => 'd']; Function-Parameters-2.002004/t/types_moose_2.t0000644000175000017500000000662213235057757020060 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More eval { require Moose::Util } ? (tests => 49) : (skip_all => "Moose required for testing types") ; use Test::Fatal; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; fun foo(('Int') $n, ('CodeRef') $f, $x) { $x = $f->($x) for 1 .. $n; $x } is foo(0, fun (@) {}, undef), undef; is foo(0, fun (@) {}, "o hai"), "o hai"; is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; is foo(3, fun (('Str') $x) { "($x)" }, 1.5), "(((1.5)))"; { my $info = Function::Parameters::info \&foo; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 3; is $req[0]->name, '$n'; ok $req[0]->type->equals('Int'); is $req[1]->name, '$f'; ok $req[1]->type->equals('CodeRef'); is $req[2]->name, '$x'; is $req[2]->type, undef; } like exception { foo("ermagerd", fun (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; fun bar( ( do { require Moose; (Function::Parameters::info(\&foo)->positional_required)[0]->type } ) $whoa ) { $whoa * 2 } is bar(21), 42; { my $info = Function::Parameters::info \&bar; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 1; is $req[0]->name, '$whoa'; ok $req[0]->type->equals('Int'); } { my $info = Function::Parameters::info(fun ( (q~ArrayRef [ Int | CodeRef ]~ )@nom) {}); is $info->invocant, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my $slurpy = $info->slurpy; is $slurpy->name, '@nom'; ok $slurpy->type->equals(Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int|CodeRef]')); } { my $phase = 'runtime'; BEGIN { $phase = 'A'; } fun baz ( ( is ( $phase ++ , 'A' ) , 'Int' ) : $marco , ( is ( $phase ++ , 'B' ) , q $ArrayRef[Str]$ ) : $polo ) { [ $marco , $polo ] } BEGIN { is $phase, 'C'; } is $phase, 'runtime'; is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; my $info = Function::Parameters::info \&baz; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_optional, 0; my @req = $info->named_required; is @req, 2; is $req[0]->name, '$marco'; ok $req[0]->type->equals('Int'); is $req[1]->name, '$polo'; ok $req[1]->type->equals('ArrayRef[Str]'); } Function-Parameters-2.002004/t/types_msg.t0000644000175000017500000000421113235057757017273 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 13; use Test::Fatal; use Function::Parameters qw(:std :modifiers); { package DefinedType; method new($class:) { bless {}, $class } method check($x) { defined $x } method get_message($ ) { "UNDEFINED" } } use constant Defined => DefinedType->new; my %stash; fun around($name, $coderef) { $stash{$name} = $coderef; } fun foo(Defined $x, $whatevs, Defined $y, Defined @z) {} like exception { foo(undef, undef, undef, undef) }, qr{\A\QIn fun foo: parameter 1 (\E\$x\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; like exception { foo('def', undef, undef, undef) }, qr{\A\QIn fun foo: parameter 3 (\E\$y\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; like exception { foo('def', undef, 'def', undef) }, qr{\A\QIn fun foo: parameter 4 (\E\@z\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; like exception { foo('def', undef, 'def', 'def', undef) }, qr{\A\QIn fun foo: parameter 4 (\E\@z\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; is exception { foo('def', undef, 'def') }, undef; method bar(Defined $this: Defined $x) {} like exception { bar(undef, undef) }, qr{\A\QIn method bar: invocant (\E\$this\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; like exception { bar('def', undef) }, qr{\A\QIn method bar: parameter 1 (\E\$x\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; is exception { bar('def', 'def') }, undef; around baz(Defined $self, Defined $orig: Defined $x, Defined $y) {} like exception { $stash{baz}(undef, undef, undef, undef) }, qr{\A\QIn around baz: invocant 1 (\E\$self\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; like exception { $stash{baz}('def', undef, undef, undef) }, qr{\A\QIn around baz: invocant 2 (\E\$orig\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; like exception { $stash{baz}('def', 'def', undef, undef) }, qr{\A\QIn around baz: parameter 1 (\E\$x\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; like exception { $stash{baz}('def', 'def', 'def', undef) }, qr{\A\QIn around baz: parameter 2 (\E\$y\Q): UNDEFINED at ${\__FILE__} line ${\__LINE__}.}; is exception { $stash{baz}('def', 'def', 'def', 'def') }, undef; Function-Parameters-2.002004/t/invocant.t0000644000175000017500000001076013235057757017110 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 67; use Test::Fatal; use Function::Parameters; { package Foo; method new($class : ) { return bless { x => 1, y => 2, z => 3, }, $class; } method get_x() { $self->{x} } method get_y($self:) { $self->{y} } method get_z($this:) { $this->{z} } method set_x($val) { $self->{x} = $val; } method set_y($self:$val) { $self->{y} = $val; } method set_z($this: $val) { $this->{z} = $val; } } my $o = Foo->new; ok $o->isa('Foo'), "Foo->new->isa('Foo')"; is $o->get_x, 1; is $o->get_y, 2; is $o->get_z, 3; $o->set_x("A"); $o->set_y("B"); $o->set_z("C"); is $o->get_x, "A"; is $o->get_y, "B"; is $o->get_z, "C"; is method ($x = $self) { "$self $x [@_]" }->('A'), 'A A []'; is eval { $o->get_z(42) }, undef; like $@, qr/Too many arguments/; is eval { $o->set_z }, undef; like $@, qr/Too few arguments/; is eval q{fun ($self:) {}}, undef; like $@, qr/invocant \$self not allowed here/; is eval q{fun ($x : $y) {}}, undef; like $@, qr/invocant \$x not allowed here/; is eval q{method (@x:) {}}, undef; like $@, qr/invocant \@x can't be an array/; is eval q{method (%x:) {}}, undef; like $@, qr/invocant %x can't be a hash/; is eval q{method ($x, $y:) {}}, undef; like $@, qr/\Qnumber of invocants in parameter list (2) differs from number of invocants in keyword definition (1)/; { use Function::Parameters { def => { invocant => 1, strict => 0, } }; def foo1($x) { join ' ', $x, @_ } def foo2($x: $y) { join ' ', $x, $y, @_ } def foo3($x, $y) { join ' ', $x, $y, @_ } is foo1("a"), "a a"; is foo2("a", "b"), "a b b"; is foo3("a", "b"), "a b a b"; is foo1("a", "b"), "a a b"; is foo2("a", "b", "c"), "a b b c"; is foo3("a", "b", "c"), "a b a b c"; } use Function::Parameters { method2 => { defaults => 'method', shift => ['$self1', '$self2' ], }, }; method2 m2_a($x) { "$self1 $self2 $x [@_]" } is m2_a('a', 'b', 'c'), 'a b c [c]'; for my $info (Function::Parameters::info(\&m2_a)) { my @inv = $info->invocants; is_deeply \@inv, [qw($self1 $self2)]; is_deeply [map $_->name, @inv], [qw($self1 $self2)]; is_deeply [map $_->type, @inv], [undef, undef]; is $info->args_min, 3; is $info->args_max, 3; like exception { $info->invocant }, qr/single invocant/; } method2 m2_b($x = $self2, $y = $self1) { "$self1 $self2 $x $y [@_]" } like exception { m2_b('a', 'b', 'c', 'd', 'e') }, qr/^\QToo many arguments for method2 m2_b (expected 4, got 5)/; is m2_b('a', 'b', 'c', 'd'), 'a b c d [c d]'; is m2_b('a', 'b', 'c'), 'a b c a [c]'; is m2_b('a', 'b'), 'a b b a []'; like exception { m2_b('a') }, qr/^\QToo few arguments for method2 m2_b (expected 2, got 1)/; for my $info (Function::Parameters::info(\&m2_b)) { my @inv = $info->invocants; is_deeply \@inv, [qw($self1 $self2)]; is_deeply [map $_->name, @inv], [qw($self1 $self2)]; is_deeply [map $_->type, @inv], [undef, undef]; is $info->args_min, 2; is $info->args_max, 4; like exception { $info->invocant }, qr/single invocant/; } method2 m2_c($t1, $t2:) { "$t1 $t2 [@_]" } like exception { m2_c('a', 'b', 'c') }, qr/^\QToo many arguments for method2 m2_c (expected 2, got 3)/; is m2_c('a', 'b'), 'a b []'; like exception { m2_c('a') }, qr/^\QToo few arguments for method2 m2_c (expected 2, got 1)/; for my $info (Function::Parameters::info(\&m2_c)) { my @inv = $info->invocants; is_deeply \@inv, [qw($t1 $t2)]; is_deeply [map $_->name, @inv], [qw($t1 $t2)]; is_deeply [map $_->type, @inv], [undef, undef]; is $info->args_min, 2; is $info->args_max, 2; like exception { $info->invocant }, qr/single invocant/; } is eval('method2 ($t1, $t2:) { $self1 }'), undef; like $@, qr/^Global symbol "\$self1" requires explicit package name/; is eval('method2 ($self1) {}'), undef; like $@, qr/\$self1 can't appear twice in the same parameter list/; is eval('method2 ($x, $self2) {}'), undef; like $@, qr/\$self2 can't appear twice in the same parameter list/; is eval('method2 m2_z($self: $x) {} 1'), undef; like $@, qr/^\QIn method2 m2_z: number of invocants in parameter list (1) differs from number of invocants in keyword definition (2)/; ok !exists &m2_z; is eval('method2 m2_z($orig, $self, $x: $y) {} 1'), undef; like $@, qr/^\QIn method2 m2_z: number of invocants in parameter list (3) differs from number of invocants in keyword definition (2)/; ok !exists &m2_z; Function-Parameters-2.002004/t/strict.t0000644000175000017500000000123714362360621016563 0ustar maukemaukeuse warnings; use strict; use Test::More tests => 10; use FindBin; for my $fail ( map ["$FindBin::Bin/strict_$_->[0].fail", @$_[1 .. $#$_]], ['1', qr/"\$z" can't appear after slurpy parameter "\@y\"/], ['2', qr/"\$y" can't appear after slurpy parameter "\@x\"/], ['3', qr/"\$z" can't appear after slurpy parameter "%y\"/], ['4', qr/"\@z" can't appear after slurpy parameter "\@y\"/], ['5', qr/Invalid.*rarity/], ) { my ($file, $pat) = @$fail; $@ = undef; my $done = do $file; my $exc = $@; my $err = $!; is $done, undef, "faulty code doesn't load - $file"; $exc or die "$file: $err" if $err; like $exc, $pat; } Function-Parameters-2.002004/t/rename.t0000644000175000017500000000057513235057757016541 0ustar maukemaukeuse strict; use warnings; use Test::More; use Function::Parameters { f => 'function' }; my $add = f ($x, $y) { $x + $y }; is $add->(2, 4), 6; use Function::Parameters { meth_b => 'method', func_b => 'function', }; func_b cat_b($x, $y) { $x . $y } meth_b tac_b($x) { $x . $self } is cat_b('ab', 'cde'), 'abcde'; is tac_b('ab', 'cde'), 'cdeab'; done_testing; Function-Parameters-2.002004/t/types_moosex_2.t0000644000175000017500000000403313235057757020242 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More eval { require MooseX::Types } ? (tests => 34) : (skip_all => "MooseX::Types required for testing types") ; use Test::Fatal; use MooseX::Types::Moose qw(Int Str ArrayRef CodeRef); use Function::Parameters qw(:strict); fun foo(Int $n, CodeRef $f, $x) { $x = $f->($x) for 1 .. $n; $x } is foo(0, fun (@) {}, undef), undef; is foo(0, fun (@) {}, "o hai"), "o hai"; is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; { my $info = Function::Parameters::info \&foo; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 3; is $req[0]->name, '$n'; ok $req[0]->type->equals(Int); is $req[1]->name, '$f'; ok $req[1]->type->equals(CodeRef); is $req[2]->name, '$x'; is $req[2]->type, undef; } like exception { foo("ermagerd", fun (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; fun bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } is bar(21), 42; { my $info = Function::Parameters::info \&bar; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 1; is $req[0]->name, '$whoa'; ok $req[0]->type->equals(Int); } { my $info = Function::Parameters::info(fun ( ArrayRef [ Int | CodeRef ]@nom) {}); is $info->invocant, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my $slurpy = $info->slurpy; is $slurpy->name, '@nom'; ok $slurpy->type->equals(ArrayRef[Int|CodeRef]); } Function-Parameters-2.002004/t/imports.t0000644000175000017500000000663313235057757016770 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 58; use Test::Fatal; { use Function::Parameters {}; # ZERO BABIES is eval('fun foo :() {}; 1'), undef; like $@, qr/syntax error/; } { use Function::Parameters { pound => 'function' }; is eval('fun foo :() {}; 1'), undef; like $@, qr/syntax error/; pound foo_1($x) { $x } is foo_1(2 + 2), 4; like exception { foo_1(5, 6) }, qr/Too many arguments/; no Function::Parameters qw(pound); is eval('pound foo() {}; 1'), undef; like $@, qr/syntax error/; } { use Function::Parameters { pound => 'method' }; is eval('fun foo () {}; 1'), undef; like $@, qr/syntax error/; pound foo_2() { $self } is foo_2(2 + 2), 4; like exception { foo_2(5, 6) }, qr/Too many arguments/; no Function::Parameters qw(pound); is eval('pound unfoo :() {}; 1'), undef; like $@, qr/syntax error/; } { is eval('pound unfoo( ){}; 1'), undef; like $@, qr/syntax error/; use Function::Parameters { pound => 'classmethod' }; is eval('fun foo () {}; 1'), undef; like $@, qr/syntax error/; pound foo_3() { $class } is foo_3(2 + 2), 4; like exception { foo_3(5, 6) }, qr/Too many arguments/; no Function::Parameters; is eval('pound unfoo :lvalue{}; 1'), undef; like $@, qr/syntax error/; } { use Function::Parameters { pound => 'function_strict' }; is eval('fun foo :() {}; 1'), undef; like $@, qr/syntax error/; pound foo_4($x) { $x } is foo_4(2 + 2), 4; like exception { foo_4(5, 6) }, qr/Too many arguments/; no Function::Parameters qw(pound); is eval('pound foo() {}; 1'), undef; like $@, qr/syntax error/; } { use Function::Parameters { pound => 'method_strict' }; is eval('fun foo () {}; 1'), undef; like $@, qr/syntax error/; pound foo_5() { $self } is foo_5(2 + 2), 4; like exception { foo_5(5, 6) }, qr/Too many arguments/; no Function::Parameters qw(pound); is eval('pound unfoo :() {}; 1'), undef; like $@, qr/syntax error/; } { is eval('pound unfoo( ){}; 1'), undef; like $@, qr/syntax error/; use Function::Parameters { pound => 'classmethod_strict' }; is eval('fun foo () {}; 1'), undef; like $@, qr/syntax error/; pound foo_6() { $class } is foo_6(2 + 2), 4; like exception { foo_6(5, 6) }, qr/Too many arguments/; no Function::Parameters; is eval('pound unfoo :lvalue{}; 1'), undef; like $@, qr/syntax error/; } { use Function::Parameters qw(method); is method () { $self + 2 }->(2), 4; is eval('fun () {}'), undef; like $@, qr/syntax error/; } { use Function::Parameters qw(method fun); is method () { $self + 2 }->(2), 4; is fun ($x) { $x + 2 }->(2), 4; } { use Function::Parameters qw(:std), { def => 'function' }; is method () { $self + 2 }->(2), 4; is fun ($x) { $x + 2 }->(2), 4; is def ($x) { $x + 2 }->(2), 4; } like exception { Function::Parameters->import(":QQQQ") }, qr/not exported/; like exception { Function::Parameters->import({":QQQQ" => "function"}) }, qr/valid identifier/; like exception { Function::Parameters->import({"jetsam" => "QQQQ"}) }, qr/valid type/; like exception { Function::Parameters->import("asdf") }, qr/not exported/; for my $kw ('', '42', 'A::B', 'a b') { like exception { Function::Parameters->import({ $kw => 'function' }) }, qr/valid identifier /; } Function-Parameters-2.002004/t/types_moosex.t0000644000175000017500000000626713235057757020034 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More eval { require MooseX::Types } ? (tests => 49) : (skip_all => "MooseX::Types required for testing types") ; use Test::Fatal; use MooseX::Types::Moose qw(Int Str ArrayRef CodeRef); use Function::Parameters qw(:strict); fun foo((Int) $n, (CodeRef) $f, $x) { $x = $f->($x) for 1 .. $n; $x } is foo(0, fun (@) {}, undef), undef; is foo(0, fun (@) {}, "o hai"), "o hai"; is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; { my $info = Function::Parameters::info \&foo; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 3; is $req[0]->name, '$n'; ok $req[0]->type->equals(Int); is $req[1]->name, '$f'; ok $req[1]->type->equals(CodeRef); is $req[2]->name, '$x'; is $req[2]->type, undef; } like exception { foo("ermagerd", fun (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; fun bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } is bar(21), 42; { my $info = Function::Parameters::info \&bar; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 1; is $req[0]->name, '$whoa'; ok $req[0]->type->equals(Int); } { my $info = Function::Parameters::info(fun ( ( ArrayRef [ Int | CodeRef ])@nom) {}); is $info->invocant, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my $slurpy = $info->slurpy; is $slurpy->name, '@nom'; ok $slurpy->type->equals(ArrayRef[Int|CodeRef]); } { my $phase = 'runtime'; BEGIN { $phase = 'A'; } fun baz ( ( is ( $phase ++ , 'A' ) , Int ) : $marco , ( is ( $phase ++ , 'B' ) , ArrayRef[Str] ) : $polo ) { [ $marco , $polo ] } BEGIN { is $phase, 'C'; } is $phase, 'runtime'; is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; my $info = Function::Parameters::info \&baz; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_optional, 0; my @req = $info->named_required; is @req, 2; is $req[0]->name, '$marco'; ok $req[0]->type->equals(Int); is $req[1]->name, '$polo'; ok $req[1]->type->equals(ArrayRef[Str]); } Function-Parameters-2.002004/t/method_runtime.t0000644000175000017500000000306513235057757020312 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 29; use Function::Parameters { fun => 'function_strict', method => { defaults => 'method_strict', runtime => 1 }, }; { package Foo; ::ok !defined &f1; method f1() {} ::ok defined &f1; ::ok !defined &f2; ::ok !defined &Bar::f2; method Bar::f2() {} ::ok !defined &f2; ::ok defined &Bar::f2; ::ok !defined &f3; if (@ARGV < 0) { method f3() {} } ::ok !defined &f3; } fun g1() { (caller 0)[3] } method g2() { (caller 0)[3] } fun Bar::g1() { (caller 0)[3] } method Bar::g2() { (caller 0)[3] } is g1, 'main::g1'; is 'main'->g2, 'main::g2'; is Bar::g1, 'Bar::g1'; is 'Bar'->g2, 'Bar::g2'; use Function::Parameters { fun_r => { defaults => 'function_strict', runtime => 1 } }; { package Foo_r; ::ok !defined &f1; fun_r f1() {} ::ok defined &f1; ::ok !defined &f2; ::ok !defined &Bar_r::f2; fun_r Bar_r::f2() {} ::ok !defined &f2; ::ok defined &Bar_r::f2; ::ok !defined &f3; if (@ARGV < 0) { fun_r f3() {} } ::ok !defined &f3; } fun h1() { (caller 0)[3] } fun_r h2() { (caller 0)[3] } fun Bar::h1() { (caller 0)[3] } fun_r Bar::h2() { (caller 0)[3] } is h1, 'main::h1'; is h2(), 'main::h2'; is Bar::h1, 'Bar::h1'; is Bar::h2(), 'Bar::h2'; fun_r p1($x, $y) :prototype($$) {} is prototype(\&p1), '$$'; is prototype('p1'), '$$'; is prototype('main::p1'), '$$'; fun_r Bar::p2($x, $y = 0) :prototype($;$) {} is prototype(\&Bar::p2), '$;$'; is prototype('Bar::p2'), '$;$'; Function-Parameters-2.002004/t/checkered_4.t0000644000175000017500000001164313235057757017430 0ustar maukemauke#!perl use Test::More tests => 108; use warnings FATAL => 'all'; use strict; use Function::Parameters { fun => 'function_strict', sad => 'function_lax', }; fun error_like($re, $body, $name = undef) { local $@; ok !eval { $body->(); 1 }; like $@, $re, $name; } fun foo_any(@) { [@_] } fun foo_any_a(@args) { [@args] } fun foo_any_b($x = undef, @rest) { [@_] } fun foo_0() { [@_] } fun foo_1($x) { [@_] } fun foo_2($x, $y) { [@_] } fun foo_3($x, $y, $z) { [@_] } fun foo_0_1($x = 'D0') { [$x] } fun foo_0_2($x = 'D0', $y = 'D1') { [$x, $y] } fun foo_0_3($x = 'D0', $y = undef, $z = 'D2') { [$x, $y, $z] } fun foo_1_2($x, $y = 'D1') { [$x, $y] } fun foo_1_3($x, $y = 'D1', $z = 'D2') { [$x, $y, $z] } fun foo_2_3($x, $y, $z = 'D2') { [$x, $y, $z] } fun foo_1_($x, @y) { [@_] } is_deeply foo_any, []; is_deeply foo_any('a'), ['a']; is_deeply foo_any('a', 'b'), ['a', 'b']; is_deeply foo_any('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_any_a, []; is_deeply foo_any_a('a'), ['a']; is_deeply foo_any_a('a', 'b'), ['a', 'b']; is_deeply foo_any_a('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any_a('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_any_b, []; is_deeply foo_any_b('a'), ['a']; is_deeply foo_any_b('a', 'b'), ['a', 'b']; is_deeply foo_any_b('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any_b('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_0, []; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1/, fun () { foo_1 }; is_deeply foo_1('a'), ['a']; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b' }; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 }; error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 'a' }; is_deeply foo_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a' }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a', 'b' }; is_deeply foo_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_3/, fun () { foo_3 'a', 'b', 'c', 'd' }; is_deeply foo_0_1, ['D0']; is_deeply foo_0_1('a'), ['a']; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b' }; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c', 'd' }; is_deeply foo_0_2, ['D0', 'D1']; is_deeply foo_0_2('a'), ['a', 'D1']; is_deeply foo_0_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c', 'd' }; is_deeply foo_0_3, ['D0', undef, 'D2']; is_deeply foo_0_3('a'), ['a', undef, 'D2']; is_deeply foo_0_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_0_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_0_3/, fun () { foo_0_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_2/, fun () { foo_1_2 }; is_deeply foo_1_2('a'), ['a', 'D1']; is_deeply foo_1_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_3/, fun () { foo_1_3 }; is_deeply foo_1_3('a'), ['a', 'D1', 'D2']; is_deeply foo_1_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_1_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_1_3/, fun () { foo_1_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 }; error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 'a' }; is_deeply foo_2_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_2_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_2_3/, fun () { foo_2_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_/, fun () { foo_1_ }; is_deeply foo_1_('a'), ['a']; is_deeply foo_1_('a', 'b'), ['a', 'b']; is_deeply foo_1_('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_1_('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; sad puppy($eyes) { [@_] } sad frog($will, $never) { $will * 3 + (pop) - $never } is_deeply puppy, []; is_deeply puppy('a'), ['a']; is_deeply puppy('a', 'b'), ['a', 'b']; is_deeply puppy('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply puppy('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is frog(7, 4, 1), 18; is frog(7, 4), 21; Function-Parameters-2.002004/t/strict_3.fail0000644000175000017500000000013413235057757017463 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters; fun bad_3($x, %y, $z) {} 'ok' Function-Parameters-2.002004/t/eating_strict_error_2.fail0000644000175000017500000000024213235057757022222 0ustar maukemauke#!perl use strict; use Function::Parameters; fun get_ip( $agent ) { } fun get_record( $agent, $target_name ) { for my $record ( @$records ) { } } 'ok' Function-Parameters-2.002004/t/attributes.t0000644000175000017500000000204313235057757017450 0ustar maukemauke#!perl use Test::More tests => 10; use warnings FATAL => 'all'; use strict; use Function::Parameters { fun => 'function', method => 'method', elrond => { attributes => ':lvalue', }, }; is eval('use Function::Parameters { fun => { attributes => "nope" } }; 1'), undef; like $@, qr/nope.*attributes/; is eval('use Function::Parameters { fun => { attributes => ": in valid {" } }; 1'), undef; like $@, qr/in valid.*attributes/; elrond hobbard($ref) { $$ref } { my $x = 1; hobbard(\$x) = 'bling'; is $x, 'bling'; } $_ = 'fool'; chop hobbard \$_; is $_, 'foo'; { package BatCountry; fun join($group, $peer) { return "* $peer has joined $group"; } ::is eval('join("left", "right")'), undef; ::like $@, qr/Ambiguous.*CORE::/; } { package CatCountry; method join($peer) { return "* $peer has joined $self->{name}"; } ::is join('!', 'left', 'right'), 'left!right'; my $obj = bless {name => 'kittens'}; ::is $obj->join("twig"), "* twig has joined kittens"; } Function-Parameters-2.002004/t/types_custom.t0000644000175000017500000000333113235057757020021 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 8; use Test::Fatal; use Function::Parameters qw(:strict); use Function::Parameters { def => { strict => 1 }, }; { package MyTC; method new( $class: $name, $check, $get_message = fun ($value) { "Validation failed for constraint '$name' with value '$value'" }, ) { bless { name => $name, check => $check, get_message => $get_message, }, $class } method check($value) { $self->{check}($value) } method get_message($value) { $self->{get_message}($value) } } use constant { TEvenNum => MyTC->new('even number' => fun ($n) { $n =~ /^[0-9]+\z/ && $n % 2 == 0 }), TShortStr => MyTC->new('short string' => fun ($s) { length($s) < 10 }), }; fun foo((TEvenNum) $x, (TShortStr) $y) { "$x/$y" } is foo(42, "hello"), "42/hello"; like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; def foo2((TEvenNum) $x, (TShortStr) $y) { "$x/$y" } is foo2(42, "hello"), "42/hello"; like exception { foo2 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; like exception { foo2 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; like exception { foo2 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; Function-Parameters-2.002004/t/checkered_2.t0000644000175000017500000001260613235057757017426 0ustar maukemauke#!perl use Test::More tests => 120; use warnings FATAL => 'all'; use strict; use Function::Parameters { method => { defaults => 'method', strict => 1, }, cathod => { defaults => 'method', strict => 0, }, fun => 'function', }; fun error_like($re, $body, $name = undef) { local $@; ok !eval { $body->(); 1 }; like $@, $re, $name; } method foo_any(@) { [@_] } method foo_any_a(@args) { [@args] } method foo_any_b($x = undef, @rest) { [@_] } method foo_0() { [@_] } method foo_1($x) { [@_] } method foo_2($x, $y) { [@_] } method foo_3($x, $y, $z) { [@_] } method foo_0_1($x = 'D0') { [$x] } method foo_0_2($x = 'D0', $y = 'D1') { [$x, $y] } method foo_0_3($x = 'D0', $y = undef, $z = 'D2') { [$x, $y, $z] } method foo_1_2($x, $y = 'D1') { [$x, $y] } method foo_1_3($x, $y = 'D1', $z = 'D2') { [$x, $y, $z] } method foo_2_3($x, $y, $z = 'D2') { [$x, $y, $z] } method foo_1_($x, @y) { [@_] } error_like qr/^Too few arguments.*foo_any/, sub { foo_any }; is_deeply foo_any('a'), []; is_deeply foo_any('a', 'b'), ['b']; is_deeply foo_any('a', 'b', 'c'), ['b', 'c']; is_deeply foo_any('a', 'b', 'c', 'd'), ['b', 'c', 'd']; error_like qr/^Too few arguments.*foo_any_a/, sub { foo_any_a }; is_deeply foo_any_a('a'), []; is_deeply foo_any_a('a', 'b'), ['b']; is_deeply foo_any_a('a', 'b', 'c'), ['b', 'c']; is_deeply foo_any_a('a', 'b', 'c', 'd'), ['b', 'c', 'd']; error_like qr/^Too few arguments.*foo_any_b/, sub { foo_any_b }; is_deeply foo_any_b('a'), []; is_deeply foo_any_b('a', 'b'), ['b']; is_deeply foo_any_b('a', 'b', 'c'), ['b', 'c']; is_deeply foo_any_b('a', 'b', 'c', 'd'), ['b', 'c', 'd']; error_like qr/^Too few arguments.*foo_0/, sub { foo_0 }; is_deeply foo_0('a'), []; error_like qr/^Too many arguments.*foo_0/, sub { foo_0 'a', 'b' }; error_like qr/^Too many arguments.*foo_0/, sub { foo_0 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0/, sub { foo_0 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1/, sub { foo_1 }; error_like qr/^Too few arguments.*foo_1/, sub { foo_1 'a' }; is_deeply foo_1('a', 'b'), ['b']; error_like qr/^Too many arguments.*foo_1/, sub { foo_1 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_1/, sub { foo_1 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_2/, sub { foo_2 }; error_like qr/^Too few arguments.*foo_2/, sub { foo_2 'a' }; error_like qr/^Too few arguments.*foo_2/, sub { foo_2 'a', 'b' }; is_deeply foo_2('a', 'b', 'c'), ['b', 'c']; error_like qr/^Too many arguments.*foo_2/, sub { foo_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_3/, sub { foo_3 }; error_like qr/^Too few arguments.*foo_3/, sub { foo_3 'a' }; error_like qr/^Too few arguments.*foo_3/, sub { foo_3 'a', 'b' }; error_like qr/^Too few arguments.*foo_3/, sub { foo_3 'a', 'b', 'c' }; is_deeply foo_3('a', 'b', 'c', 'd'), ['b', 'c', 'd']; error_like qr/^Too many arguments.*foo_3/, sub { foo_3 'a', 'b', 'c', 'd', 'e' }; error_like qr/^Too few arguments.*foo_0_1/, sub { foo_0_1 }; is_deeply foo_0_1('a'), ['D0']; is_deeply foo_0_1('a', 'b'), ['b']; error_like qr/^Too many arguments.*foo_0_1/, sub { foo_0_1 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0_1/, sub { foo_0_1 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_0_2/, sub { foo_0_2 }; is_deeply foo_0_2('a'), ['D0', 'D1']; is_deeply foo_0_2('a', 'b'), ['b', 'D1']; is_deeply foo_0_2('a', 'b', 'c'), ['b', 'c']; error_like qr/^Too many arguments.*foo_0_2/, sub { foo_0_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_0_3/, sub { foo_0_3 }; is_deeply foo_0_3('a'), ['D0', undef, 'D2']; is_deeply foo_0_3('a', 'b'), ['b', undef, 'D2']; is_deeply foo_0_3('a', 'b', 'c'), ['b', 'c', 'D2']; is_deeply foo_0_3('a', 'b', 'c', 'd'), ['b', 'c', 'd']; error_like qr/^Too many arguments.*foo_0_3/, sub { foo_0_3 'a', 'b', 'c', 'd', 'e' }; error_like qr/^Too few arguments.*foo_1_2/, sub { foo_1_2 }; error_like qr/^Too few arguments.*foo_1_2/, sub { foo_1_2 'a' }; is_deeply foo_1_2('a', 'b'), ['b', 'D1']; is_deeply foo_1_2('a', 'b', 'c'), ['b', 'c']; error_like qr/^Too many arguments.*foo_1_2/, sub { foo_1_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_3/, sub { foo_1_3 }; error_like qr/^Too few arguments.*foo_1_3/, sub { foo_1_3 'a' }; is_deeply foo_1_3('a', 'b'), ['b', 'D1', 'D2']; is_deeply foo_1_3('a', 'b', 'c'), ['b', 'c', 'D2']; is_deeply foo_1_3('a', 'b', 'c', 'd'), ['b', 'c', 'd']; error_like qr/^Too many arguments.*foo_1_3/, sub { foo_1_3 'a', 'b', 'c', 'd', 'e' }; error_like qr/^Too few arguments.*foo_2_3/, sub { foo_2_3 }; error_like qr/^Too few arguments.*foo_2_3/, sub { foo_2_3 'a' }; error_like qr/^Too few arguments.*foo_2_3/, sub { foo_2_3 'a', 'b' }; is_deeply foo_2_3('a', 'b', 'c'), ['b', 'c', 'D2']; is_deeply foo_2_3('a', 'b', 'c', 'd'), ['b', 'c', 'd']; error_like qr/^Too many arguments.*foo_2_3/, sub { foo_2_3 'a', 'b', 'c', 'd', 'e' }; error_like qr/^Too few arguments.*foo_1_/, sub { foo_1_ }; error_like qr/^Too few arguments.*foo_1_/, sub { foo_1_ 'a' }; is_deeply foo_1_('a', 'b'), ['b']; is_deeply foo_1_('a', 'b', 'c'), ['b', 'c']; is_deeply foo_1_('a', 'b', 'c', 'd'), ['b', 'c', 'd']; cathod puppy($eyes) { [@_] } cathod frog($will, $never) { $will * 3 + (pop) - $never } is_deeply puppy, []; is_deeply puppy('a'), []; is_deeply puppy('a', 'b'), ['b']; is_deeply puppy('a', 'b', 'c'), ['b', 'c']; is_deeply puppy('a', 'b', 'c', 'd'), ['b', 'c', 'd']; is +main->frog(7, 4, 1), 18; is +main->frog(7, 4), 21; Function-Parameters-2.002004/t/eating_strict_error.t0000644000175000017500000000077514362360715021335 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 4; use FindBin; for my $thing (map ["$FindBin::Bin/eating_strict_error$_->[0].fail", @$_[1 .. $#$_]], ['', 6], ['_2', 9]) { my ($file, $line) = @$thing; $@ = undef; my $done = do $file; my $exc = $@; my $err = $!; is $done, undef, "faulty code doesn't load - $file"; like $exc, qr{^Global symbol "\$records" requires explicit package name.* at \Q$file\E line \Q$line.\E\n}; $exc or die "$file: $err"; } Function-Parameters-2.002004/t/gorn.t0000644000175000017500000000046713235057757016237 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 4; use Function::Parameters; is eval 'fun {}', undef; like $@, qr/\A\QIn fun (anon): I was expecting a parameter list, not "{"/; is eval 'fun () :() {}', undef; like $@, qr/\A\QIn fun (anon): I was expecting a function body, not "("/; Function-Parameters-2.002004/t/bonus.t0000644000175000017500000000235013235057757016411 0ustar maukemauke#!perl use Test::More tests => 13; use warnings FATAL => 'all'; use strict; use Function::Parameters { fun => { defaults => 'function_strict', }, }; fun filter($f = fun ($x) { 1 }, @xs) { !@xs ? () : (($f->($xs[0]) ? $xs[0] : ()), filter $f, @xs[1 .. $#xs]) } is_deeply [filter], []; is_deeply [filter fun (@) { 1 }, 2 .. 3], [2 .. 3]; is_deeply [filter fun ($x) { $x % 2 }, 1 .. 10], [1, 3, 5, 7, 9]; fun fact($k, $n) :prototype(&$) { $n < 2 ? $k->(1) : fact { $k->($n * $_[0]) } $n - 1 } is +(fact { "~@_~" } 5), "~120~"; is +(fact { $_[0] / 2 } 6), 360; fun write_to($ref) :prototype(\$) :lvalue { $$ref } { my $x = 2; is $x, 2; write_to($x) = "hi"; is $x, "hi"; write_to($x)++; is $x, "hj"; } { my $c = 0; fun horf_dorf($ref, $val = $c++) :prototype(\@;$) :lvalue { push @$ref, $val; $ref->[-1] } } { my @asdf = "A"; is_deeply \@asdf, ["A"]; horf_dorf(@asdf) = "b"; is_deeply \@asdf, ["A", "b"]; ++horf_dorf @asdf; is_deeply \@asdf, ["A", "b", 2]; horf_dorf @asdf, 100; is_deeply \@asdf, ["A", "b", 2, 100]; splice @asdf, 1, 1; horf_dorf(@asdf) *= 3; is_deeply \@asdf, ["A", 2, 100, 6]; } Function-Parameters-2.002004/t/types_moose_3.t0000644000175000017500000000634113235057757020057 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More eval { require Moose } ? (tests => 49) : (skip_all => "Moose required for testing types") ; use Test::Fatal; use Function::Parameters { def => { strict => 1, reify_type => 'moose' }, }; def foo(Int $n, CodeRef $f, $x) { $x = $f->($x) for 1 .. $n; $x } is foo(0, def (@) {}, undef), undef; is foo(0, def (@) {}, "o hai"), "o hai"; is foo(3, def ($x) { "($x)" }, 1.5), "(((1.5)))"; is foo(3, def (Str $x) { "($x)" }, 1.5), "(((1.5)))"; { my $info = Function::Parameters::info \&foo; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 3; is $req[0]->name, '$n'; ok $req[0]->type->equals('Int'); is $req[1]->name, '$f'; ok $req[1]->type->equals('CodeRef'); is $req[2]->name, '$x'; is $req[2]->type, undef; } like exception { foo("ermagerd", def (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; def bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } is bar(21), 42; { my $info = Function::Parameters::info \&bar; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 1; is $req[0]->name, '$whoa'; ok $req[0]->type->equals('Int'); } { my $info = Function::Parameters::info(def ( ArrayRef [ Int | CodeRef ]@nom) {}); is $info->invocant, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my $slurpy = $info->slurpy; is $slurpy->name, '@nom'; ok $slurpy->type->equals(Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int|CodeRef]')); } { my $phase = 'runtime'; BEGIN { $phase = 'A'; } def baz ( ( is ( $phase ++ , 'A' ) , 'Int' ) : $marco , ( is ( $phase ++ , 'B' ) , q $ArrayRef[Str]$ ) : $polo ) { [ $marco , $polo ] } BEGIN { is $phase, 'C'; } is $phase, 'runtime'; is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; my $info = Function::Parameters::info \&baz; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_optional, 0; my @req = $info->named_required; is @req, 2; is $req[0]->name, '$marco'; ok $req[0]->type->equals('Int'); is $req[1]->name, '$polo'; ok $req[1]->type->equals('ArrayRef[Str]'); } Function-Parameters-2.002004/t/eating_strict_error.fail0000644000175000017500000000024213235057757022001 0ustar maukemauke#!perl use strict; use Function::Parameters; fun get_record( $agent, $target_name ) { for my $record ( @$records ) { } } fun get_ip( $agent ) { } 'ok' Function-Parameters-2.002004/t/types_moose.t0000644000175000017500000000646013235057757017637 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More eval { require Moose } ? (tests => 49) : (skip_all => "Moose required for testing types") ; use Test::Fatal; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; fun foo(Int $n, CodeRef $f, $x) { $x = $f->($x) for 1 .. $n; $x } is foo(0, fun (@) {}, undef), undef; is foo(0, fun (@) {}, "o hai"), "o hai"; is foo(3, fun ($x) { "($x)" }, 1.5), "(((1.5)))"; is foo(3, fun (Str $x) { "($x)" }, 1.5), "(((1.5)))"; { my $info = Function::Parameters::info \&foo; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 3; is $req[0]->name, '$n'; ok $req[0]->type->equals('Int'); is $req[1]->name, '$f'; ok $req[1]->type->equals('CodeRef'); is $req[2]->name, '$x'; is $req[2]->type, undef; } like exception { foo("ermagerd", fun (@) {}, undef) }, qr/\bparameter 1.+\$n\b.+\bValidation failed\b.+\bInt\b.+ermagerd/; like exception { foo(0, {}, undef) }, qr/\bparameter 2.+\$f\b.+\bValidation failed\b.+\bCodeRef\b/; fun bar(((Function::Parameters::info(\&foo)->positional_required)[0]->type) $whoa) { $whoa * 2 } is bar(21), 42; { my $info = Function::Parameters::info \&bar; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my @req = $info->positional_required; is @req, 1; is $req[0]->name, '$whoa'; ok $req[0]->type->equals('Int'); } { my $info = Function::Parameters::info(fun ( ArrayRef [ Int | CodeRef ]@nom) {}); is $info->invocant, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_required, 0; is $info->named_optional, 0; my $slurpy = $info->slurpy; is $slurpy->name, '@nom'; ok $slurpy->type->equals(Moose::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Int|CodeRef]')); } { my $phase = 'runtime'; BEGIN { $phase = 'A'; } fun baz ( ( is ( $phase ++ , 'A' ) , 'Int' ) : $marco , ( is ( $phase ++ , 'B' ) , q $ArrayRef[Str]$ ) : $polo ) { [ $marco , $polo ] } BEGIN { is $phase, 'C'; } is $phase, 'runtime'; is_deeply baz(polo => [qw(foo bar baz)], marco => 11), [11, [qw(foo bar baz)]]; my $info = Function::Parameters::info \&baz; is $info->invocant, undef; is $info->slurpy, undef; is $info->positional_required, 0; is $info->positional_optional, 0; is $info->named_optional, 0; my @req = $info->named_required; is @req, 2; is $req[0]->name, '$marco'; ok $req[0]->type->equals('Int'); is $req[1]->name, '$polo'; ok $req[1]->type->equals('ArrayRef[Str]'); } Function-Parameters-2.002004/t/checkered.t0000644000175000017500000001167513235057757017212 0ustar maukemauke#!perl use Test::More tests => 108; use warnings FATAL => 'all'; use strict; use Function::Parameters { fun => { strict => 1, }, sad => { strict => 0, }, }; fun error_like($re, $body, $name = undef) { local $@; ok !eval { $body->(); 1 }; like $@, $re, $name; } fun foo_any(@) { [@_] } fun foo_any_a(@args) { [@args] } fun foo_any_b($x = undef, @rest) { [@_] } fun foo_0() { [@_] } fun foo_1($x) { [@_] } fun foo_2($x, $y) { [@_] } fun foo_3($x, $y, $z) { [@_] } fun foo_0_1($x = 'D0') { [$x] } fun foo_0_2($x = 'D0', $y = 'D1') { [$x, $y] } fun foo_0_3($x = 'D0', $y = undef, $z = 'D2') { [$x, $y, $z] } fun foo_1_2($x, $y = 'D1') { [$x, $y] } fun foo_1_3($x, $y = 'D1', $z = 'D2') { [$x, $y, $z] } fun foo_2_3($x, $y, $z = 'D2') { [$x, $y, $z] } fun foo_1_($x, @y) { [@_] } is_deeply foo_any, []; is_deeply foo_any('a'), ['a']; is_deeply foo_any('a', 'b'), ['a', 'b']; is_deeply foo_any('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_any_a, []; is_deeply foo_any_a('a'), ['a']; is_deeply foo_any_a('a', 'b'), ['a', 'b']; is_deeply foo_any_a('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any_a('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_any_b, []; is_deeply foo_any_b('a'), ['a']; is_deeply foo_any_b('a', 'b'), ['a', 'b']; is_deeply foo_any_b('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any_b('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_0, []; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1/, fun () { foo_1 }; is_deeply foo_1('a'), ['a']; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b' }; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 }; error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 'a' }; is_deeply foo_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a' }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a', 'b' }; is_deeply foo_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_3/, fun () { foo_3 'a', 'b', 'c', 'd' }; is_deeply foo_0_1, ['D0']; is_deeply foo_0_1('a'), ['a']; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b' }; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c', 'd' }; is_deeply foo_0_2, ['D0', 'D1']; is_deeply foo_0_2('a'), ['a', 'D1']; is_deeply foo_0_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c', 'd' }; is_deeply foo_0_3, ['D0', undef, 'D2']; is_deeply foo_0_3('a'), ['a', undef, 'D2']; is_deeply foo_0_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_0_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_0_3/, fun () { foo_0_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_2/, fun () { foo_1_2 }; is_deeply foo_1_2('a'), ['a', 'D1']; is_deeply foo_1_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_3/, fun () { foo_1_3 }; is_deeply foo_1_3('a'), ['a', 'D1', 'D2']; is_deeply foo_1_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_1_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_1_3/, fun () { foo_1_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 }; error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 'a' }; is_deeply foo_2_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_2_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_2_3/, fun () { foo_2_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_/, fun () { foo_1_ }; is_deeply foo_1_('a'), ['a']; is_deeply foo_1_('a', 'b'), ['a', 'b']; is_deeply foo_1_('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_1_('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; sad puppy($eyes) { [@_] } sad frog($will, $never) { $will * 3 + (pop) - $never } is_deeply puppy, []; is_deeply puppy('a'), ['a']; is_deeply puppy('a', 'b'), ['a', 'b']; is_deeply puppy('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply puppy('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is frog(7, 4, 1), 18; is frog(7, 4), 21; Function-Parameters-2.002004/t/types_inline.t0000644000175000017500000000573614417751740017774 0ustar maukemauke#!perl use warnings qw(all FATAL uninitialized); use strict; use Test::More $^V ge v5.20.0 ? (tests => 14) : (skip_all => sprintf("[perl-v%vd] this test throws syntax errors on perls before 5.20 and I don't understand why :shrug:", $^V)); use Test::Fatal; use Function::Parameters; BEGIN { package MyTC; method new( $class: :$incline = 0, :$file = undef, :$line = undef, :$broken = undef, ) { bless { incline => $incline, file => $file, line => $line, broken => $broken, }, $class } method can_be_inlined() { 1 } method inline_check($var) { my $line = $self->{line}; my $file = $self->{file}; if (defined $file) { $line //= (caller)[2]; } my $header = defined $line ? qq{#line $line "$file"\n} : ""; my $garbage = ";\n" x $self->{incline}; my $error = $self->{broken} ? "]" : ""; $header . "do { $garbage defined($var) $error }" } method check($value) { die "check() shouldn't be called"; } method get_message($value) { "value is not defined" } } use constant { TDef => MyTC->new, TBroken => MyTC->new(broken => 1, incline => 99), TDefI7 => MyTC->new(incline => 7), TDefX => MyTC->new(file => "fake-file", line => 666_666), TDefXI2 => MyTC->new(file => "fake-file", line => 666_666, incline => 2), }; is eval(qq|#line 2 "~virtual~"\nfun (TBroken \$bad) {}|), undef, "broken type constraint doesn't compile"; like $@, qr/\bsyntax error at \(inline_check:~virtual~:2\) line 100\b/, "broken type constraint reports correct source location"; #line 62 "t/types_inline.t" fun foo0(TDef $x) { $x } is foo0('good'), 'good', "defined value passes inline check"; like exception { foo0(undef) }, qr/\AIn fun foo0: parameter 1 \(\$x\): value is not defined\b/, "undefined value throws"; is __FILE__ . ' ' . __LINE__, "t/types_inline.t 66", "source location OK"; #line 69 "t/types_inline.t" fun foo1(TDefI7 $x) { $x } is foo1('good'), 'good', "(+7) defined value passes inline check"; like exception { foo1(undef) }, qr/\AIn fun foo1: parameter 1 \(\$x\): value is not defined\b/, "(+7) undefined value throws"; is __FILE__ . ' ' . __LINE__, "t/types_inline.t 73", "(+7) source location OK"; #line 76 "t/types_inline.t" fun foo2(TDefX $x) { $x } is foo2('good'), 'good', "(X) defined value passes inline check"; like exception { foo2(undef) }, qr/\AIn fun foo2: parameter 1 \(\$x\): value is not defined\b/, "(X) undefined value throws"; is __FILE__ . ' ' . __LINE__, "t/types_inline.t 80", "(X) source location OK"; #line 83 "t/types_inline.t" fun foo3(TDefXI2 $x) { $x } is foo3('good'), 'good', "(X+2) defined value passes inline check"; like exception { foo3(undef) }, qr/\AIn fun foo3: parameter 1 \(\$x\): value is not defined\b/, "(X+2) undefined value throws"; is __FILE__ . ' ' . __LINE__, "t/types_inline.t 87", "(X+2) source location OK"; Function-Parameters-2.002004/t/method_cache.t0000644000175000017500000000065713235057757017676 0ustar maukemauke#!perl use warnings FATAL => 'all'; no warnings qw(once redefine); use strict; use Test::More tests => 2; use Function::Parameters { method => { defaults => 'method_strict', runtime => 1 }, }; # See commit 978a498e17ec54b6f1fc65f3375a62a68f321f99 in perl: # http://perl5.git.perl.org/perl.git/commitdiff/978a498e17ec5 method Y::b() { 'b' } *X::b = *Y::b; @Z::ISA = 'X'; is +Z->b, 'b'; method Y::b() { 'c' } is +Z->b, 'c'; Function-Parameters-2.002004/t/threads2.t0000644000175000017500000000120113235057757016771 0ustar maukemauke#!perl use Test::More eval { require threads; threads->import; 1 } ? (tests => 1) : (skip_all => "threads required for testing threads"); use warnings FATAL => 'all'; use strict; use threads::shared; my $nthreads = 5; my $xvar :shared = 0; for my $t (1 .. $nthreads) { threads->create(sub { lock $xvar; $xvar++; cond_wait $xvar while $xvar >= 0; require Function::Parameters; }); } { threads->yield; lock $xvar; if ($xvar < $nthreads) { redo; } $xvar = -1; cond_broadcast $xvar; } $_->join for threads->list; pass "we haven't crashed yet"; Function-Parameters-2.002004/t/types_custom_4.t0000644000175000017500000000326313235057757020250 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 8; use Test::Fatal; use Function::Parameters qw(:strict), { def => { strict => 1 } }; { package MyTC; method new( $class: $name, $check, $get_message = fun ($value) { "Validation failed for constraint '$name' with value '$value'" }, ) { bless { name => $name, check => $check, get_message => $get_message, }, $class } method check($value) { $self->{check}($value) } method get_message($value) { $self->{get_message}($value) } } use constant { TEvenNum => MyTC->new('even number' => fun ($n) { $n =~ /^[0-9]+\z/ && $n % 2 == 0 }), TShortStr => MyTC->new('short string' => fun ($s) { length($s) < 10 }), }; fun foo(TEvenNum $x, TShortStr $y) { "$x/$y" } is foo(42, "hello"), "42/hello"; like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; def foo2(TEvenNum $x, TShortStr $y) { "$x/$y" } is foo2(42, "hello"), "42/hello"; like exception { foo2 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; like exception { foo2 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; like exception { foo2 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; Function-Parameters-2.002004/t/lineno.t0000644000175000017500000000223313235057757016547 0ustar maukemaukeuse warnings; use strict; use Test::More tests => 11; use Function::Parameters; fun actual_location_of_line_with($marker) { seek DATA, 0, 0 or die "seek DATA: $!"; my $loc = 0; while (my $line = readline DATA) { $loc++; index($line, $marker) >= 0 and return $loc; } undef } fun test_loc($marker) { my $expected = actual_location_of_line_with $marker; defined $expected or die "$marker: something done fucked up"; my $got = (caller)[2]; is $got, $expected, "location of '$marker'"; } fun () { test_loc 'LX simple'; }->(); test_loc 'LX -- 1'; fun ( ) { test_loc 'LX creative formatting'; } -> ( ); test_loc 'LX -- 2'; fun () { fun () { test_loc 'LX nested'; }->() }->(); test_loc 'LX -- 3'; { #local $TODO = 'expressions break line numbers???'; 0 , fun () { test_loc 'LX assign'; }->() ; test_loc 'LX -- 4'; } { #local $TODO = 'newlines in prototype/attributes'; fun wtf() :prototype( ) : { test_loc 'LX -- 5 (inner)' } test_loc 'LX -- 5 (bonus)'; wtf; test_loc 'LX -- 5 (outer)'; } __DATA__ Function-Parameters-2.002004/t/defaults_bare.t0000644000175000017500000000151613235057757020066 0ustar maukemauke#!perl use Test::More tests => 13; use warnings FATAL => 'all'; use strict; use Function::Parameters qw(:strict); fun foo_1($x = ) { [ $x ] } fun foo_2($x=) { [ $x ] } fun foo_3($x =, $y =) { [ $x, $y ] } fun foo_4($x = 'hi', $y= ) { [ $x, $y ] } fun foo_5($x= , $y='hi') { [ $x, $y ] } is_deeply foo_1(), [ undef ]; is_deeply foo_1('aa'), [ 'aa' ]; is_deeply foo_2(), [ undef ]; is_deeply foo_2('aa'), [ 'aa' ]; is_deeply foo_3(), [ undef, undef ]; is_deeply foo_3('aa'), [ 'aa', undef ]; is_deeply foo_3('aa', 'bb'), [ 'aa', 'bb' ]; is_deeply foo_4(), [ 'hi', undef ]; is_deeply foo_4('aa'), [ 'aa', undef ]; is_deeply foo_4('aa', 'bb'), [ 'aa', 'bb' ]; is_deeply foo_5(), [ undef, 'hi' ]; is_deeply foo_5('aa'), [ 'aa', 'hi' ]; is_deeply foo_5('aa', 'bb'), [ 'aa', 'bb' ]; Function-Parameters-2.002004/t/stringy_h.t0000644000175000017500000000122214406604347017260 0ustar maukemauke#!perl use strict; use warnings; use Test::More; use Function::Parameters; my @warnings; BEGIN { $SIG{__WARN__} = sub { push @warnings, $_[0]; }; } sub wget { splice @warnings } { BEGIN { $^H{'Function::Parameters/config'} .= ''; } if (0) {} if (0) {} } BEGIN { my @w = wget; is @w, 1; like $w[0], qr{^Function::Parameters: \$\^H\{'Function::Parameters/config'\} is not a reference; skipping: HASH\(}; } { no warnings 'Function::Parameters'; BEGIN { $^H{'Function::Parameters/config'} .= ''; } if (0) {} if (0) {} } BEGIN { my @w = wget; is @w, 0; is $w[0], undef; } done_testing; Function-Parameters-2.002004/t/hueg.t0000644000175000017500000001663713235057757016230 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 1; use Function::Parameters qw(:lax); fun yes_this_is_an_unusually_long_function_name_wouldnt_you_agree_with_me_there ( $the_first_parameter_is_the_only_one_I_really_care_about_and_gets_a_very_special_name, $stupid_prefix_0, $stupid_prefix_1, $stupid_prefix_2, $stupid_prefix_3, $stupid_prefix_4, $stupid_prefix_5, $stupid_prefix_6, $stupid_prefix_7, $stupid_prefix_8, $stupid_prefix_9, $stupid_prefix_10, $stupid_prefix_11, $stupid_prefix_12, $stupid_prefix_13, $stupid_prefix_14, $stupid_prefix_15, $stupid_prefix_16, $stupid_prefix_17, $stupid_prefix_18, $stupid_prefix_19, $stupid_prefix_20, $stupid_prefix_21, $stupid_prefix_22, $stupid_prefix_23, $stupid_prefix_24, $stupid_prefix_25, $stupid_prefix_26, $stupid_prefix_27, $stupid_prefix_28, $stupid_prefix_29, $stupid_prefix_30, $stupid_prefix_31, $stupid_prefix_32, $stupid_prefix_33, $stupid_prefix_34, $stupid_prefix_35, $stupid_prefix_36, $stupid_prefix_37, $stupid_prefix_38, $stupid_prefix_39, $stupid_prefix_40, $stupid_prefix_41, $stupid_prefix_42, $stupid_prefix_43, $stupid_prefix_44, $stupid_prefix_45, $stupid_prefix_46, $stupid_prefix_47, $stupid_prefix_48, $stupid_prefix_49, $stupid_prefix_50, $stupid_prefix_51, $stupid_prefix_52, $stupid_prefix_53, $stupid_prefix_54, $stupid_prefix_55, $stupid_prefix_56, $stupid_prefix_57, $stupid_prefix_58, $stupid_prefix_59, $stupid_prefix_60, $stupid_prefix_61, $stupid_prefix_62, $stupid_prefix_63, $stupid_prefix_64, $stupid_prefix_65, $stupid_prefix_66, $stupid_prefix_67, $stupid_prefix_68, $stupid_prefix_69, $stupid_prefix_70, $stupid_prefix_71, $stupid_prefix_72, $stupid_prefix_73, $stupid_prefix_74, $stupid_prefix_75, $stupid_prefix_76, $stupid_prefix_77, $stupid_prefix_78, $stupid_prefix_79, $stupid_prefix_80, $stupid_prefix_81, $stupid_prefix_82, $stupid_prefix_83, $stupid_prefix_84, $stupid_prefix_85, $stupid_prefix_86, $stupid_prefix_87, $stupid_prefix_88, $stupid_prefix_89, $stupid_prefix_90, $stupid_prefix_91, $stupid_prefix_92, $stupid_prefix_93, $stupid_prefix_94, $stupid_prefix_95, $stupid_prefix_96, $stupid_prefix_97, $stupid_prefix_98, $stupid_prefix_99, $stupid_prefix_100, $stupid_prefix_101, $stupid_prefix_102, $stupid_prefix_103, $stupid_prefix_104, $stupid_prefix_105, $stupid_prefix_106, $stupid_prefix_107, $stupid_prefix_108, $stupid_prefix_109, $stupid_prefix_110, $stupid_prefix_111, $stupid_prefix_112, $stupid_prefix_113, $stupid_prefix_114, $stupid_prefix_115, $stupid_prefix_116, $stupid_prefix_117, $stupid_prefix_118, $stupid_prefix_119, $stupid_prefix_120, $stupid_prefix_121, $stupid_prefix_122, $stupid_prefix_123, $stupid_prefix_124, $stupid_prefix_125, $stupid_prefix_126, $stupid_prefix_127, $stupid_prefix_128, $stupid_prefix_129, $stupid_prefix_130, $stupid_prefix_131, $stupid_prefix_132, $stupid_prefix_133, $stupid_prefix_134, $stupid_prefix_135, $stupid_prefix_136, $stupid_prefix_137, $stupid_prefix_138, $stupid_prefix_139, $stupid_prefix_140, $stupid_prefix_141, $stupid_prefix_142, $stupid_prefix_143, $stupid_prefix_144, $stupid_prefix_145, $stupid_prefix_146, $stupid_prefix_147, $stupid_prefix_148, $stupid_prefix_149, $stupid_prefix_150, $stupid_prefix_151, $stupid_prefix_152, $stupid_prefix_153, $stupid_prefix_154, $stupid_prefix_155, $stupid_prefix_156, $stupid_prefix_157, $stupid_prefix_158, $stupid_prefix_159, $stupid_prefix_160, $stupid_prefix_161, $stupid_prefix_162, $stupid_prefix_163, $stupid_prefix_164, $stupid_prefix_165, $stupid_prefix_166, $stupid_prefix_167, $stupid_prefix_168, $stupid_prefix_169, $stupid_prefix_170, $stupid_prefix_171, $stupid_prefix_172, $stupid_prefix_173, $stupid_prefix_174, $stupid_prefix_175, $stupid_prefix_176, $stupid_prefix_177, $stupid_prefix_178, $stupid_prefix_179, $stupid_prefix_180, $stupid_prefix_181, $stupid_prefix_182, $stupid_prefix_183, $stupid_prefix_184, $stupid_prefix_185, $stupid_prefix_186, $stupid_prefix_187, $stupid_prefix_188, $stupid_prefix_189, $stupid_prefix_190, $stupid_prefix_191, $stupid_prefix_192, $stupid_prefix_193, $stupid_prefix_194, $stupid_prefix_195, $stupid_prefix_196, $stupid_prefix_197, $stupid_prefix_198, $stupid_prefix_199, $stupid_prefix_200, $stupid_prefix_201, $stupid_prefix_202, $stupid_prefix_203, $stupid_prefix_204, $stupid_prefix_205, $stupid_prefix_206, $stupid_prefix_207, $stupid_prefix_208, $stupid_prefix_209, $stupid_prefix_210, $stupid_prefix_211, $stupid_prefix_212, $stupid_prefix_213, $stupid_prefix_214, $stupid_prefix_215, $stupid_prefix_216, $stupid_prefix_217, $stupid_prefix_218, $stupid_prefix_219, $stupid_prefix_220, $stupid_prefix_221, $stupid_prefix_222, $stupid_prefix_223, $stupid_prefix_224, $stupid_prefix_225, $stupid_prefix_226, $stupid_prefix_227, $stupid_prefix_228, $stupid_prefix_229, $stupid_prefix_230, $stupid_prefix_231, $stupid_prefix_232, $stupid_prefix_233, $stupid_prefix_234, $stupid_prefix_235, $stupid_prefix_236, $stupid_prefix_237, $stupid_prefix_238, $stupid_prefix_239, $stupid_prefix_240, $stupid_prefix_241, $stupid_prefix_242, $stupid_prefix_243, $stupid_prefix_244, $stupid_prefix_245, $stupid_prefix_246, $stupid_prefix_247, $stupid_prefix_248, $stupid_prefix_249, $stupid_prefix_250, $stupid_prefix_251, $stupid_prefix_252, $stupid_prefix_253, $stupid_prefix_254, $stupid_prefix_255, $stupid_prefix_256, $stupid_prefix_257, $stupid_prefix_258, $stupid_prefix_259, $stupid_prefix_260, $stupid_prefix_261, $stupid_prefix_262, $stupid_prefix_263, $stupid_prefix_264, $stupid_prefix_265, $stupid_prefix_266, $stupid_prefix_267, $stupid_prefix_268, $stupid_prefix_269, $stupid_prefix_270, $stupid_prefix_271, $stupid_prefix_272, $stupid_prefix_273, $stupid_prefix_274, $stupid_prefix_275, $stupid_prefix_276, $stupid_prefix_277, $stupid_prefix_278, $stupid_prefix_279, $stupid_prefix_280, $stupid_prefix_281, $stupid_prefix_282, $stupid_prefix_283, $stupid_prefix_284, $stupid_prefix_285, $stupid_prefix_286, $stupid_prefix_287, $stupid_prefix_288, $stupid_prefix_289, $stupid_prefix_290, $stupid_prefix_291, $stupid_prefix_292, $stupid_prefix_293, $stupid_prefix_294, $stupid_prefix_295, $stupid_prefix_296, $stupid_prefix_297, $stupid_prefix_298, $stupid_prefix_299, ) { $the_first_parameter_is_the_only_one_I_really_care_about_and_gets_a_very_special_name } is yes_this_is_an_unusually_long_function_name_wouldnt_you_agree_with_me_there("all is well"), "all is well"; Function-Parameters-2.002004/t/croak.t0000644000175000017500000000455613235057757016374 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 12; use Test::Fatal; use Function::Parameters { fun => { defaults => 'function_strict', reify_type => \&MyT::reify_type }, method => 'method_strict', }; { package MyT; fun reify_type($type) { bless [$type], __PACKAGE__ } method check($value) { 0 } method get_message($value) { "A failure ($self->[0]) of $value" } } my $marker = __LINE__; { package Crabs; fun take2($x, $y) {} fun worng1() { take2 1 } fun worng4() { take2 1, 2, 3, 4 } fun takekw(:$zomg) {} fun worngkw1() { takekw "a", "b", "c" } fun worngkw2() { takekw a => 1 } fun worngkw4() { takekw zomg => 1, a => 2 } fun taket(Cool[Story] $x) {} fun worngt1() { taket "X" } } is exception { Crabs::take2 1 }, "Too few arguments for fun take2 (expected 2, got 1) at ${\__FILE__} line ${\__LINE__}.\n"; is exception { Crabs::worng1 }, "Too few arguments for fun take2 (expected 2, got 1) at ${\__FILE__} line ${\($marker + 5)}.\n"; is exception { Crabs::take2 1, 2, 3, 4 }, "Too many arguments for fun take2 (expected 2, got 4) at ${\__FILE__} line ${\__LINE__}.\n"; is exception { Crabs::worng4 }, "Too many arguments for fun take2 (expected 2, got 4) at ${\__FILE__} line ${\($marker + 6)}.\n"; is exception { Crabs::takekw "a", "b", "c" }, "Odd number of paired arguments for fun takekw at ${\__FILE__} line ${\__LINE__}.\n"; is exception { Crabs::worngkw1 }, "Odd number of paired arguments for fun takekw at ${\__FILE__} line ${\($marker + 9)}.\n"; is exception { Crabs::takekw a => 1 }, "In fun takekw: missing named parameter: zomg at ${\__FILE__} line ${\__LINE__}.\n"; is exception { Crabs::worngkw2 }, "In fun takekw: missing named parameter: zomg at ${\__FILE__} line ${\($marker + 10)}.\n"; is exception { Crabs::takekw zomg => 1, a => 2 }, "In fun takekw: no such named parameter: a at ${\__FILE__} line ${\__LINE__}.\n"; is exception { Crabs::worngkw4 }, "In fun takekw: no such named parameter: a at ${\__FILE__} line ${\($marker + 11)}.\n"; is exception { Crabs::taket "X" }, "In fun taket: parameter 1 (\$x): A failure (Cool[Story]) of X at ${\__FILE__} line ${\__LINE__}.\n"; is exception { Crabs::worngt1 }, "In fun taket: parameter 1 (\$x): A failure (Cool[Story]) of X at ${\__FILE__} line ${\($marker + 14)}.\n"; Function-Parameters-2.002004/t/eval.t0000644000175000017500000000302113235057757016206 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Function::Parameters; { package TX; method new($class: :$chk) { bless { @_ }, $class } method check($x) { $self->{chk}($x) } method get_message($x) { die "get_message($x)"; } } our @trace; use Function::Parameters { def => { defaults => 'function', runtime => 1, shift => [ [ '$self' => TX->new(chk => fun ($x) { push @trace, [self_check => $x]; 1 }) ], ], install_sub => fun ($name, $body) { $name = caller . "::$name" unless $name =~ /::/; push @trace, [install => $name]; my $sym = do { no strict 'refs'; \*$name }; *$sym = $body; }, } }; package Groovy; use constant OtherType => TX->new( chk => fun ($x) { push @trace, [other_check => $x]; 1 }, ); use Test::More tests => 5; is_deeply [ splice @trace ], []; def foo(OtherType $x) { push @trace, [foo => $self, $x]; } is_deeply [ splice @trace ], [ [install => 'Groovy::foo'], ]; is eval q{ def bar(OtherType $x) { push @trace, [bar => $self, $x]; } 42 }, 42; is_deeply [ splice @trace ], [ [install => 'Groovy::bar'], ]; foo('A1', 'A2'); bar('B1', 'B2'); is_deeply [ splice @trace ], [ [self_check => 'A1'], [other_check => 'A2'], [foo => qw(A1 A2)], [self_check => 'B1'], [other_check => 'B2'], [bar => qw(B1 B2)], ]; Function-Parameters-2.002004/t/types_coerce.t0000644000175000017500000000566114411347422017743 0ustar maukemauke#!perl use warnings qw(all FATAL uninitialized); use strict; use Test::More tests => 15; use Test::Fatal; use Function::Parameters; { package MyTC_noco; method new($class: $good) { bless { good => $good }, $class } method coerce($value) { die "bad"; } method check($value) { $value eq $self->{good} } method get_message($value) { "'$value' ain't '$self->{good}'" } } { package MyTC; BEGIN { our @ISA = MyTC_noco::; } method has_coercion() { $self->{has_coercion} } method enable_coercion($flag = 1) { $self->{has_coercion} = $flag; } method new($class: $good, $coerce = 0) { my $self = $class->SUPER::new($good); $self->enable_coercion($coerce); $self } method coerce($value) { $value =~ s/\?+\z//; $value } } use constant { Type_A => MyTC_noco->new('Type_A:good'), Type_B => MyTC->new('Type_B:good'), Type_C => MyTC->new('Type_C:good', 1), }; fun constrained_0(Type_A $x, Type_B $y, Type_C $z) { [$x, $y, $z] } fun constrained_1((Type_A) $x, (Type_B) $y, (Type_C) $z) { [$x, $y, $z] } fun constrained_2(('Type_A') $x, ('Type_B') $y, ('Type_C') $z) { [$x, $y, $z] } is_deeply constrained_0('Type_A:good', 'Type_B:good', 'Type_C:good'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; is_deeply constrained_1('Type_A:good', 'Type_B:good', 'Type_C:good'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; is_deeply constrained_2('Type_A:good', 'Type_B:good', 'Type_C:good'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; like exception { constrained_0 'Type_A:good???', '-', '-' }, qr/\Q'Type_A:good???' ain't 'Type_A:good'/; like exception { constrained_1 'Type_A:good???', '-', '-' }, qr/\Q'Type_A:good???' ain't 'Type_A:good'/; like exception { constrained_2 'Type_A:good???', '-', '-' }, qr/\Q'Type_A:good???' ain't 'Type_A:good'/; like exception { constrained_0 'Type_A:good', 'Type_B:good???', '-', }, qr/\Q'Type_B:good???' ain't 'Type_B:good'/; like exception { constrained_1 'Type_A:good', 'Type_B:good???', '-', }, qr/\Q'Type_B:good???' ain't 'Type_B:good'/; like exception { constrained_2 'Type_A:good', 'Type_B:good???', '-', }, qr/\Q'Type_B:good???' ain't 'Type_B:good'/; like exception { constrained_0 'Type_A:good', 'Type_B:good', 'Type_C:bad??', }, qr/\Q'Type_C:bad' ain't 'Type_C:good'/; like exception { constrained_1 'Type_A:good', 'Type_B:good', 'Type_C:bad??', }, qr/\Q'Type_C:bad' ain't 'Type_C:good'/; like exception { constrained_2 'Type_A:good', 'Type_B:good', 'Type_C:bad??', }, qr/\Q'Type_C:bad' ain't 'Type_C:good'/; is_deeply constrained_0('Type_A:good', 'Type_B:good', 'Type_C:good???'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; is_deeply constrained_1('Type_A:good', 'Type_B:good', 'Type_C:good???'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; is_deeply constrained_2('Type_A:good', 'Type_B:good', 'Type_C:good???'), ['Type_A:good', 'Type_B:good', 'Type_C:good']; Function-Parameters-2.002004/t/info.t0000644000175000017500000001225514454413243016211 0ustar maukemaukeuse warnings qw(all FATAL uninitialized); use strict; use Test::More tests => 140; use Function::Parameters; use constant Inf => 0 + 'Inf'; fun foo($pr1, $pr2, $po1 = 1, $po2 = 2, :$no1 = 3, :$no2 = 4, %r) {} { my $info = Function::Parameters::info \&foo; is $info->keyword, 'fun'; is_deeply [$info->invocants], []; is scalar $info->invocants, 0; is $info->invocant, undef; is_deeply [$info->positional_required], [qw($pr1 $pr2)]; is scalar $info->positional_required, 2; is_deeply [$info->positional_optional], [qw($po1 $po2)]; is scalar $info->positional_optional, 2; is_deeply [$info->named_required], []; is scalar $info->named_required, 0; is_deeply [$info->named_optional], [qw($no1 $no2)]; is scalar $info->named_optional, 2; is $info->slurpy, '%r'; is $info->args_min, 2; is $info->args_max, Inf; } { my $info = Function::Parameters::info fun ($pr1, :$nr1, :$nr2) {}; is $info->keyword, 'fun'; is_deeply [$info->invocants], []; is scalar $info->invocants, 0; is $info->invocant, undef; is_deeply [$info->positional_required], [qw($pr1)]; is scalar $info->positional_required, 1; is_deeply [$info->positional_optional], []; is scalar $info->positional_optional, 0; is_deeply [$info->named_required], [qw($nr1 $nr2)]; is scalar $info->named_required, 2; is_deeply [$info->named_optional], []; is scalar $info->named_optional, 0; is $info->slurpy, undef; is $info->args_min, 5; is $info->args_max, Inf; } sub bar {} is Function::Parameters::info(\&bar), undef; is Function::Parameters::info(sub {}), undef; method baz($class: $po1 = 1, $po2 = 2, $po3 = 3, :$no1 = 4, @rem) {} { my $info = Function::Parameters::info \&baz; is $info->keyword, 'method'; is_deeply [$info->invocants], [qw($class)]; is scalar $info->invocants, 1; is $info->invocant, '$class'; is_deeply [$info->positional_required], []; is scalar $info->positional_required, 0; is_deeply [$info->positional_optional], [qw($po1 $po2 $po3)]; is scalar $info->positional_optional, 3; is_deeply [$info->named_required], []; is scalar $info->named_required, 0; is_deeply [$info->named_optional], [qw($no1)]; is scalar $info->named_optional, 1; is $info->slurpy, '@rem'; is $info->args_min, 1; is $info->args_max, Inf; } { my $info = Function::Parameters::info method () {}; is $info->keyword, 'method'; is_deeply [$info->invocants], [qw($self)]; is scalar $info->invocants, 1; is $info->invocant, '$self'; is_deeply [$info->positional_required], []; is scalar $info->positional_required, 0; is_deeply [$info->positional_optional], []; is scalar $info->positional_optional, 0; is_deeply [$info->named_required], []; is scalar $info->named_required, 0; is_deeply [$info->named_optional], []; is scalar $info->named_optional, 0; is $info->slurpy, undef; is $info->args_min, 1; is $info->args_max, 1; } { use Function::Parameters { proc => 'function' }; my $info = Function::Parameters::info proc (@) {}; is $info->keyword, 'proc'; is_deeply [$info->invocants], []; is scalar $info->invocants, 0; is $info->invocant, undef; is_deeply [$info->positional_required], []; is scalar $info->positional_required, 0; is_deeply [$info->positional_optional], []; is scalar $info->positional_optional, 0; is_deeply [$info->named_required], []; is scalar $info->named_required, 0; is_deeply [$info->named_optional], []; is scalar $info->named_optional, 0; is $info->slurpy, '@'; is $info->args_min, 0; is $info->args_max, Inf; } { my $info = Function::Parameters::info method (@) {}; is $info->keyword, 'method'; is_deeply [$info->invocants], [qw($self)]; is scalar $info->invocants, 1; is $info->invocant, '$self'; is_deeply [$info->positional_required], []; is scalar $info->positional_required, 0; is_deeply [$info->positional_optional], []; is scalar $info->positional_optional, 0; is_deeply [$info->named_required], []; is scalar $info->named_required, 0; is_deeply [$info->named_optional], []; is scalar $info->named_optional, 0; is $info->slurpy, '@'; is $info->args_min, 1; is $info->args_max, Inf; } { my @fs; for my $i (qw(aku soku zan)) { push @fs, [$i => fun (:$sin, :$swift, :$slay) { $i }]; } for my $kf (@fs) { my ($i, $f) = @$kf; my $info = Function::Parameters::info $f; is $info->keyword, 'fun'; is_deeply [$info->invocants], []; is scalar $info->invocants, 0; is $info->invocant, undef; is_deeply [$info->positional_required], []; is scalar $info->positional_required, 0; is_deeply [$info->positional_optional], []; is scalar $info->positional_optional, 0; is_deeply [$info->named_required], [qw($sin $swift $slay)]; is scalar $info->named_required, 3; is_deeply [$info->named_optional], []; is scalar $info->named_optional, 0; is $info->slurpy, undef; is $info->args_min, 6; is $info->args_max, Inf; is $f->(sin => 1, swift => 2, slay => 3), $i; } } Function-Parameters-2.002004/t/defaults.t0000644000175000017500000002310214411204554017052 0ustar maukemauke#!perl use strict; use warnings qw(all FATAL uninitialized); use Test::More tests => 106; use Function::Parameters { fun => { default_arguments => 1, }, nofun => { default_arguments => 0, }, }; fun foo0($x, $y = 1, $z = 3) { $x * 5 + $y * 2 + $z } is foo0(10), 55; is foo0(5, -2), 24; is foo0(6, 10, 1), 51; fun foo1($x, $y //= 1, $z //= 3) { $x * 5 + $y * 2 + $z } is foo1(10), 55; is foo1(10, undef), 55; is foo1(10, undef, undef), 55; is foo1(5, -2), 24; is foo1(5, -2, undef), 24; is foo1(6, 10, 1), 51; is fun ($answer = 42) { $answer }->(), 42; is fun ($answer //= 42) { $answer }->(), 42; is fun ($answer //= 42) { $answer }->(undef), 42; fun sharingan0($input, $x = [], $y = {}) { push @$x, $input; $y->{$#$x} = $input; $x, $y } { is_deeply [sharingan0 'e'], [['e'], {0 => 'e'}]; my $sneaky = ['ants']; is_deeply [sharingan0 $sneaky], [[['ants']], {0 => ['ants']}]; unshift @$sneaky, 'thanks'; is_deeply [sharingan0 $sneaky], [[['thanks', 'ants']], {0 => ['thanks', 'ants']}]; @$sneaky = 'thants'; is_deeply [sharingan0 $sneaky], [[['thants']], {0 => ['thants']}]; } fun sharingan1($input, $x //= [], $y //= {}) { push @$x, $input; $y->{$#$x} = $input; $x, $y } { is_deeply [sharingan1 'e', undef, undef], [['e'], {0 => 'e'}]; my $sneaky = ['ants']; is_deeply [sharingan1 $sneaky, undef], [[['ants']], {0 => ['ants']}]; unshift @$sneaky, 'thanks'; is_deeply [sharingan1 $sneaky], [[['thanks', 'ants']], {0 => ['thanks', 'ants']}]; @$sneaky = 'thants'; is_deeply [sharingan1 $sneaky, undef, undef], [[['thants']], {0 => ['thants']}]; } is eval('fun ($x, $y = $powersauce) {}'), undef; like $@, qr/^Global symbol.*explicit package name/; is eval('fun ($x, $y //= $powersauce) {}'), undef; like $@, qr/^Global symbol.*explicit package name/; { my $d = 'outer'; my $f; { my $d = 'herp'; fun guy($d = $d, $x = $d . '2') { return [$d, $x]; } is_deeply guy('a', 'b'), ['a', 'b']; is_deeply guy('c'), ['c', 'c2']; is_deeply guy, ['herp', 'herp2']; $d = 'ort'; is_deeply guy('a', 'b'), ['a', 'b']; is_deeply guy('c'), ['c', 'c2']; is_deeply guy, ['ort', 'ort2']; my $g = fun ($alarum = $d) { "[$alarum]" }; is $g->(""), "[]"; is $g->(), "[ort]"; $d = 'flowerpot'; is_deeply guy('bloodstain'), ['bloodstain', 'bloodstain2']; is $g->(), "[flowerpot]"; $f = $g; } is $f->(), "[flowerpot]"; is $f->("Q"), "[Q]"; } { my $c = 0; fun edelweiss($x = $c++) :prototype(;$) { $x } } is edelweiss "AAAAA", "AAAAA"; is_deeply edelweiss [], []; is edelweiss, 0; is edelweiss, 1; is_deeply edelweiss {}, {}; is edelweiss 0, 0; is edelweiss, 2; for my $f (fun ($wtf = return 'ohi') { "~$wtf" }) { is $f->(""), "~"; is $f->("a"), "~a"; is $f->(), "ohi"; } for my $f (fun ($wtf //= return 'ohi') { "~$wtf" }) { is $f->(""), "~"; is $f->("a"), "~a"; is $f->(undef), "ohi"; is $f->(), "ohi"; } is eval('fun (@x = 42) {}'), undef; like $@, qr/default value/; is eval('fun ($x, %y = ()) {}'), undef; like $@, qr/default value/; is eval('nofun ($x = 42) {}'), undef; like $@, qr/nofun.*default argument/; is eval('fun (@x //= 42) {}'), undef; like $@, qr/default value/; is eval('fun ($x, %y //= ()) {}'), undef; like $@, qr/default value/; is eval('nofun ($x //= 42) {}'), undef; like $@, qr/nofun.*default argument/; { my $var = "outer"; fun scope_check( $var, # inner $snd = "${var}2", # initialized from $var) $both = "$var and $snd", ) { return $var, $snd, $both; } is_deeply [scope_check 'A'], ['A', 'A2', 'A and A2']; is_deeply [scope_check 'B', 'C'], ['B', 'C', 'B and C']; is_deeply [scope_check 4, 5, 6], [4, 5, 6]; is eval('fun ($QQQ = $QQQ) {}; 1'), undef; like $@, qr/Global symbol.*\$QQQ.*explicit package name/; is eval('fun ($QQQ //= $QQQ) {}; 1'), undef; like $@, qr/Global symbol.*\$QQQ.*explicit package name/; use Function::Parameters { method => 'method' }; method mscope_check( $var, # inner $snd = "${var}2", # initialized from $var $both = "($self) $var and $snd", # and $self! ) { return $self, $var, $snd, $both; } is_deeply [mscope_check '$x', 'A'], ['$x', 'A', 'A2', '($x) A and A2']; is_deeply [mscope_check '$x', 'B', 'C'], ['$x', 'B', 'C', '($x) B and C']; is_deeply [mscope_check '$x', 4, 5, 6], ['$x', 4, 5, 6]; } { my @extra; my $f = fun ( $p0, $p1 //= 'd1', $p2 = 'd2', $p3 = 'd3', $p4 = (push(@extra, 'x4'), 'd4'), $p5 //= 'd5', $p6 = 'd6', $ = push(@extra, 'x7'), $p8 = 'd8', $ //= push(@extra, 'x9'), ) { [ $p0, $p1, $p2, $p3, $p4, $p5, $p6, $p8 ] }; is_deeply [$f->(undef), [splice @extra]], [[undef, 'd1', 'd2', 'd3', 'd4', 'd5', 'd6', 'd8'], ['x4', 'x7', 'x9']]; is_deeply [$f->('a0'), [splice @extra]], [['a0', 'd1', 'd2', 'd3', 'd4', 'd5', 'd6', 'd8'], ['x4', 'x7', 'x9']]; is_deeply [$f->('a0', undef), [splice @extra]], [['a0', 'd1', 'd2', 'd3', 'd4', 'd5', 'd6', 'd8'], ['x4', 'x7', 'x9']]; is_deeply [$f->('a0', 'a1'), [splice @extra]], [['a0', 'a1', 'd2', 'd3', 'd4', 'd5', 'd6', 'd8'], ['x4', 'x7', 'x9']]; is_deeply [$f->('a0', 'a1', undef), [splice @extra]], [['a0', 'a1', undef, 'd3', 'd4', 'd5', 'd6', 'd8'], ['x4', 'x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2'), [splice @extra]], [['a0', 'a1', 'a2', 'd3', 'd4', 'd5', 'd6', 'd8'], ['x4', 'x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', undef), [splice @extra]], [['a0', 'a1', 'a2', undef, 'd4', 'd5', 'd6', 'd8'], ['x4', 'x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'd4', 'd5', 'd6', 'd8'], ['x4', 'x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', undef), [splice @extra]], [['a0', 'a1', 'a2', 'a3', undef, 'd5', 'd6', 'd8'], ['x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'd5', 'd6', 'd8'], ['x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', undef), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'd5', 'd6', 'd8'], ['x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'd6', 'd8'], ['x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5', undef), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', undef, 'd8'], ['x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'd8'], ['x7', 'x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', undef), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'd8'], ['x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a7'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'd8'], ['x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a7', undef), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', undef], ['x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a7', 'a8'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a8'], ['x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a7', 'a8', undef), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a8'], ['x9']]; is_deeply [$f->('a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a7', 'a8', 'a9'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4', 'a5', 'a6', 'a8'], []]; is_deeply [$f->(undef, 'a1', undef, 'a3', undef, 'a5', undef, 'a7', undef, 'a9'), [splice @extra]], [[undef, 'a1', undef, 'a3', undef, 'a5', undef, undef], []]; is_deeply [$f->('a0', undef, 'a2', undef, 'a4', undef, 'a6', undef, 'a8', undef), [splice @extra]], [['a0', 'd1', 'a2', undef, 'a4', 'd5', 'a6', 'a8'], ['x9']]; } { my @extra; my $f = fun ( :$p0, :$p1 //= 'd1', :$p2 = 'd2', :$p3 //= (push(@extra, 'x3'), 'd3'), :$p4 = (push(@extra, 'x4'), 'd4'), ) { [ $p0, $p1, $p2, $p3, $p4 ] }; is_deeply [$f->(p0 => undef), [splice @extra]], [[undef, 'd1', 'd2', 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p0 => 'a0'), [splice @extra]], [['a0', 'd1', 'd2', 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p0 => 'a0', p1 => undef), [splice @extra]], [['a0', 'd1', 'd2', 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p1 => 'a1', p0 => 'a0'), [splice @extra]], [['a0', 'a1', 'd2', 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p1 => undef, p0 => 'a0', p1 => 'a1'), [splice @extra]], [['a0', 'a1', 'd2', 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p1 => 'a1', p0 => 'a0', p1 => undef), [splice @extra]], [['a0', 'd1', 'd2', 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p0 => 'a0', p1 => 'a1', p2 => undef), [splice @extra]], [['a0', 'a1', undef, 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p0 => 'a0', p1 => 'a1', p2 => 'a2'), [splice @extra]], [['a0', 'a1', 'a2', 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p0 => 'a0', p1 => 'a1', p2 => 'a2', p3 => undef), [splice @extra]], [['a0', 'a1', 'a2', 'd3', 'd4'], ['x3', 'x4']]; is_deeply [$f->(p0 => 'a0', p1 => 'a1', p2 => 'a2', p3 => 'a3'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'd4'], ['x4']]; is_deeply [$f->(p0 => 'a0', p1 => 'a1', p2 => 'a2', p3 => 'a3', p4 => undef), [splice @extra]], [['a0', 'a1', 'a2', 'a3', undef], []]; is_deeply [$f->(p0 => 'a0', p1 => 'a1', p2 => 'a2', p3 => 'a3', p4 => 'a4'), [splice @extra]], [['a0', 'a1', 'a2', 'a3', 'a4'], []]; } Function-Parameters-2.002004/t/unicode2.t0000644000175000017500000000234413235057757016776 0ustar maukemauke#!perl use utf8; use Test::More tests => 25; use warnings FATAL => 'all'; use strict; use Function::Parameters { pŕöç => 'function_strict' }; pŕöç hörps($x) { $x * 2 } pŕöç drau($spın̈al_tap) { $spın̈al_tap * 3 } pŕöç ääää($éééééé) { $éééééé * 4 } is hörps(10), 20; is drau(11), 33; is ääää(12), 48; is eval('pŕöç á(){} 1'), 1; is á(), undef; is eval('pŕöç ́(){} 1'), undef; like $@, qr/pŕöç.* parameter list/s; is eval(q), undef; like $@, qr/pŕöç.* parameter list/s; is eval('pŕöç ::hi($z){} 1'), 1; is hi(42), undef; is eval('pŕöç 123(){} 1'), undef; like $@, qr/pŕöç.* parameter list/s; is eval('pŕöç main::234(){} 1'), undef; like $@, qr/pŕöç.* parameter list/s; is eval('pŕöç m123($z){} 1'), 1; is m123(42), undef; is eval('pŕöç ::m234($z){} 1'), 1; is m234(42), undef; is eval { ääää }, undef; like $@, qr/pŕöç.*ääää/s; for my $info (Function::Parameters::info \&ääää) { is $info->keyword, 'pŕöç'; is join(' ', $info->positional_required), '$éééééé'; } for my $info (Function::Parameters::info \&drau) { is $info->keyword, 'pŕöç'; is join(' ', $info->positional_required), '$spın̈al_tap'; } Function-Parameters-2.002004/t/strict_1.fail0000644000175000017500000000013413235057757017461 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters; fun bad_1($x, @y, $z) {} 'ok' Function-Parameters-2.002004/t/lexical.t0000644000175000017500000000214413235057757016705 0ustar maukemauke#!perl use Test::More tests => 16; use warnings FATAL => 'all'; use strict; sub Burlap::fun (&) { $_[0]->() } { use Function::Parameters; is fun () { 2 + 2 }->(), 4; package Burlap; ::ok fun () { 0 }; } { package Burlap; ::is fun { 'singing' }, 'singing'; } { sub proc (&) { &Burlap::fun } use Function::Parameters { proc => 'function' }; proc add($x, $y) { return $x + $y; } is add(@{[2, 3]}), 5; { use Function::Parameters; is proc () { 'bla' }->(), 'bla'; is method () { $self }->('der'), 'der'; { no Function::Parameters; is proc { 'unk' }, 'unk'; is eval('fun foo($x) { $x; } 1'), undef; like $@, qr/syntax error/; } is proc () { 'bla' }->(), 'bla'; is method () { $self }->('der'), 'der'; no Function::Parameters 'proc'; is proc { 'unk2' }, 'unk2'; is method () { $self }->('der2'), 'der2'; } is proc () { 'bla3' }->(), 'bla3'; is eval('fun foo($x) { $x; } 1'), undef; like $@, qr/syntax error/; } Function-Parameters-2.002004/t/prototype.t0000644000175000017500000000671113235057757017335 0ustar maukemauke#!perl use Test::More tests => 73; use warnings FATAL => 'all'; use strict; use Function::Parameters; is eval 'fun () :prototype([) {}', undef; like $@, qr/Illegal character in prototype/; is eval 'fun () :prototype(][[[[[[) {}', undef; like $@, qr/Illegal character in prototype/; is eval 'fun () :prototype(\;) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype(\[_;@]) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype(\+) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype(\\\\) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype([$]) {}', undef; like $@, qr/Illegal character in prototype/; is eval 'fun () :prototype(\[_$]) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype(__) {}', undef; like $@, qr/Illegal character after '_' in prototype/; is eval 'fun () :prototype(_$) {}', undef; like $@, qr/Illegal character after '_' in prototype/; is eval 'fun () :prototype(_\@) {}', undef; like $@, qr/Illegal character after '_' in prototype/; { no warnings qw(illegalproto); ok eval 'fun () :prototype([) {}'; ok eval 'fun () :prototype(][[[[[[) {}'; ok eval 'fun () :prototype(\;) {}'; ok eval 'fun () :prototype(\[_;@]) {}'; ok eval 'fun () :prototype(\+) {}'; ok eval 'fun () :prototype(\\\\) {}'; ok eval 'fun () :prototype([$]) {}'; ok eval 'fun () :prototype(\[_$]) {}'; ok eval 'fun () :prototype(__) {}'; ok eval 'fun () :prototype(_$) {}'; ok eval 'fun () :prototype(_\@) {}'; } is eval 'fun () :prototype([) {}', undef; like $@, qr/Illegal character in prototype/; is eval 'fun () :prototype(][[[[[[) {}', undef; like $@, qr/Illegal character in prototype/; is eval 'fun () :prototype(\;) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype(\[_;@]) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype(\+) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype(\\\\) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype([$]) {}', undef; like $@, qr/Illegal character in prototype/; is eval 'fun () :prototype(\[_$]) {}', undef; like $@, qr/Illegal character after '\\' in prototype/; is eval 'fun () :prototype(__) {}', undef; like $@, qr/Illegal character after '_' in prototype/; is eval 'fun () :prototype(_$) {}', undef; like $@, qr/Illegal character after '_' in prototype/; is eval 'fun () :prototype(_\@) {}', undef; like $@, qr/Illegal character after '_' in prototype/; { no warnings qw(illegalproto); ok eval 'fun () :prototype([) {}'; ok eval 'fun () :prototype(][[[[[[) {}'; ok eval 'fun () :prototype(\;) {}'; ok eval 'fun () :prototype(\[_;@]) {}'; ok eval 'fun () :prototype(\+) {}'; ok eval 'fun () :prototype(\\\\) {}'; ok eval 'fun () :prototype([$]) {}'; ok eval 'fun () :prototype(\[_$]) {}'; ok eval 'fun () :prototype(__) {}'; ok eval 'fun () :prototype(_$) {}'; ok eval 'fun () :prototype(_\@) {}'; } is eval 'fun () :prototype($) prototype(@) {}', undef; like $@, qr/Can't redefine prototype/; ok eval 'fun () :prototype(_) {}'; ok eval 'fun () :prototype(_;) {}'; ok eval 'fun () :prototype(_;$) {}'; ok eval 'fun () :prototype(_@) {}'; ok eval 'fun () :prototype(_%) {}'; Function-Parameters-2.002004/t/name_1.fail0000644000175000017500000000041213235057757017070 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters { func => { name => 'required', }, f => { name => 'prohibited', }, method => { name => 'required', shift => '$this', }, }; my $bad = func () { 1 }; Function-Parameters-2.002004/t/checkered_3.t0000644000175000017500000001162613235057757017430 0ustar maukemauke#!perl use Test::More tests => 108; use warnings FATAL => 'all'; use strict; use Function::Parameters qw(:strict); fun error_like($re, $body, $name = undef) { local $@; ok !eval { $body->(); 1 }; like $@, $re, $name; } fun foo_any(@) { [@_] } fun foo_any_a(@args) { [@args] } fun foo_any_b($x = undef, @rest) { [@_] } fun foo_0() { [@_] } fun foo_1($x) { [@_] } fun foo_2($x, $y) { [@_] } fun foo_3($x, $y, $z) { [@_] } fun foo_0_1($x = 'D0') { [$x] } fun foo_0_2($x = 'D0', $y = 'D1') { [$x, $y] } fun foo_0_3($x = 'D0', $y = undef, $z = 'D2') { [$x, $y, $z] } fun foo_1_2($x, $y = 'D1') { [$x, $y] } fun foo_1_3($x, $y = 'D1', $z = 'D2') { [$x, $y, $z] } fun foo_2_3($x, $y, $z = 'D2') { [$x, $y, $z] } fun foo_1_($x, @y) { [@_] } is_deeply foo_any, []; is_deeply foo_any('a'), ['a']; is_deeply foo_any('a', 'b'), ['a', 'b']; is_deeply foo_any('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_any_a, []; is_deeply foo_any_a('a'), ['a']; is_deeply foo_any_a('a', 'b'), ['a', 'b']; is_deeply foo_any_a('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any_a('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_any_b, []; is_deeply foo_any_b('a'), ['a']; is_deeply foo_any_b('a', 'b'), ['a', 'b']; is_deeply foo_any_b('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_any_b('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is_deeply foo_0, []; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0/, fun () { foo_0 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1/, fun () { foo_1 }; is_deeply foo_1('a'), ['a']; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b' }; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_1/, fun () { foo_1 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 }; error_like qr/^Too few arguments.*foo_2/, fun () { foo_2 'a' }; is_deeply foo_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_2/, fun () { foo_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a' }; error_like qr/^Too few arguments.*foo_3/, fun () { foo_3 'a', 'b' }; is_deeply foo_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_3/, fun () { foo_3 'a', 'b', 'c', 'd' }; is_deeply foo_0_1, ['D0']; is_deeply foo_0_1('a'), ['a']; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b' }; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0_1/, fun () { foo_0_1 'a', 'b', 'c', 'd' }; is_deeply foo_0_2, ['D0', 'D1']; is_deeply foo_0_2('a'), ['a', 'D1']; is_deeply foo_0_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_0_2/, fun () { foo_0_2 'a', 'b', 'c', 'd' }; is_deeply foo_0_3, ['D0', undef, 'D2']; is_deeply foo_0_3('a'), ['a', undef, 'D2']; is_deeply foo_0_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_0_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_0_3/, fun () { foo_0_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_2/, fun () { foo_1_2 }; is_deeply foo_1_2('a'), ['a', 'D1']; is_deeply foo_1_2('a', 'b'), ['a', 'b']; error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c' }; error_like qr/^Too many arguments.*foo_1_2/, fun () { foo_1_2 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_3/, fun () { foo_1_3 }; is_deeply foo_1_3('a'), ['a', 'D1', 'D2']; is_deeply foo_1_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_1_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_1_3/, fun () { foo_1_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 }; error_like qr/^Too few arguments.*foo_2_3/, fun () { foo_2_3 'a' }; is_deeply foo_2_3('a', 'b'), ['a', 'b', 'D2']; is_deeply foo_2_3('a', 'b', 'c'), ['a', 'b', 'c']; error_like qr/^Too many arguments.*foo_2_3/, fun () { foo_2_3 'a', 'b', 'c', 'd' }; error_like qr/^Too few arguments.*foo_1_/, fun () { foo_1_ }; is_deeply foo_1_('a'), ['a']; is_deeply foo_1_('a', 'b'), ['a', 'b']; is_deeply foo_1_('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply foo_1_('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; use Function::Parameters qw(:lax); fun puppy($eyes) { [@_] } fun frog($will, $never) { $will * 3 + (pop) - $never } is_deeply puppy, []; is_deeply puppy('a'), ['a']; is_deeply puppy('a', 'b'), ['a', 'b']; is_deeply puppy('a', 'b', 'c'), ['a', 'b', 'c']; is_deeply puppy('a', 'b', 'c', 'd'), ['a', 'b', 'c', 'd']; is frog(7, 4, 1), 18; is frog(7, 4), 21; Function-Parameters-2.002004/t/elsewhere.t0000644000175000017500000000055213235057757017250 0ustar maukemaukeuse strict; use warnings; use Test::More; { package Wrapper; use Function::Parameters (); sub shazam { Function::Parameters->import(@_); } } BEGIN { Wrapper::shazam; } ok fun ($x) { $x }->(1); { package Cu::Ba; BEGIN { Wrapper::shazam { gorn => 'function_lax' }; } gorn wooden ($gorn) { !$gorn } } ok Cu::Ba::wooden; done_testing; Function-Parameters-2.002004/t/defaults_regress.t0000644000175000017500000000056413235057757020631 0ustar maukemauke#!perl use Test::More tests => 3; use warnings FATAL => 'all'; use strict; use Function::Parameters { fun => { default_arguments => 1, }, }; { my ($d0, $d1, $d2, $d3); my $default = 'aaa'; fun padness($x = $default++) { return $x; } is padness('unrelated'), 'unrelated'; is &padness(), 'aaa'; is padness, 'aab'; } Function-Parameters-2.002004/t/types_custom_2.t0000644000175000017500000000300713235057757020242 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 4; use Test::Fatal; { package MyTC; use Function::Parameters qw(:strict); method new( $class: $name, $check, $get_message = fun ($value) { "Validation failed for constraint '$name' with value '$value'" }, ) { bless { name => $name, check => $check, get_message => $get_message, }, $class } method check($value) { $self->{check}($value) } method get_message($value) { $self->{get_message}($value) } } use Function::Parameters do { use Function::Parameters qw(:strict); my %Types = ( TEvenNum => MyTC->new('even number' => fun ($n) { $n =~ /^[0-9]+\z/ && $n % 2 == 0 }), TShortStr => MyTC->new('short string' => fun ($s) { length($s) < 10 }), Any => MyTC->new('any value' => fun ($a) { 1 }), ); +{ fun => { strict => 1, reify_type => sub { $Types{ $_[0] } || $Types{Any} }, }, } }; fun foo(TEvenNum $x, TShortStr $y) { "$x/$y" } is foo(42, "hello"), "42/hello"; like exception { foo 41, "hello" }, qr{\bValidation failed for constraint 'even number' with value '41'}; like exception { foo 42, "1234567890~" }, qr{\bValidation failed for constraint 'short string' with value '1234567890~'}; like exception { foo 41, "1234567890~" }, qr{\bValidation failed for constraint 'even number' with value '41'}; Function-Parameters-2.002004/t/name.t0000644000175000017500000000201714362360761016175 0ustar maukemaukeuse warnings; use strict; use Test::More tests => 12; use FindBin; use Function::Parameters { func => { name => 'required', }, f => { name => 'prohibited', }, method => { name => 'required', shift => '$this', }, }; func foo($x, $y, $z) { $x .= $z; return $y . $x . $y; } method bar($k, $d) { $d = $k . $d; return $d . $this->{$k} . $d; } is foo('a', 'b', 'c'), 'bacb'; is bar({ab => 'cd'}, 'ab', 'e'), 'abecdabe'; my $baz = f ($x) { $x * 2 + 1 }; is $baz->(11), 23; is $baz->(-0.5), 0; for my $fail ( map ["$FindBin::Bin/name_$_->[0].fail", @$_[1 .. $#$_]], ['1', qr/expect.*function.*name/], ['2', qr/expect.*parameter.*list/], ['3', qr/expect.*function.*name/], ['4', qr/Global symbol "\$self" requires explicit package name/] ) { my ($file, $pat) = @$fail; my $done = do $file; my $exc = $@; my $err = $!; is $done, undef, "faulty code doesn't load - $file"; $exc or die "$file: $err"; like $exc, $pat; } Function-Parameters-2.002004/t/lineno-torture.t0000644000175000017500000001745513235057757020265 0ustar maukemaukeuse warnings; use strict; use Test::More; use Function::Parameters; fun actual_location_of_line_with($marker) { seek DATA, 0, 0 or die "seek DATA: $!"; my $loc = 0; while (my $line = readline DATA) { $loc++; index($line, $marker) >= 0 and return $loc; } undef } fun test_loc($marker) { my $expected = actual_location_of_line_with $marker; defined $expected or die "$marker: something done fucked up"; my $got = (caller)[2]; is $got, $expected, "location of '$marker'"; } sub { test_loc 'LT torture begin.'; use integer; my $r = shift; my $a = shift; my $b = shift; test_loc 'LT torture A.'; @_ = ( sub { my $f = shift; test_loc 'LT torture B.'; @_ = ( sub { my $f = shift; test_loc 'LT torture C.'; @_ = ( sub { my $f = shift; test_loc 'LT torture D.'; @_ = ( sub { my $n = shift; test_loc 'LT torture end.'; @_ = $n; goto &$r; }, $b ); goto &$f; }, $a ); goto &$f; }, sub { my $r = shift; my $f = shift; @_ = sub { my $r = shift; my $x = shift; @_ = sub { my $r = shift; my $y = shift; test_loc 'LT torture body.'; if ($x && $y) { @_ = ( sub { my $f = shift; @_ = ($r, ($x & $y) << 1); goto &$f; }, $x ^ $y ); goto &$f; } @_ = $x ^ $y; goto &$r; }; goto &$r; }; goto &$r; } ); goto &$f; }, sub { my $r = shift; my $y = shift; @_ = sub { my $r = shift; my $f = shift; @_ = sub { my $r = shift; my $x = shift; @_ = ( sub { my $f = shift; @_ = ($r, $x); goto &$f; }, sub { my $r = shift; my $x = shift; @_ = ( sub { my $g = shift; @_ = ( sub { my $f = shift; @_ = ($r, $x); goto &$f; }, $f ); goto &$g; }, $y ); goto &$y; } ); goto &$f; }; goto &$r; }; goto &$r; } ); goto & { sub { my $r = shift; my $f = shift; test_loc 'LT torture boot.'; @_ = ($r, $f); goto &$f; } }; }->(sub { my $n = shift; is $n, 2, '1 + 1 = 2' }, 1, 1); { #local $TODO = 'line numbers all fucked up'; fun ($r, $a, $b) { test_loc 'LX torture begin.'; use integer; test_loc 'LX torture A.'; @_ = ( do { test_loc 'LX torture A-post.'; () }, do { test_loc 'LX torture B-pre.'; () }, fun ($f) { test_loc 'LX torture B-pre.'; test_loc 'LX torture B.'; @_ = ( fun ($f) { test_loc 'LX torture C.'; @_ = ( fun ($f) { test_loc 'LX torture D.'; @_ = ( fun ($n) { test_loc 'LX torture end.'; @_ = $n; goto &$r; }, $b ); goto &$f; }, $a ); goto &$f; }, fun ($r, $f) { @_ = fun ($r, $x) { @_ = fun ($r, $y) { test_loc 'LX torture body.'; if ($x && $y) { @_ = ( fun ($f) { @_ = ($r, ($x & $y) << 1); goto &$f; }, $x ^ $y ); goto &$f; } @_ = $x ^ $y; goto &$r; }; goto &$r; }; goto &$r; } ); goto &$f; }, fun ($r, $y) { @_ = fun ($r, $f) { @_ = fun ($r, $x) { @_ = ( fun ($f) { @_ = ($r, $x); goto &$f; }, fun ($r, $x) { @_ = ( fun ($g) { @_ = ( fun ($f) { @_ = ($r, $x); goto &$f; }, $f ); goto &$g; }, $y ); goto &$y; } ); goto &$f; }; goto &$r; }; goto &$r; } ); goto & { fun ($r, $f) { test_loc 'LX torture boot.'; @_ = ($r, $f); goto &$f; } }; }->(fun ($n) { is $n, 2, '1 + 1 = 2' }, 1, 1); } done_testing; __DATA__ Function-Parameters-2.002004/t/name_3.fail0000644000175000017500000000042013235057757017071 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters { func => { name => 'required', }, f => { name => 'prohibited', }, method => { name => 'required', shift => '$this', }, }; my $bad = method () { $this }; Function-Parameters-2.002004/Changes0000644000175000017500000003162414454414437016130 0ustar maukemaukeRevision history for Function-Parameters 2.002004 2023-07-15 - Remove 'perl -T' from tests. This way we can run on perls compiled without support for taint mode. The test didn't actually care about taint anyway. 2.002003 2023-04-19 - Fix line numbers after inlined type checks (gh #42). Previously, the code for type checks was inlined literally, so if a particular check took 5 lines of code, all the following line numbers in the source file would be off by 5 (they would be "pushed down" by the interpolated code). These bad line numbers would show up in error messages from Perl (including warn and die) as well as __LINE__ and caller (and thus stack traces). 2.002002 2023-04-01 - Work around old versions of ExtUtils::MakeMaker not providing is_make_type(), whose version dependency is undocumented (sigh). - Restrict GNU syntax for exporting variables to type 'gmake'; should fix building on BSD, Solaris, etc. - Declare dependency on ExtUtils::MakeMaker 7+ and remove compatibility code for older versions. 2.002001 2023-04-01 - Fix (hopefully) Windows builds using nmake.exe. 2.002 2023-04-01 - Provide //= for default arguments that are also used when the caller passes in undef. - Provide more type combinators in parameter declarations: In addition to | (union types), now ~ & / are also supported (for complement types, intersection types, and alternative types, respectively). - Enable type coercions. If a parameter has a declared type and that type supports coercions ($type->has_coercion returns true), call its ->coerce($value) method to transform arguments before type checking. - Enable inline type checks. If a parameter has a declared type and that type supports inlining ($type->can_be_inlined returns true), its inline code (as provided by ->inline_check('$value')) is baked into the function definition instead of a call to ->check($value). This may speed up type checks. - Move a big chunk of tests to xt/ (author testing only). - Remove xt/ from the distribution. - Enable parallel testing by default (with -j4). 2.001006 2023-03-27 - Work around perl core issue GH#20950 (use re "eval" doesn't capture lexical %^H environment like eval() does and stringifies it instead) by downgrading the previous hard error to a warning (in the new category 'Function::Parameters') and switching Function::Parameters off in the affected scope. 2.001005 2023-01-27 - Fix failures with perl 5.37.5 .. 5.37.6 caused by new internal opcode structure for anonymous subs. 2.001004 2023-01-20 - Drop Dir::Self test dependency (use FindBin instead). 2.001003 2017-11-11 - Fix threaded initialization issue better. This is the same issue that was fixed in 2.001002, but now we use PL_op_mutex instead of PL_check_mutex. This has the advantage of also being thread-safe on v5.14. 2.001002 2017-11-09 - Fix crash when Function::Parameters is loaded at runtime by multiple threads (a stack overflow due to infinite recursion). This is arguably a core bug (RT#132413). The current workaround employed by Function::Parameters slightly abuses an internal perl mutex meant for something else (protecting op checkers), but it fixes the issue on perls v5.16 .. v5.26. v5.14 doesn't have this API yet, so the workaround is not thread safe there. It is technically possible to still run into this issue if two threads initialize Function::Parameters at the exact same moment (I haven't managed to reproduce this yet, so hopefully it's unlikely in practice). It is possible to completely avoid the problem on all versions of perl and Function::Parameters by making sure the module is loaded before the first thread is created. 2.001001 2017-07-12 - fix duplicate type check on invocant: method foo(T $self: $x) { ... } # every call to foo() performs T->check($self) twice - clean up how type errors refer to parameters (now it's "parameter $N" for non-invocant parameters and "invocant $N" for invocants (or just "invocant" if there is exactly one)) - rewrite pragma implementation and the way %^H is used - remove several internal package variables 2.000007 2017-05-15 - no real code changes - extend bug RT#129090 workaround to perl 5.25.5 - try to detect broken Moose installs earlier - fix declaration of developer dependencies 2.000006 2017-04-16 - work around core bug RT#129090 / RT#131146 in perl 5.22 and 5.24: perl -e 'use Function::Parameters; \&f; fun f() { eval "" }' hangs in the compiler (also happens with perl -d or Devel::Cover instead of eval) (gh #29) 2.000003 2017-03-31 - fix a bug where method modifiers would inadvertently declare subs (e.g. 'before foo() {}' acting like 'sub foo; BEGIN { &before('foo', sub {}) }'), breaking Pkg->can($method) and thus Class::Method::Modifiers (RT #120804) - make method modifiers take effect at runtime because otherwise you'd have to wrap every with()/extends() in a BEGIN block to make consumed/inherited methods visible to modifiers (RT #120804) - make method modifiers require a name (what would an anonymous modifier modify?) - (hopefully) improve the error message you get for trying to add any parameters after a slurpy 2.000002 2017-03-27 - default to strict mode - allow types with multiple arguments (e.g. 'Tuple[Int, String]') - implement new 'auto' type reifier and use it by default - allow multiple invocants - support custom installers - implement Moo/Moose-style method modifiers - rework and extend import syntax - make implicit $self available in default arguments - call type reifiers from correct package and remove 2nd arg workaround - remove :(...) prototype syntax - remove undocumented 'attrs' option - drop internal Moo dependency 1.0706 2017-03-17 - don't require . in @INC during install - improve internal code generation functions used on perls before 5.22 1.0705 2016-06-11 - simplify internals 1.0704 2016-02-13 - guard against broken Mooses in Makefile.PL - remove last internal use of glob() 1.0703 2016-01-05 - fix line numbers in runtime errors caused by calls with bad arguments (Carp trying to be smart and skipping over "internal" callers) 1.0702 2015-12-21 - fix parsing of _ in prototypes (caused bogus "Illegal character after '_' in prototype" warnings) 1.0701 2015-12-04 - remove old "bare" import syntax: use Function::Parameters 'foo', 'bar'; # equivalent to # use Function::Parameters { foo => 'function', bar => 'method' }; (marked as deprecated in 0.06, no longer documented since 1.00) 1.0605 2015-04-26 - update metacpan links - remove wonky test 1.0604 2015-04-22 - new explicit "lax" mode - fix info() with taint mode on (gh pr #12) - don't hide syntax errors that are followed by a parameter list with types (gh #15) - compatibility with perl v5.21.11 (#103843) 1.0603 2014-11-25 - some documentation changes - compatibility with perl development versions 1.0602 2014-10-21 - fix warnings under perl5.21 (causes harmless test failure) 1.0601 2014-10-20 - allow nameless parameters for arguments that should be ignored - fix string comparison bug (":lvaluefoobar" treated as ":lvalue", etc) - explicitly disallow $_/@_/%_ as parameters - change "Not enough" to "Too few" in error message to match perl - don't parse $#foo as a sigil plus comment - remove implicitly optional parameters ("fun foo($x = 42, $y)" used to be equivalent to "fun foo($x = 42, $y = undef)") 1.0503 2014-10-17 - skip initializing parameters if the default argument is undef (don't generate '$x = undef if @_ < 1' for 'fun ($x = undef)') 1.0502 2014-10-16 - fix bug that prevents building with threaded perls 1.0501 2014-10-13 - support :prototype(...) for setting the prototype - allow fun foo($x =, $y =) (empty default arg equivalent to specifying undef) 1.0404 2014-10-13 - fix segfault on 'fun foo(A[[' (malformed type) 1.0403 2014-10-12 - general overhaul for 5.18 and 5.20 support - be more flexible about strict 'vars' error message in tests (#99100) 1.0402 2014-09-01 - fix #92871: don't access dead stack frames on error - fix #95803: don't dereference NULL 1.0401 2013-10-09 - enable type checks by default 1.0301 2013-09-16 - support 'defaults' to base keywords on existing keyword types - 'check_argument_count' no longer controls type checks - new 'check_argument_types' property controls type checks - new 'strict' property does what 'check_argument_count' used to - new 'runtime' property lets you define functions at runtime - some more tests 1.0202 2013-08-28 - make t/foreign/Fun/name.t less fragile to support newer Carp - support older Moo without ->meta support 1.0201 2013-08-13 - custom (per-keyword) type reification - actually use documented defaults for custom keywords 1.0104 2013-06-16 - support unicode in custom keywords - actually validate default attributes 1.0103 2013-06-09 - properly allow non-moose-based custom type constraints (#85851) 1.0102 2013-03-08 - prepare for internals changes in the upcoming 5.18 release (https://rt.cpan.org/Ticket/Display.html?id=83439) - only allocate memory after recognizing a keyword like 'fun' (might speed up parsing a little) 1.0101 2013-02-05 - new reflection API to inspect parameter information of functions - Moose types in parameter lists - more tests 1.0004 2012-11-26 - fix test relying on hash ordering 1.0003 2012-11-19 - clean up internals - fix build errors on some platforms - fix module metadata - some more tests 1.00 2012-11-01 - add named parameters with ':$foo, :$bar' syntax - rewrite documentation - more tests (some of them copied from similar modules on CPAN) 0.10 2012-10-21 - add ':strict' import target - support $invocant: parameter syntax 0.09 2012-10-14 - fix wrong line number for statement immediately following a function 0.08 2012-07-19 - support UTF-8 in function/parameter names - better detection of invalid prototypes 0.07 2012-06-25 - completely rework internals to generate optrees directly (no more generating/reparsing source) - simplify / fewer dependencies - new feature: default arguments (on by default) - new feature: strict argument count checks (off by default) enabled by "*_strict" variants of symbolic types 0.06 2012-06-19 - complete rewrite in XS - require perl 5.14+ - hopefully fix bug where it would get the line numbers wrong - we're a lexical pragma now; remove import_into() - more fine-grained control over behavior of generated keywords: * function name can be optional/required/prohibited * invocant name can be any variable, not just $self * default attributes (and method now defaults to ':method') 0.05 2011-08-02 - complete rewrite - hopefully fix bug where it would swallow compilation errors or get the line numbers wrong - method keyword! - more flexible keyword customization 0.04 2010-03-03 - allow renaming the function keyword - provide import_into so you can mess with other packages 0.03 2009-12-14 First version, released on an unsuspecting world. Function-Parameters-2.002004/MANIFEST.SKIP0000644000175000017500000000031614410660361016514 0ustar maukemauke(?' build_requires: FindBin: '0' Hash::Util: '0.07' Test::Fatal: '0' Test::More: '0' constant: '0' strict: '0' utf8: '0' configure_requires: ExtUtils::MakeMaker: '7.0' File::Find: '0' File::Spec: '0' strict: '0' warnings: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Function-Parameters no_index: directory: - t - inc - xt requires: Carp: '0' Scalar::Util: '0' XSLoader: '0' perl: '5.014000' warnings: '0' resources: repository: git://github.com/mauke/Function-Parameters version: '2.002004' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Function-Parameters-2.002004/MANIFEST0000644000175000017500000000341514454414615015761 0ustar maukemaukeChanges hax/block_end.c.inc hax/block_start.c.inc hax/COP_SEQ_RANGE_HIGH_set.c.inc hax/COP_SEQ_RANGE_LOW_set.c.inc hax/intro_my.c.inc hax/newDEFSVOP.c.inc hax/op_convert_list.c.inc hax/pad_add_name_pvs.c.inc hax/pad_add_name_sv.c.inc hax/pad_alloc.c.inc hax/pad_block_start.c.inc hax/pad_findmy_pvs.c.inc hax/pad_leavemy.c.inc hax/scalarseq.c.inc hax/STATIC_ASSERT_STMT.c.inc lib/Function/Parameters.pm lib/Function/Parameters/Info.pm Makefile.PL Makefile_PL_settings.plx MANIFEST MANIFEST.SKIP Parameters.xs t/01-compiles.t t/02-compiles.t t/03-compiles.t t/attributes.t t/bonus.t t/checkered.t t/checkered_2.t t/checkered_3.t t/checkered_4.t t/croak.t t/defaults.t t/defaults_bare.t t/defaults_regress.t t/eating_strict_error.fail t/eating_strict_error.t t/eating_strict_error_2.fail t/elsewhere.t t/eval.t t/gorn.t t/hueg.t t/imports.t t/info.t t/install.t t/invocant.t t/lexical.t t/lifetime.t t/lineno-torture.t t/lineno.t t/method_cache.t t/method_runtime.t t/name.t t/name_1.fail t/name_2.fail t/name_3.fail t/name_4.fail t/named_params.t t/precedence.t t/prototype.t t/recursion.t t/regress.t t/rename.t t/strict.t t/strict_1.fail t/strict_2.fail t/strict_3.fail t/strict_4.fail t/strict_5.fail t/stringy_h.t t/threads.t t/threads2.t t/types_auto.t t/types_caller.t t/types_coerce.t t/types_custom.t t/types_custom_2.t t/types_custom_3.t t/types_custom_4.t t/types_inline.t t/types_moose.t t/types_moose_2.t t/types_moose_3.t t/types_moosex.t t/types_moosex_2.t t/types_msg.t t/types_parse.t t/unicode.t t/unicode2.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README generated from Function::Parameters POD (added by maint/eumm-fixup.pl) Function-Parameters-2.002004/hax/0000755000175000017500000000000014454414615015405 5ustar maukemaukeFunction-Parameters-2.002004/hax/STATIC_ASSERT_STMT.c.inc0000644000175000017500000000224613235057757021252 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef STATIC_ASSERT_STMT #if (defined(static_assert) || (defined(__cplusplus) && __cplusplus >= 201103L)) && (!defined(__IBMC__) || __IBMC__ >= 1210) /* static_assert is a macro defined in in C11 or a compiler builtin in C++11. But IBM XL C V11 does not support _Static_assert, no matter what says. */ # define STATIC_ASSERT_DECL(COND) static_assert(COND, #COND) #else /* We use a bit-field instead of an array because gcc accepts 'typedef char x[n]' where n is not a compile-time constant. We want to enforce constantness. */ # define STATIC_ASSERT_2(COND, SUFFIX) \ typedef struct { \ unsigned int _static_assertion_failed_##SUFFIX : (COND) ? 1 : -1; \ } _static_assertion_failed_##SUFFIX PERL_UNUSED_DECL # define STATIC_ASSERT_1(COND, SUFFIX) STATIC_ASSERT_2(COND, SUFFIX) # define STATIC_ASSERT_DECL(COND) STATIC_ASSERT_1(COND, __LINE__) #endif /* We need this wrapper even in C11 because 'case X: static_assert(...);' is an error (static_assert is a declaration, and only statements can have labels). */ #define STATIC_ASSERT_STMT(COND) do { STATIC_ASSERT_DECL(COND); } while (0) #endif Function-Parameters-2.002004/hax/pad_findmy_pvs.c.inc0000644000175000017500000000035113235057757021330 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef pad_findmy_pvs #if HAVE_PERL_VERSION(5, 16, 0) #error "This situation surprises me considerably." #endif #define pad_findmy_pvs(NAME, FLAGS) pad_findmy("" NAME "", sizeof NAME - 1, FLAGS) #endif Function-Parameters-2.002004/hax/COP_SEQ_RANGE_HIGH_set.c.inc0000644000175000017500000000030013235057757022037 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef COP_SEQ_RANGE_HIGH_set #define COP_SEQ_RANGE_HIGH_set(SV, VAL) \ STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END #endif Function-Parameters-2.002004/hax/COP_SEQ_RANGE_LOW_set.c.inc0000644000175000017500000000027513235057757021774 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef COP_SEQ_RANGE_LOW_set #define COP_SEQ_RANGE_LOW_set(SV, VAL) \ STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END #endif Function-Parameters-2.002004/hax/pad_add_name_pvs.c.inc0000644000175000017500000000031213235057757021567 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef pad_add_name_pvs #define pad_add_name_pvs(NAME, FLAGS, TYPESTASH, OURSTASH) S_pad_add_name_pvn(aTHX_ "" NAME "", sizeof NAME - 1, FLAGS, TYPESTASH, OURSTASH) #endif Function-Parameters-2.002004/hax/pad_leavemy.c.inc0000644000175000017500000000411013235057757020611 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef pad_leavemy #define pad_leavemy() S_pad_leavemy(aTHX) static OP *S_pad_leavemy(pTHX) { dVAR; I32 off; OP *o = NULL; SV * const * const svp = AvARRAY(PL_comppad_name); PL_pad_reset_pending = FALSE; ASSERT_CURPAD_ACTIVE("pad_leavemy"); if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) { for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { const SV * const sv = svp[off]; if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv)) Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "%"SVf" never introduced", SVfARG(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) { SV * const sv = svp[off]; if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv) && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO) { COP_SEQ_RANGE_HIGH_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad leavemy: %ld \"%s\", (%lu,%lu)\n", (long)off, SvPVX_const(sv), (unsigned long)COP_SEQ_RANGE_LOW(sv), (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); #if HAVE_PERL_VERSION(5, 17, 4) if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv) && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) { OP *kid = newOP(OP_INTROCV, 0); kid->op_targ = off; o = op_prepend_elem(OP_LINESEQ, kid, o); } #endif } } PL_cop_seqmax++; if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ PL_cop_seqmax++; DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax)); return o; } #endif Function-Parameters-2.002004/hax/block_end.c.inc0000644000175000017500000000216413235057757020252 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef block_end #include "scalarseq.c.inc" #include "pad_leavemy.c.inc" #define block_end(A, B) S_block_end(aTHX_ A, B) static OP *S_block_end(pTHX_ I32 floor, OP *seq) { dVAR; const int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP *retval = scalarseq(seq); OP *o; CALL_BLOCK_HOOKS(bhk_pre_end, &retval); LEAVE_SCOPE(floor); #if !HAVE_PERL_VERSION(5, 19, 3) CopHINTS_set(&PL_compiling, PL_hints); #endif if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ o = pad_leavemy(); if (o) { #if HAVE_PERL_VERSION(5, 17, 4) OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o; OP *const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o; for (;; kid = kid->op_sibling) { OP *newkid = newOP(OP_CLONECV, 0); newkid->op_targ = kid->op_targ; o = op_append_elem(OP_LINESEQ, o, newkid); if (kid == last) break; } retval = op_prepend_elem(OP_LINESEQ, o, retval); #endif } CALL_BLOCK_HOOKS(bhk_post_end, &retval); return retval; } #endif Function-Parameters-2.002004/hax/scalarseq.c.inc0000644000175000017500000000136713235057757020314 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef scalarseq #define scalarseq(A) S_scalarseq(aTHX_ A) static OP *S_scalarseq(pTHX_ OP *o) { dVAR; if (o) { const OPCODE type = o->op_type; if (type == OP_LINESEQ || type == OP_SCOPE || type == OP_LEAVE || type == OP_LEAVETRY) { OP *kid; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { op_contextualize(kid, G_VOID); } } PL_curcop = &PL_compiling; } o->op_flags &= ~OPf_PARENS; if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS; } else o = newOP(OP_STUB, 0); return o; } #endif Function-Parameters-2.002004/hax/newDEFSVOP.c.inc0000644000175000017500000000071613235057757020153 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef newDEFSVOP #include "pad_findmy_pvs.c.inc" #define newDEFSVOP() S_newDEFSVOP(aTHX) static OP *S_newDEFSVOP(pTHX) { dVAR; const PADOFFSET offset = pad_findmy_pvs("$_", 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } else { OP * const o = newOP(OP_PADSV, 0); o->op_targ = offset; return o; } } #endif Function-Parameters-2.002004/hax/op_convert_list.c.inc0000644000175000017500000000276013235057757021545 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef op_convert_list #define CHECKOP(type,o) \ ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ (OP*)0 ) \ : PL_check[type](aTHX_ (OP*)o)) static OP *S_op_std_init(pTHX_ OP *o) { I32 type = o->op_type; if (PL_opargs[type] & OA_RETSCALAR) op_contextualize(o, G_SCALAR); if (PL_opargs[type] & OA_TARGET && !o->op_targ) o->op_targ = pad_alloc(type, SVs_PADTMP); return o; } #define op_convert_list(A, B, C) S_op_convert_list(aTHX_ A, B, C) static OP *S_op_convert_list(pTHX_ I32 type, I32 flags, OP *o) { dVAR; assert(type >= 0); if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, NULL); else o->op_flags &= ~OPf_WANT; if (!(PL_opargs[type] & OA_MARK)) op_null(cLISTOPo->op_first); else { #if HAVE_PERL_VERSION(5, 15, 3) OP * const kid2 = cLISTOPo->op_first->op_sibling; if (kid2 && kid2->op_type == OP_COREARGS) { op_null(cLISTOPo->op_first); kid2->op_private |= OPpCOREARGS_PUSHMARK; } #endif } o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; o->op_flags |= flags; o = CHECKOP(type, o); if (o->op_type != type) { return o; } return S_op_std_init(aTHX_ o); } #endif Function-Parameters-2.002004/hax/intro_my.c.inc0000644000175000017500000000301013235057757020161 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef intro_my #include "COP_SEQ_RANGE_HIGH_set.c.inc" #include "COP_SEQ_RANGE_LOW_set.c.inc" #define intro_my() S_intro_my(aTHX) static U32 S_intro_my(pTHX) { dVAR; SV **svp; I32 i; U32 seq; ASSERT_CURPAD_ACTIVE("intro_my"); if (! PL_min_intro_pending) return PL_cop_seqmax; svp = AvARRAY(PL_comppad_name); for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { SV *const sv = svp[i]; if (sv && IF_HAVE_PERL_5_19_3(PadnameLEN(sv), sv != &PL_sv_undef) && !SvFAKE(sv) && COP_SEQ_RANGE_LOW(sv) == PERL_PADSEQ_INTRO) { COP_SEQ_RANGE_HIGH_set(sv, PERL_PADSEQ_INTRO); /* Don't know scope end yet. */ COP_SEQ_RANGE_LOW_set(sv, PL_cop_seqmax); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad intromy: %ld \"%s\", (%lu,%lu)\n", (long)i, SvPVX_const(sv), (unsigned long)COP_SEQ_RANGE_LOW(sv), (unsigned long)COP_SEQ_RANGE_HIGH(sv)) ); } } seq = PL_cop_seqmax; PL_cop_seqmax++; if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ PL_cop_seqmax++; PL_min_intro_pending = 0; PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */ DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad intromy: seq -> %ld\n", (long)(PL_cop_seqmax))); return seq; } #endif Function-Parameters-2.002004/hax/pad_alloc.c.inc0000644000175000017500000000345513235057757020254 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef pad_alloc #define pad_alloc(OPTYPE, TMPTYPE) S_pad_alloc(aTHX_ OPTYPE, TMPTYPE) static PADOFFSET S_pad_alloc(pTHX_ I32 optype, U32 tmptype) { dVAR; SV *sv; I32 retval; PERL_UNUSED_ARG(optype); ASSERT_CURPAD_ACTIVE("pad_alloc"); if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_alloc"); PL_pad_reset_pending = FALSE; if (tmptype & SVs_PADMY) { sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); retval = AvFILLp(PL_comppad); } else { SV * const * const names = AvARRAY(PL_comppad_name); const SSize_t names_fill = AvFILLp(PL_comppad_name); for (;;) { /* * "foreach" index vars temporarily become aliases to non-"my" * values. Thus we must skip, not just pad values that are * marked as current pad values, but also those with names. */ /* HVDS why copy to sv here? we don't seem to use it */ if (++PL_padix <= names_fill && (sv = names[PL_padix]) && sv != &PL_sv_undef) continue; sv = *av_fetch(PL_comppad, PL_padix, TRUE); if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) && !IS_PADGV(sv) && !IS_PADCONST(sv)) break; } retval = PL_padix; } SvFLAGS(sv) |= tmptype; PL_curpad = AvARRAY(PL_comppad); DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf"[0x%"UVxf"] alloc: %ld for %s\n", PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long) retval, PL_op_name[optype])); #ifdef DEBUG_LEAKING_SCALARS sv->sv_debug_optype = optype; sv->sv_debug_inpad = 1; #endif return (PADOFFSET)retval; } #endif Function-Parameters-2.002004/hax/pad_add_name_sv.c.inc0000644000175000017500000000464213235057757021421 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef pad_add_name_sv #include "pad_alloc.c.inc" #include "COP_SEQ_RANGE_LOW_set.c.inc" #include "COP_SEQ_RANGE_HIGH_set.c.inc" #define pad_add_name_sv(NAMESV, FLAGS, TYPESTASH, OURSTASH) S_pad_add_name_sv(aTHX_ NAMESV, FLAGS, TYPESTASH, OURSTASH) static PADOFFSET S_pad_alloc_name(pTHX_ SV *namesv, U32 flags, HV *typestash, HV *ourstash) { dVAR; const PADOFFSET offset = pad_alloc(OP_PADSV, SVs_PADMY); (void)flags; assert(flags == 0); ASSERT_CURPAD_ACTIVE("pad_alloc_name"); if (typestash) { assert(SvTYPE(namesv) == SVt_PVMG); SvPAD_TYPED_on(namesv); SvSTASH_set(namesv, MUTABLE_HV(SvREFCNT_inc_simple_NN(MUTABLE_SV(typestash)))); } if (ourstash) { SvPAD_OUR_on(namesv); SvOURSTASH_set(namesv, ourstash); SvREFCNT_inc_simple_void_NN(ourstash); } av_store(PL_comppad_name, offset, namesv); return offset; } static PADOFFSET S_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags, HV *typestash, HV *ourstash) { dVAR; PADOFFSET offset; SV *namesv; assert(flags == 0); namesv = newSV_type((ourstash || typestash) ? SVt_PVMG : SVt_PVNV); sv_setpvn(namesv, namepv, namelen); offset = S_pad_alloc_name(aTHX_ namesv, flags, typestash, ourstash); /* not yet introduced */ COP_SEQ_RANGE_LOW_set(namesv, PERL_PADSEQ_INTRO); COP_SEQ_RANGE_HIGH_set(namesv, 0); if (!PL_min_intro_pending) PL_min_intro_pending = offset; PL_max_intro_pending = offset; /* if it's not a simple scalar, replace with an AV or HV */ assert(SvTYPE(PL_curpad[offset]) == SVt_NULL); assert(SvREFCNT(PL_curpad[offset]) == 1); if (namelen != 0 && *namepv == '@') sv_upgrade(PL_curpad[offset], SVt_PVAV); else if (namelen != 0 && *namepv == '%') sv_upgrade(PL_curpad[offset], SVt_PVHV); assert(SvPADMY(PL_curpad[offset])); DEBUG_Xv(PerlIO_printf(Perl_debug_log, "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n", (long)offset, SvPVX(namesv), PTR2UV(PL_curpad[offset]))); return offset; } static PADOFFSET S_pad_add_name_sv(pTHX_ SV *name, U32 flags, HV *typestash, HV *ourstash) { char *namepv; STRLEN namelen; assert(flags == 0); namepv = SvPV(name, namelen); return S_pad_add_name_pvn(aTHX_ namepv, namelen, flags, typestash, ourstash); } #endif Function-Parameters-2.002004/hax/block_start.c.inc0000644000175000017500000000073113235057757020637 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef block_start #include "pad_block_start.c.inc" #define block_start(A) S_block_start(aTHX_ A) static int S_block_start(pTHX_ int full) { dVAR; const int retval = PL_savestack_ix; pad_block_start(full); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings); CALL_BLOCK_HOOKS(bhk_start, full); return retval; } #endif Function-Parameters-2.002004/hax/pad_block_start.c.inc0000644000175000017500000000124513235057757021464 0ustar maukemauke/* vi: set ft=c inde=: */ #ifndef pad_block_start #define pad_block_start(A) S_pad_block_start(aTHX_ A) static void S_pad_block_start(pTHX_ int full) { dVAR; ASSERT_CURPAD_ACTIVE("pad_block_start"); SAVEI32(PL_comppad_name_floor); PL_comppad_name_floor = AvFILLp(PL_comppad_name); if (full) PL_comppad_name_fill = PL_comppad_name_floor; if (PL_comppad_name_floor < 0) PL_comppad_name_floor = 0; SAVEI32(PL_min_intro_pending); SAVEI32(PL_max_intro_pending); PL_min_intro_pending = 0; SAVEI32(PL_comppad_name_fill); SAVEI32(PL_padix_floor); PL_padix_floor = PL_padix; PL_pad_reset_pending = FALSE; } #endif Function-Parameters-2.002004/Parameters.xs0000644000175000017500000025171714417752314017321 0ustar maukemauke/* Copyright 2012, 2014, 2023 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. */ #ifdef __GNUC__ #if __GNUC__ >= 5 #define IF_HAVE_GCC_5(X) X #endif #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5 #define PRAGMA_GCC_(X) _Pragma(#X) #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X) #endif #endif #ifndef IF_HAVE_GCC_5 #define IF_HAVE_GCC_5(X) #endif #ifndef PRAGMA_GCC #define PRAGMA_GCC(X) #endif #ifdef DEVEL #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop) #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic error #X) #define WARNINGS_ENABLE \ WARNINGS_ENABLEW(-Wall) \ WARNINGS_ENABLEW(-Wextra) \ WARNINGS_ENABLEW(-Wundef) \ WARNINGS_ENABLEW(-Wshadow) \ WARNINGS_ENABLEW(-Wbad-function-cast) \ WARNINGS_ENABLEW(-Wcast-align) \ WARNINGS_ENABLEW(-Wwrite-strings) \ WARNINGS_ENABLEW(-Wstrict-prototypes) \ WARNINGS_ENABLEW(-Wmissing-prototypes) \ WARNINGS_ENABLEW(-Winline) \ WARNINGS_ENABLEW(-Wdisabled-optimization) \ IF_HAVE_GCC_5(WARNINGS_ENABLEW(-Wnested-externs)) #else #define WARNINGS_RESET #define WARNINGS_ENABLE #endif #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #ifdef DEVEL #undef NDEBUG #include #endif #ifdef PERL_MAD #error "MADness is not supported." #endif #define HAVE_PERL_VERSION(R, V, S) \ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #if HAVE_PERL_VERSION(5, 19, 3) #define IF_HAVE_PERL_5_19_3(YES, NO) YES #else #define IF_HAVE_PERL_5_19_3(YES, NO) NO #endif #ifndef SvREFCNT_dec_NN #define SvREFCNT_dec_NN(SV) SvREFCNT_dec(SV) #endif #define MY_PKG "Function::Parameters" /* 5.22+ shouldn't require any hax */ #if !HAVE_PERL_VERSION(5, 22, 0) #if !HAVE_PERL_VERSION(5, 16, 0) #include "hax/pad_alloc.c.inc" #include "hax/pad_add_name_sv.c.inc" #include "hax/pad_add_name_pvs.c.inc" #ifndef padadd_NO_DUP_CHECK #define padadd_NO_DUP_CHECK 0 #endif #endif #include "hax/newDEFSVOP.c.inc" #include "hax/intro_my.c.inc" #include "hax/block_start.c.inc" #include "hax/block_end.c.inc" #include "hax/op_convert_list.c.inc" /* < 5.22 */ #include "hax/STATIC_ASSERT_STMT.c.inc" #endif WARNINGS_ENABLE #ifdef newSVpvf #undef newSVpvf #endif #define newSVpvf @"perlapi says Perl_newSVpvf must be called explicitly (with aTHX_)" #ifdef warner #undef warner #endif #define warner @"perlapi says Perl_warner must be called explicitly (with aTHX_)" #ifdef croak #undef croak #endif #define croak @"perlapi says Perl_croak must be called explicitly (with aTHX_)" #define HAVE_BUG_GH_15557 (HAVE_PERL_VERSION(5, 21, 7) && !HAVE_PERL_VERSION(5, 25, 5)) #define HINTK_CONFIG MY_PKG "/config" #define HINTSK_FLAGS "flags" #define HINTSK_SHIFT "shift" #define HINTSK_SHIF2 "shift_types" #define HINTSK_ATTRS "attrs" #define HINTSK_REIFY "reify" #define HINTSK_INSTL "instl" #define DEFSTRUCT(T) typedef struct T T; struct T #define VEC(B) B ## _Vec #define DEFVECTOR(B) DEFSTRUCT(VEC(B)) { \ B (*data); \ size_t used, size; \ } #define DEFVECTOR_INIT(N, B) static void N(VEC(B) *p) { \ p->used = 0; \ p->size = 23; \ Newx(p->data, p->size, B); \ } static void N(VEC(B) *) #define DEFVECTOR_EXTEND(N, B) static B (*N(VEC(B) *p)) { \ assert(p->used <= p->size); \ if (p->used == p->size) { \ const size_t n = p->size / 2 * 3 + 1; \ Renew(p->data, n, B); \ p->size = n; \ } \ return &p->data[p->used]; \ } static B (*N(VEC(B) *)) #define DEFVECTOR_CLEAR_GENERIC(N, N_PARAM_, B, F, F_ARG_) static void N(N_PARAM_ VEC(B) *p) { \ while (p->used) { \ p->used--; \ F(F_ARG_ &p->data[p->used]); \ } \ Safefree(p->data); \ p->data = NULL; \ p->size = 0; \ } static void N(N_PARAM_ VEC(B) *) #define DEFVECTOR_CLEAR(N, B, F) DEFVECTOR_CLEAR_GENERIC(N, , B, F, ) #define DEFVECTOR_CLEAR_THX(N, B, F) DEFVECTOR_CLEAR_GENERIC(N, pTHX_, B, F, aTHX_) enum { FLAG_NAME_OK = 0x001, FLAG_ANON_OK = 0x002, FLAG_DEFAULT_ARGS = 0x004, FLAG_CHECK_NARGS = 0x008, FLAG_INVOCANT = 0x010, FLAG_NAMED_PARAMS = 0x020, FLAG_TYPES_OK = 0x040, FLAG_CHECK_TARGS = 0x080, FLAG_RUNTIME = 0x100 }; DEFSTRUCT(SpecParam) { SV *name; SV *type; }; DEFVECTOR(SpecParam); DEFVECTOR_INIT(spv_init, SpecParam); static void sp_clear(SpecParam *p) { p->name = NULL; p->type = NULL; } DEFVECTOR_CLEAR(spv_clear, SpecParam, sp_clear); DEFVECTOR_EXTEND(spv_extend, SpecParam); static void spv_push(VEC(SpecParam) *ps, SV *name, SV *type) { SpecParam *p = spv_extend(ps); p->name = name; p->type = type; ps->used++; } DEFSTRUCT(KWSpec) { unsigned flags; SV *reify_type; VEC(SpecParam) shift; SV *attrs; SV *install_sub; }; static void kws_free_void(pTHX_ void *p) { KWSpec *const spec = p; PERL_UNUSED_CONTEXT; spv_clear(&spec->shift); spec->attrs = NULL; spec->install_sub = NULL; Safefree(spec); } DEFSTRUCT(Resource) { Resource *next; void *data; void (*destroy)(pTHX_ void *); }; typedef Resource *Sentinel[1]; static void sentinel_clear_void(pTHX_ void *pv) { Resource **pp = pv; Resource *p = *pp; Safefree(pp); while (p) { Resource *cur = p; if (cur->destroy) { cur->destroy(aTHX_ cur->data); } cur->data = (void *)"no"; cur->destroy = NULL; p = cur->next; Safefree(cur); } } static Resource *sentinel_register(Sentinel sen, void *data, void (*destroy)(pTHX_ void *)) { Resource *cur; Newx(cur, 1, Resource); cur->data = data; cur->destroy = destroy; cur->next = *sen; *sen = cur; return cur; } static void sentinel_disarm(Resource *p) { p->destroy = NULL; } static void my_sv_refcnt_dec_void(pTHX_ void *p) { SV *sv = p; SvREFCNT_dec(sv); } static SV *sentinel_mortalize(Sentinel sen, SV *sv) { sentinel_register(sen, sv, my_sv_refcnt_dec_void); return sv; } #if HAVE_PERL_VERSION(5, 17, 2) #define MY_OP_SLABBED(O) ((O)->op_slabbed) #else #define MY_OP_SLABBED(O) 0 #endif DEFSTRUCT(OpGuard) { OP *op; bool needs_freed; }; static void op_guard_init(OpGuard *p) { p->op = NULL; p->needs_freed = FALSE; } static OpGuard op_guard_transfer(OpGuard *p) { OpGuard r = *p; op_guard_init(p); return r; } static OP *op_guard_relinquish(OpGuard *p) { OP *o = p->op; op_guard_init(p); return o; } static void op_guard_update(OpGuard *p, OP *o) { p->op = o; p->needs_freed = o && !MY_OP_SLABBED(o); } static void op_guard_clear(pTHX_ OpGuard *p) { if (p->needs_freed) { op_free(p->op); } } static void free_op_guard_void(pTHX_ void *vp) { OpGuard *p = vp; op_guard_clear(aTHX_ p); Safefree(p); } static void free_op_void(pTHX_ void *vp) { OP *p = vp; op_free(p); } #define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof S - 1) static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) { STRLEN sv_len; const char *sv_p = SvPV(sv, sv_len); return sv_len == n && memcmp(sv_p, p, n) == 0; } #ifndef newMETHOP #define newMETHOP newUNOP #endif enum { MY_ATTR_LVALUE = 0x01, MY_ATTR_METHOD = 0x02, MY_ATTR_SPECIAL = 0x04 }; static void my_sv_cat_c(pTHX_ SV *sv, U32 c) { char ds[UTF8_MAXBYTES + 1], *d; d = (char *)uvchr_to_utf8((U8 *)ds, c); if (d - ds > 1) { sv_utf8_upgrade(sv); } sv_catpvn(sv, ds, d - ds); } #define MY_UNI_IDFIRST(C) isIDFIRST_uni(C) #define MY_UNI_IDCONT(C) isALNUM_uni(C) #if HAVE_PERL_VERSION(5, 25, 9) #define MY_UNI_IDFIRST_utf8(P, Z) isIDFIRST_utf8_safe((const unsigned char *)(P), (const unsigned char *)(Z)) #define MY_UNI_IDCONT_utf8(P, Z) isWORDCHAR_utf8_safe((const unsigned char *)(P), (const unsigned char *)(Z)) #else #define MY_UNI_IDFIRST_utf8(P, Z) isIDFIRST_utf8((const unsigned char *)(P)) #define MY_UNI_IDCONT_utf8(P, Z) isALNUM_utf8((const unsigned char *)(P)) #endif static SV *my_scan_word(pTHX_ Sentinel sen, bool allow_package) { bool at_start, at_substart; I32 c; SV *sv = sentinel_mortalize(sen, newSVpvs("")); if (lex_bufutf8()) { SvUTF8_on(sv); } at_start = at_substart = TRUE; c = lex_peek_unichar(0); while (c != -1) { if (at_substart ? MY_UNI_IDFIRST(c) : MY_UNI_IDCONT(c)) { lex_read_unichar(0); my_sv_cat_c(aTHX_ sv, c); at_substart = FALSE; c = lex_peek_unichar(0); } else if (allow_package && !at_substart && c == '\'') { lex_read_unichar(0); c = lex_peek_unichar(0); if (!MY_UNI_IDFIRST(c)) { lex_stuff_pvs("'", 0); break; } sv_catpvs(sv, "'"); at_substart = TRUE; } else if (allow_package && (at_start || !at_substart) && c == ':') { lex_read_unichar(0); if (lex_peek_unichar(0) != ':') { lex_stuff_pvs(":", 0); break; } lex_read_unichar(0); c = lex_peek_unichar(0); if (!MY_UNI_IDFIRST(c)) { lex_stuff_pvs("::", 0); break; } sv_catpvs(sv, "::"); at_substart = TRUE; } else { break; } at_start = FALSE; } return SvCUR(sv) ? sv : NULL; } static SV *my_scan_parens_tail(pTHX_ Sentinel sen, bool keep_backslash) { I32 c, nesting; SV *sv; line_t start; start = CopLINE(PL_curcop); sv = sentinel_mortalize(sen, newSVpvs("")); if (lex_bufutf8()) { SvUTF8_on(sv); } nesting = 0; for (;;) { c = lex_read_unichar(0); if (c == EOF) { CopLINE_set(PL_curcop, start); return NULL; } if (c == '\\') { c = lex_read_unichar(0); if (c == EOF) { CopLINE_set(PL_curcop, start); return NULL; } if (keep_backslash || (c != '(' && c != ')')) { sv_catpvs(sv, "\\"); } } else if (c == '(') { nesting++; } else if (c == ')') { if (!nesting) { break; } nesting--; } my_sv_cat_c(aTHX_ sv, c); } return sv; } static void my_check_prototype(pTHX_ Sentinel sen, const SV *declarator, SV *proto) { char *start, *r, *w, *end; STRLEN len; /* strip spaces */ start = SvPVbyte_force(proto, len); end = start + len; for (w = r = start; r < end; r++) { if (!isSPACE(*r)) { *w++ = *r; } } *w = '\0'; SvCUR_set(proto, w - start); end = w; len = end - start; if (!ckWARN(WARN_ILLEGALPROTO)) { return; } /* check for bad characters */ if (strspn(start, "$@%*;[]&\\_+") != len) { SV *dsv = sentinel_mortalize(sen, newSVpvs("")); Perl_warner( aTHX_ packWARN(WARN_ILLEGALPROTO), "Illegal character in prototype for %"SVf" : %s", SVfARG(declarator), SvUTF8(proto) ? sv_uni_display( dsv, proto, len, UNI_DISPLAY_ISPRINT ) : pv_pretty(dsv, start, len, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII ) ); return; } for (r = start; r < end; r++) { switch (*r) { default: Perl_warner( aTHX_ packWARN(WARN_ILLEGALPROTO), "Illegal character in prototype for %"SVf" : %s", SVfARG(declarator), r ); return; case '_': if (r[1] && !strchr(";@%", r[1])) { Perl_warner( aTHX_ packWARN(WARN_ILLEGALPROTO), "Illegal character after '_' in prototype for %"SVf" : %s", SVfARG(declarator), r + 1 ); return; } break; case '@': case '%': if (r[1]) { Perl_warner( aTHX_ packWARN(WARN_ILLEGALPROTO), "prototype after '%c' for %"SVf": %s", *r, SVfARG(declarator), r + 1 ); return; } break; case '\\': r++; if (strchr("$@%&*", *r)) { break; } if (*r == '[') { r++; for (; r < end && *r != ']'; r++) { if (!strchr("$@%&*", *r)) { break; } } if (*r == ']' && r[-1] != '[') { break; } } Perl_warner( aTHX_ packWARN(WARN_ILLEGALPROTO), "Illegal character after '\\' in prototype for %"SVf" : %s", SVfARG(declarator), r ); return; case '$': case '*': case '&': case ';': case '+': break; } } } static SV *parse_type(pTHX_ Sentinel, const SV *, char); static SV *parse_type_paramd(pTHX_ Sentinel sen, const SV *declarator, char prev) { I32 c; SV *t; if (!(t = my_scan_word(aTHX_ sen, TRUE))) { Perl_croak(aTHX_ "In %"SVf": missing type name after '%c'", SVfARG(declarator), prev); } lex_read_space(0); c = lex_peek_unichar(0); if (c == '[') { do { SV *u; lex_read_unichar(0); lex_read_space(0); my_sv_cat_c(aTHX_ t, c); u = parse_type(aTHX_ sen, declarator, c); sv_catsv(t, u); c = lex_peek_unichar(0); } while (c == ','); if (c != ']') { Perl_croak(aTHX_ "In %"SVf": missing ']' after '%"SVf"'", SVfARG(declarator), SVfARG(t)); } lex_read_unichar(0); lex_read_space(0); my_sv_cat_c(aTHX_ t, c); } return t; } static SV *parse_type_term(pTHX_ Sentinel sen, const SV *declarator, char prev) { I32 c; SV *t, *u; t = sentinel_mortalize(sen, newSVpvs("")); while ((c = lex_peek_unichar(0)) == '~') { lex_read_unichar(0); lex_read_space(0); my_sv_cat_c(aTHX_ t, c); prev = c; } if (c == '(') { lex_read_unichar(0); lex_read_space(0); my_sv_cat_c(aTHX_ t, c); u = parse_type(aTHX_ sen, declarator, c); sv_catsv(t, u); c = lex_peek_unichar(0); if (c != ')') { Perl_croak(aTHX_ "In %"SVf": missing ')' after '%"SVf"'", SVfARG(declarator), SVfARG(t)); } my_sv_cat_c(aTHX_ t, c); lex_read_unichar(0); lex_read_space(0); return t; } u = parse_type_paramd(aTHX_ sen, declarator, prev); sv_catsv(t, u); return t; } static SV *parse_type_alt(pTHX_ Sentinel sen, const SV *declarator, char prev) { I32 c; SV *t; t = parse_type_term(aTHX_ sen, declarator, prev); while ((c = lex_peek_unichar(0)) == '/') { SV *u; lex_read_unichar(0); lex_read_space(0); my_sv_cat_c(aTHX_ t, c); u = parse_type_term(aTHX_ sen, declarator, c); sv_catsv(t, u); } return t; } static SV *parse_type_intersect(pTHX_ Sentinel sen, const SV *declarator, char prev) { I32 c; SV *t; t = parse_type_alt(aTHX_ sen, declarator, prev); while ((c = lex_peek_unichar(0)) == '&') { SV *u; lex_read_unichar(0); lex_read_space(0); my_sv_cat_c(aTHX_ t, c); u = parse_type_alt(aTHX_ sen, declarator, c); sv_catsv(t, u); } return t; } static SV *parse_type(pTHX_ Sentinel sen, const SV *declarator, char prev) { I32 c; SV *t; t = parse_type_intersect(aTHX_ sen, declarator, prev); while ((c = lex_peek_unichar(0)) == '|') { SV *u; lex_read_unichar(0); lex_read_space(0); my_sv_cat_c(aTHX_ t, c); u = parse_type_intersect(aTHX_ sen, declarator, c); sv_catsv(t, u); } return t; } static SV *call_from_curstash(pTHX_ Sentinel sen, SV *sv, SV **args, size_t nargs, I32 flags) { SV *r; COP curcop_with_stash; I32 want; dSP; assert(sv != NULL); if ((flags & G_WANT) == 0) { flags |= G_SCALAR; } want = flags & G_WANT; ENTER; SAVETMPS; PUSHMARK(SP); if (!args) { flags |= G_NOARGS; } else { size_t i; EXTEND(SP, (SSize_t)nargs); for (i = 0; i < nargs; i++) { PUSHs(args[i]); } } PUTBACK; assert(PL_curcop == &PL_compiling); curcop_with_stash = PL_compiling; CopSTASH_set(&curcop_with_stash, PL_curstash); PL_curcop = &curcop_with_stash; call_sv(sv, flags); PL_curcop = &PL_compiling; if (want == G_VOID) { r = NULL; } else { assert(want == G_SCALAR); SPAGAIN; r = sentinel_mortalize(sen, SvREFCNT_inc(POPs)); PUTBACK; } FREETMPS; LEAVE; return r; } static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, const KWSpec *spec, SV *name) { SV *t; t = call_from_curstash(aTHX_ sen, spec->reify_type, &name, 1, 0); if (!sv_isobject(t)) { Perl_croak(aTHX_ "In %"SVf": invalid type '%"SVf"' (%"SVf" is not a type object)", SVfARG(declarator), SVfARG(name), SVfARG(t)); } return t; } DEFSTRUCT(Param) { SV *name; PADOFFSET padoff; SV *type; }; typedef enum { ICOND_EXISTS, ICOND_DEFINED } InitCond; DEFSTRUCT(ParamInit) { Param param; OpGuard init; InitCond cond; }; DEFVECTOR(Param); DEFVECTOR(ParamInit); DEFSTRUCT(ParamSpec) { size_t shift; VEC(Param) positional_required; VEC(ParamInit) positional_optional; VEC(Param) named_required; VEC(ParamInit) named_optional; Param slurpy; PADOFFSET rest_hash; }; DEFVECTOR_INIT(pv_init, Param); DEFVECTOR_INIT(piv_init, ParamInit); static void p_init(Param *p) { p->name = NULL; p->padoff = NOT_IN_PAD; p->type = NULL; } static void ps_init(ParamSpec *ps) { ps->shift = 0; pv_init(&ps->positional_required); piv_init(&ps->positional_optional); pv_init(&ps->named_required); piv_init(&ps->named_optional); p_init(&ps->slurpy); ps->rest_hash = NOT_IN_PAD; } DEFVECTOR_EXTEND(pv_extend, Param); DEFVECTOR_EXTEND(piv_extend, ParamInit); static void pv_push(VEC(Param) *ps, SV *name, PADOFFSET padoff, SV *type) { Param *p = pv_extend(ps); p->name = name; p->padoff = padoff; p->type = type; ps->used++; } static Param *pv_unshift(VEC(Param) *ps, size_t n) { size_t i; assert(ps->used <= ps->size); if (ps->used + n > ps->size) { const size_t n2 = ps->used + n + 10; Renew(ps->data, n2, Param); ps->size = n2; } Move(ps->data, ps->data + n, ps->used, Param); for (i = 0; i < n; i++) { p_init(&ps->data[i]); } ps->used += n; return ps->data; } static void p_clear(Param *p) { p->name = NULL; p->padoff = NOT_IN_PAD; p->type = NULL; } static void pi_clear(pTHX_ ParamInit *pi) { p_clear(&pi->param); op_guard_clear(aTHX_ &pi->init); } DEFVECTOR_CLEAR(pv_clear, Param, p_clear); DEFVECTOR_CLEAR_THX(piv_clear, ParamInit, pi_clear); static void ps_clear(pTHX_ ParamSpec *ps) { pv_clear(&ps->positional_required); piv_clear(aTHX_ &ps->positional_optional); pv_clear(&ps->named_required); piv_clear(aTHX_ &ps->named_optional); p_clear(&ps->slurpy); } static int ps_contains(pTHX_ const ParamSpec *ps, SV *sv) { size_t i, lim; for (i = 0, lim = ps->positional_required.used; i < lim; i++) { if (sv_eq(sv, ps->positional_required.data[i].name)) { return 1; } } for (i = 0, lim = ps->positional_optional.used; i < lim; i++) { if (sv_eq(sv, ps->positional_optional.data[i].param.name)) { return 1; } } for (i = 0, lim = ps->named_required.used; i < lim; i++) { if (sv_eq(sv, ps->named_required.data[i].name)) { return 1; } } for (i = 0, lim = ps->named_optional.used; i < lim; i++) { if (sv_eq(sv, ps->named_optional.data[i].param.name)) { return 1; } } return 0; } static void ps_free_void(pTHX_ void *p) { ps_clear(aTHX_ p); Safefree(p); } static int args_min(const ParamSpec *ps) { return ps->positional_required.used + ps->named_required.used * 2; } static int args_max(const ParamSpec *ps) { if (ps->named_required.used || ps->named_optional.used || ps->slurpy.name) { return -1; } return ps->positional_required.used + ps->positional_optional.used; } static size_t count_positional_params(const ParamSpec *ps) { return ps->positional_required.used + ps->positional_optional.used; } static size_t count_named_params(const ParamSpec *ps) { return ps->named_required.used + ps->named_optional.used; } static SV *my_eval(pTHX_ Sentinel sen, I32 floor_ix, OP *op) { CV *cv; cv = newATTRSUB(floor_ix, NULL, NULL, NULL, op); return call_from_curstash(aTHX_ sen, (SV *)cv, NULL, 0, 0); } static OP *my_var_g(pTHX_ I32 type, I32 flags, PADOFFSET padoff) { OP *var = newOP(type, flags); var->op_targ = padoff; return var; } static OP *my_var(pTHX_ I32 flags, PADOFFSET padoff) { return my_var_g(aTHX_ OP_PADSV, flags, padoff); } static OP *mkhvelem(pTHX_ PADOFFSET h, OP *k) { OP *hv = my_var_g(aTHX_ OP_PADHV, OPf_REF, h); return newBINOP(OP_HELEM, 0, hv, k); } static OP *mkconstsv(pTHX_ SV *sv) { return newSVOP(OP_CONST, 0, sv); } static OP *mkconstiv(pTHX_ IV i) { return mkconstsv(aTHX_ newSViv(i)); } static OP *mkconstpv(pTHX_ const char *p, size_t n) { return mkconstsv(aTHX_ newSVpv(p, n)); } #define mkconstpvs(S) mkconstpv(aTHX_ "" S "", sizeof S - 1) static OP *mkcroak(pTHX_ OP *msg) { OP *xcroak; xcroak = newCVREF( OPf_WANT_SCALAR, mkconstsv(aTHX_ newSVpvs(MY_PKG "::_croak")) ); xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak)); return xcroak; } static OP *mktypecheckv(pTHX_ Sentinel sen, const SV *declarator, size_t nr, SV *name, PADOFFSET padoff, SV *type, int is_invocant) { /* $type->can("has_coercion") && $type->has_coercion * ? $type->check($value = $type->coerce($value)) or F:P::_croak "...: " . $type->get_message($value) * : $type->check($value) or F:P::_croak "...: " . $type->get_message($value) */ OP *chk, *err, *msg, *xcroak; bool has_coercion = FALSE, can_be_inlined = FALSE; { GV *can_has_coercion; if ((can_has_coercion = gv_fetchmethod_autoload(SvSTASH(SvRV(type)), "has_coercion", TRUE))) { SV *ret = call_from_curstash(aTHX_ sen, MUTABLE_SV(GvCV(can_has_coercion)), &type, 1, 0); if (SvTRUE(ret)) { has_coercion = TRUE; } } } { GV *can_can_be_inlined; if ((can_can_be_inlined = gv_fetchmethod_autoload(SvSTASH(SvRV(type)), "can_be_inlined", TRUE))) { SV *ret = call_from_curstash(aTHX_ sen, MUTABLE_SV(GvCV(can_can_be_inlined)), &type, 1, 0); if (SvTRUE(ret)) { can_be_inlined = TRUE; } } } if (can_be_inlined) { GV *can_inline_check; SV *src; can_inline_check = gv_fetchmethod_autoload(SvSTASH(SvRV(type)), "inline_check", FALSE); if (!can_inline_check) { can_inline_check = gv_fetchmethod_autoload(SvSTASH(SvRV(type)), "_inline_check", TRUE); if (!can_inline_check) { goto cannot_inline; } } { SV *f_args[2]; f_args[0] = type; f_args[1] = padoff == NOT_IN_PAD ? sentinel_mortalize(sen, newSVpvs("$_")) : name; src = call_from_curstash(aTHX_ sen, MUTABLE_SV(GvCV(can_inline_check)), f_args, 2, 0); } ENTER; SAVETMPS; { SV *virt_file = sentinel_mortalize(sen, Perl_newSVpvf(aTHX_ "(inline_check:%s:%lu)", CopFILE(PL_curcop), (unsigned long)CopLINE(PL_curcop))); SAVECOPLINE(PL_curcop); SAVECOPFILE_FREE(PL_curcop); { /* local variable because otherwise 5.30.0-DEBUGGING fails under -Werror=shadow */ char *ptr = SvPV_nolen(virt_file); CopFILE_set(PL_curcop, ptr); } CopLINE_set(PL_curcop, 1); lex_start(src, NULL, 0); chk = parse_fullexpr(0); if (PL_parser->error_count) { op_free(chk); chk = NULL; } } FREETMPS; LEAVE; if (!chk) { SV *e = sentinel_mortalize(sen, Perl_newSVpvf( aTHX_ "In %"SVf": inlining type constraint %"SVf" for %s %lu (%"SVf") failed", SVfARG(declarator), SVfARG(type), is_invocant ? "invocant" : "parameter", (unsigned long)nr, SVfARG(name) )); SV *const errsv = PL_errors && SvCUR(PL_errors) ? PL_errors : ERRSV; if (SvTRUE(errsv)) { char *ptr; STRLEN len; e = mess_sv(e, TRUE); ptr = SvPV_force(e, len); if (len >= 2 && ptr[len - 1] == '\n' && ptr[len - 2] == '.') { ptr[len - 2] = ':'; ptr[len - 1] = ' '; } sv_catsv(e, errsv); } croak_sv(e); } if (has_coercion) { OP *args2 = NULL, *coerce; args2 = op_append_elem(OP_LIST, args2, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type))); args2 = op_append_elem(OP_LIST, args2, padoff == NOT_IN_PAD ? newDEFSVOP() : my_var(aTHX_ 0, padoff)); coerce = op_convert_list( OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, args2, newMETHOP(OP_METHOD, 0, mkconstpvs("coerce"))) ); coerce = newASSIGNOP( OPf_STACKED, padoff == NOT_IN_PAD ? newDEFSVOP() : my_var(aTHX_ 0, padoff), 0, coerce ); chk = op_append_elem(OP_LIST, coerce, chk); } } else cannot_inline: { OP *args = NULL, *arg; arg = padoff == NOT_IN_PAD ? newDEFSVOP() : my_var(aTHX_ 0, padoff); if (has_coercion) { OP *args2 = NULL, *coerce; args2 = op_append_elem(OP_LIST, args2, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type))); args2 = op_append_elem(OP_LIST, args2, arg); coerce = op_convert_list( OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, args2, newMETHOP(OP_METHOD, 0, mkconstpvs("coerce"))) ); arg = newASSIGNOP( OPf_STACKED, padoff == NOT_IN_PAD ? newDEFSVOP() : my_var(aTHX_ 0, padoff), 0, coerce ); } args = op_append_elem(OP_LIST, args, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type))); args = op_append_elem(OP_LIST, args, arg); chk = op_convert_list( OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, args, newMETHOP(OP_METHOD, 0, mkconstpvs("check"))) ); } err = mkconstsv( aTHX_ is_invocant == -1 ? Perl_newSVpvf(aTHX_ "In %"SVf": invocant (%"SVf"): ", SVfARG(declarator), SVfARG(name)) : Perl_newSVpvf(aTHX_ "In %"SVf": %s %lu (%"SVf"): ", SVfARG(declarator), is_invocant ? "invocant" : "parameter", (unsigned long)nr, SVfARG(name)) ); { OP *args = NULL; args = op_append_elem(OP_LIST, args, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type))); args = op_append_elem( OP_LIST, args, padoff == NOT_IN_PAD ? newDEFSVOP() : my_var(aTHX_ 0, padoff) ); msg = op_convert_list( OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, args, newMETHOP(OP_METHOD, 0, mkconstpvs("get_message"))) ); } msg = newBINOP(OP_CONCAT, 0, err, msg); xcroak = mkcroak(aTHX_ msg); chk = newLOGOP(OP_OR, 0, chk, xcroak); return chk; } static OP *mktypecheck(pTHX_ Sentinel sen, const SV *declarator, size_t nr, SV *name, PADOFFSET padoff, SV *type) { return mktypecheckv(aTHX_ sen, declarator, nr, name, padoff, type, 0); } static OP *mktypecheckp(pTHX_ Sentinel sen, const SV *declarator, size_t nr, const Param *param) { return mktypecheck(aTHX_ sen, declarator, nr, param->name, param->padoff, param->type); } static OP *mktypecheckpv(pTHX_ Sentinel sen, const SV *declarator, size_t nr, const Param *param, int is_invocant) { return mktypecheckv(aTHX_ sen, declarator, nr, param->name, param->padoff, param->type, is_invocant); } static OP *mkanonsub(pTHX_ CV *cv) { #if HAVE_PERL_VERSION(5, 37, 5) return newSVOP(OP_ANONCODE, OPf_REF, (SV *)cv); #else return newUNOP( OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, (SV *)cv) ); #endif } enum { PARAM_INVOCANT = 0x01, PARAM_NAMED = 0x02, PARAM_DEFINED_OR = 0x04 }; static PADOFFSET parse_param( pTHX_ Sentinel sen, const SV *declarator, const KWSpec *spec, ParamSpec *param_spec, int *pflags, SV **pname, OpGuard *ginit, SV **ptype ) { I32 c; char sigil; SV *name; bool is_defined_or; assert(!ginit->op); *pflags = 0; *ptype = NULL; c = lex_peek_unichar(0); if (spec->flags & FLAG_TYPES_OK) { if (c == '(') { I32 floor_ix; OP *expr; Resource *expr_sentinel; lex_read_unichar(0); floor_ix = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); CvSPECIAL_on(PL_compcv); if (!(expr = parse_fullexpr(PARSE_OPTIONAL))) { Perl_croak(aTHX_ "In %"SVf": invalid type expression", SVfARG(declarator)); } if (MY_OP_SLABBED(expr)) { expr_sentinel = NULL; } else { expr_sentinel = sentinel_register(sen, expr, free_op_void); } lex_read_space(0); c = lex_peek_unichar(0); if (c != ')') { Perl_croak(aTHX_ "In %"SVf": missing ')' after type expression", SVfARG(declarator)); } lex_read_unichar(0); lex_read_space(0); SvREFCNT_inc_simple_void(PL_compcv); if (expr_sentinel) { sentinel_disarm(expr_sentinel); } *ptype = my_eval(aTHX_ sen, floor_ix, expr); if (!SvROK(*ptype)) { *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype); } else if (!sv_isobject(*ptype)) { Perl_croak(aTHX_ "In %"SVf": invalid type (%"SVf" is not a type object)", SVfARG(declarator), SVfARG(*ptype)); } c = lex_peek_unichar(0); } else if (MY_UNI_IDFIRST(c) || c == '~') { *ptype = parse_type(aTHX_ sen, declarator, ','); *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype); c = lex_peek_unichar(0); } } if (c == ':') { lex_read_unichar(0); lex_read_space(0); *pflags |= PARAM_NAMED; c = lex_peek_unichar(0); } if (c == -1) { Perl_croak(aTHX_ "In %"SVf": unterminated parameter list", SVfARG(declarator)); } if (!(c == '$' || c == '@' || c == '%')) { Perl_croak(aTHX_ "In %"SVf": unexpected '%c' in parameter list (expecting a sigil)", SVfARG(declarator), (int)c); } sigil = c; lex_read_unichar(0); c = lex_peek_unichar(0); if (c == '#') { Perl_croak(aTHX_ "In %"SVf": unexpected '%c#' in parameter list (expecting an identifier)", SVfARG(declarator), sigil); } lex_read_space(0); if (!(name = my_scan_word(aTHX_ sen, FALSE))) { name = sentinel_mortalize(sen, newSVpvs("")); } else if (sv_eq_pvs(name, "_")) { Perl_croak(aTHX_ "In %"SVf": Can't use global %c_ as a parameter", SVfARG(declarator), sigil); } sv_insert(name, 0, 0, &sigil, 1); *pname = name; lex_read_space(0); c = lex_peek_unichar(0); is_defined_or = FALSE; if (c == '/') { lex_read_unichar(0); c = lex_peek_unichar(0); if (c != '/') { Perl_croak(aTHX_ "In %"SVf": unexpected '%s' after '%"SVf"' (expecting '//=' or '=')", SVfARG(declarator), c == '=' ? "/=" : "/", SVfARG(name)); } lex_read_unichar(0); c = lex_peek_unichar(0); if (c != '=') { Perl_croak(aTHX_ "In %"SVf": unexpected '%c' after '%"SVf" //' (expecting '=')", SVfARG(declarator), (int)c, SVfARG(name)); } *pflags |= PARAM_DEFINED_OR; is_defined_or = TRUE; /* fall through */ } if (c == '=') { lex_read_unichar(0); lex_read_space(0); c = lex_peek_unichar(0); if (c == ',' || c == ')') { if (is_defined_or) { Perl_croak(aTHX_ "In %"SVf": unexpected '%c' after '//=' (expecting expression)", SVfARG(declarator), (int)c); } op_guard_update(ginit, newOP(OP_UNDEF, 0)); } else { if (param_spec->shift == 0 && spec->shift.used) { size_t i, lim = spec->shift.used; Param *p = pv_unshift(¶m_spec->positional_required, lim); for (i = 0; i < lim; i++) { p[i].name = spec->shift.data[i].name; p[i].padoff = pad_add_name_sv(p[i].name, 0, NULL, NULL); p[i].type = spec->shift.data[i].type; } param_spec->shift = lim; intro_my(); } op_guard_update(ginit, parse_termexpr(0)); lex_read_space(0); c = lex_peek_unichar(0); } } if (c == ':') { *pflags |= PARAM_INVOCANT; lex_read_unichar(0); lex_read_space(0); } else if (c == ',') { lex_read_unichar(0); lex_read_space(0); } else if (c != ')') { if (c == -1) { Perl_croak(aTHX_ "In %"SVf": unterminated parameter list", SVfARG(declarator)); } Perl_croak(aTHX_ "In %"SVf": unexpected '%c' in parameter list (expecting ',')", SVfARG(declarator), (int)c); } return SvCUR(*pname) < 2 ? NOT_IN_PAD : pad_add_name_sv(*pname, padadd_NO_DUP_CHECK, NULL, NULL) ; } static void register_info(pTHX_ UV key, SV *declarator, const ParamSpec *ps) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 9); /* 0 */ { mPUSHu(key); } /* 1 */ { STRLEN n; char *p = SvPV(declarator, n); char *q = memchr(p, ' ', n); SV *tmp = newSVpvn_utf8(p, q ? (size_t)(q - p) : n, SvUTF8(declarator)); mPUSHs(tmp); } /* 2 */ { mPUSHu(ps->shift); } /* 3 */ { size_t i, lim; AV *av; lim = ps->positional_required.used; av = newAV(); if (lim) { av_extend(av, (lim - 1) * 2); for (i = 0; i < lim; i++) { Param *cur = &ps->positional_required.data[i]; av_push(av, SvREFCNT_inc_simple_NN(cur->name)); av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef); } } mPUSHs(newRV_noinc((SV *)av)); } /* 4 */ { size_t i, lim; AV *av; lim = ps->positional_optional.used; av = newAV(); if (lim) { av_extend(av, (lim - 1) * 2); for (i = 0; i < lim; i++) { Param *cur = &ps->positional_optional.data[i].param; av_push(av, SvREFCNT_inc_simple_NN(cur->name)); av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef); } } mPUSHs(newRV_noinc((SV *)av)); } /* 5 */ { size_t i, lim; AV *av; lim = ps->named_required.used; av = newAV(); if (lim) { av_extend(av, (lim - 1) * 2); for (i = 0; i < lim; i++) { Param *cur = &ps->named_required.data[i]; av_push(av, SvREFCNT_inc_simple_NN(cur->name)); av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef); } } mPUSHs(newRV_noinc((SV *)av)); } /* 6 */ { size_t i, lim; AV *av; lim = ps->named_optional.used; av = newAV(); if (lim) { av_extend(av, (lim - 1) * 2); for (i = 0; i < lim; i++) { Param *cur = &ps->named_optional.data[i].param; av_push(av, SvREFCNT_inc_simple_NN(cur->name)); av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef); } } mPUSHs(newRV_noinc((SV *)av)); } /* 7, 8 */ { if (ps->slurpy.name) { PUSHs(ps->slurpy.name); if (ps->slurpy.type) { PUSHs(ps->slurpy.type); } else { PUSHmortal; } } else { PUSHmortal; PUSHmortal; } } PUTBACK; call_pv(MY_PKG "::_register_info", G_VOID); FREETMPS; LEAVE; } static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) { ParamSpec *param_spec; SV *declarator; I32 floor_ix; int save_ix; SV *saw_name; OpGuard *prelude_sentinel; SV *proto; OpGuard *attrs_sentinel; OP *body; unsigned builtin_attrs; I32 c; declarator = sentinel_mortalize(sen, newSVpvn(keyword_ptr, keyword_len)); if (lex_bufutf8()) { SvUTF8_on(declarator); } lex_read_space(0); builtin_attrs = 0; /* function name */ saw_name = NULL; if ((spec->flags & FLAG_NAME_OK) && (saw_name = my_scan_word(aTHX_ sen, TRUE))) { if (PL_parser->expect != XSTATE) { /* bail out early so we don't predeclare $saw_name */ Perl_croak(aTHX_ "In %"SVf": I was expecting a parameter list, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name)); } sv_catpvs(declarator, " "); sv_catsv(declarator, saw_name); if ( sv_eq_pvs(saw_name, "BEGIN") || sv_eq_pvs(saw_name, "END") || sv_eq_pvs(saw_name, "INIT") || sv_eq_pvs(saw_name, "CHECK") || sv_eq_pvs(saw_name, "UNITCHECK") ) { builtin_attrs |= MY_ATTR_SPECIAL; } lex_read_space(0); } else if (!(spec->flags & FLAG_ANON_OK)) { Perl_croak(aTHX_ "I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - PL_parser->bufptr), PL_parser->bufptr); } else { sv_catpvs(declarator, " (anon)"); } /* we're a subroutine declaration */ floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON); SAVEFREESV(PL_compcv); /* create outer block: '{' */ save_ix = block_start(TRUE); /* initialize synthetic optree */ Newx(prelude_sentinel, 1, OpGuard); op_guard_init(prelude_sentinel); sentinel_register(sen, prelude_sentinel, free_op_guard_void); /* parameters */ c = lex_peek_unichar(0); if (c != '(') { Perl_croak(aTHX_ "In %"SVf": I was expecting a parameter list, not \"%c\"", SVfARG(declarator), (int)c); } lex_read_unichar(0); lex_read_space(0); Newx(param_spec, 1, ParamSpec); ps_init(param_spec); sentinel_register(sen, param_spec, ps_free_void); { OpGuard *init_sentinel; Newx(init_sentinel, 1, OpGuard); op_guard_init(init_sentinel); sentinel_register(sen, init_sentinel, free_op_guard_void); while ((c = lex_peek_unichar(0)) != ')') { int flags; SV *name, *type; char sigil; PADOFFSET padoff; padoff = parse_param(aTHX_ sen, declarator, spec, param_spec, &flags, &name, init_sentinel, &type); if (padoff != NOT_IN_PAD) { intro_my(); } sigil = SvPV_nolen(name)[0]; /* internal consistency */ if (flags & PARAM_NAMED) { if (padoff == NOT_IN_PAD) { Perl_croak(aTHX_ "In %"SVf": named parameter %"SVf" can't be unnamed", SVfARG(declarator), SVfARG(name)); } if (flags & PARAM_INVOCANT) { Perl_croak(aTHX_ "In %"SVf": invocant %"SVf" can't be a named parameter", SVfARG(declarator), SVfARG(name)); } if (sigil != '$') { Perl_croak(aTHX_ "In %"SVf": named parameter %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash"); } } else if (flags & PARAM_INVOCANT) { if (init_sentinel->op) { Perl_croak(aTHX_ "In %"SVf": invocant %"SVf" can't have a default value", SVfARG(declarator), SVfARG(name)); } if (sigil != '$') { Perl_croak(aTHX_ "In %"SVf": invocant %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash"); } } else if (sigil != '$' && init_sentinel->op) { Perl_croak(aTHX_ "In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(name)); } if (type && padoff == NOT_IN_PAD) { Perl_croak(aTHX_ "In %"SVf": unnamed parameter %"SVf" can't have a type", SVfARG(declarator), SVfARG(name)); } /* external constraints */ if (param_spec->slurpy.name) { Perl_croak(aTHX_ "In %"SVf": \"%"SVf"\" can't appear after slurpy parameter \"%"SVf"\"", SVfARG(declarator), SVfARG(name), SVfARG(param_spec->slurpy.name)); } if (sigil != '$') { assert(!init_sentinel->op); param_spec->slurpy.name = name; param_spec->slurpy.padoff = padoff; param_spec->slurpy.type = type; continue; } if (!(flags & PARAM_NAMED) && count_named_params(param_spec)) { Perl_croak(aTHX_ "In %"SVf": positional parameter %"SVf" can't appear after named parameter %"SVf"", SVfARG(declarator), SVfARG(name), SVfARG((param_spec->named_required.used ? param_spec->named_required.data[0] : param_spec->named_optional.data[0].param).name)); } if (flags & PARAM_INVOCANT) { if (param_spec->shift) { assert(param_spec->shift <= param_spec->positional_required.used); Perl_croak(aTHX_ "In %"SVf": invalid double invocants (... %"SVf": ... %"SVf":)", SVfARG(declarator), SVfARG(param_spec->positional_required.data[param_spec->shift - 1].name), SVfARG(name)); } if (!(spec->flags & FLAG_INVOCANT)) { Perl_croak(aTHX_ "In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(name)); } if (spec->shift.used && spec->shift.used != param_spec->positional_required.used + 1) { Perl_croak(aTHX_ "In %"SVf": number of invocants in parameter list (%lu) differs from number of invocants in keyword definition (%lu)", SVfARG(declarator), (unsigned long)(param_spec->positional_required.used + 1), (unsigned long)spec->shift.used); } } if (!(flags & PARAM_NAMED) && !init_sentinel->op && param_spec->positional_optional.used) { Perl_croak(aTHX_ "In %"SVf": required parameter %"SVf" can't appear after optional parameter %"SVf"", SVfARG(declarator), SVfARG(name), SVfARG(param_spec->positional_optional.data[0].param.name)); } if (init_sentinel->op && !(spec->flags & FLAG_DEFAULT_ARGS)) { Perl_croak(aTHX_ "In %"SVf": default argument for %"SVf" not allowed here", SVfARG(declarator), SVfARG(name)); } if (padoff != NOT_IN_PAD && ps_contains(aTHX_ param_spec, name)) { Perl_croak(aTHX_ "In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(name)); } if (flags & PARAM_NAMED) { if (!(spec->flags & FLAG_NAMED_PARAMS)) { Perl_croak(aTHX_ "In %"SVf": named parameter :%"SVf" not allowed here", SVfARG(declarator), SVfARG(name)); } if (init_sentinel->op) { ParamInit *pi = piv_extend(¶m_spec->named_optional); pi->param.name = name; pi->param.padoff = padoff; pi->param.type = type; pi->init = op_guard_transfer(init_sentinel); pi->cond = flags & PARAM_DEFINED_OR ? ICOND_DEFINED : ICOND_EXISTS; param_spec->named_optional.used++; } else { if (param_spec->positional_optional.used) { Perl_croak(aTHX_ "In %"SVf": can't combine optional positional (%"SVf") and required named (%"SVf") parameters", SVfARG(declarator), SVfARG(param_spec->positional_optional.data[0].param.name), SVfARG(name)); } pv_push(¶m_spec->named_required, name, padoff, type); } } else { if (init_sentinel->op) { ParamInit *pi = piv_extend(¶m_spec->positional_optional); pi->param.name = name; pi->param.padoff = padoff; pi->param.type = type; pi->init = op_guard_transfer(init_sentinel); pi->cond = flags & PARAM_DEFINED_OR ? ICOND_DEFINED : ICOND_EXISTS; param_spec->positional_optional.used++; } else { assert(param_spec->positional_optional.used == 0); pv_push(¶m_spec->positional_required, name, padoff, type); if (flags & PARAM_INVOCANT) { assert(param_spec->shift == 0); param_spec->shift = param_spec->positional_required.used; } } } } lex_read_unichar(0); lex_read_space(0); if (param_spec->shift == 0 && spec->shift.used) { size_t i, lim = spec->shift.used; Param *p; p = pv_unshift(¶m_spec->positional_required, lim); for (i = 0; i < lim; i++) { const SpecParam *const cur = &spec->shift.data[i]; if (ps_contains(aTHX_ param_spec, cur->name)) { Perl_croak(aTHX_ "In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(cur->name)); } p[i].name = cur->name; p[i].padoff = pad_add_name_sv(p[i].name, 0, NULL, NULL); p[i].type = cur->type; } param_spec->shift = lim; } } /* attributes */ Newx(attrs_sentinel, 1, OpGuard); op_guard_init(attrs_sentinel); sentinel_register(sen, attrs_sentinel, free_op_guard_void); proto = NULL; c = lex_peek_unichar(0); if (c == ':' || c == '{') /* '}' - hi, vim */ { /* kludge default attributes in */ if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') { lex_stuff_sv(spec->attrs, 0); c = ':'; } if (c == ':') { lex_read_unichar(0); lex_read_space(0); c = lex_peek_unichar(0); for (;;) { SV *attr; if (!(attr = my_scan_word(aTHX_ sen, FALSE))) { break; } lex_read_space(0); c = lex_peek_unichar(0); if (c != '(') { if (sv_eq_pvs(attr, "lvalue")) { builtin_attrs |= MY_ATTR_LVALUE; attr = NULL; } else if (sv_eq_pvs(attr, "method")) { builtin_attrs |= MY_ATTR_METHOD; attr = NULL; } } else { SV *sv; lex_read_unichar(0); if (!(sv = my_scan_parens_tail(aTHX_ sen, TRUE))) { Perl_croak(aTHX_ "In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator)); } if (sv_eq_pvs(attr, "prototype")) { if (proto) { Perl_croak(aTHX_ "In %"SVf": Can't redefine prototype (%"SVf") using attribute prototype(%"SVf")", SVfARG(declarator), SVfARG(proto), SVfARG(sv)); } proto = sv; my_check_prototype(aTHX_ sen, declarator, proto); attr = NULL; } else { sv_catpvs(attr, "("); sv_catsv(attr, sv); sv_catpvs(attr, ")"); } lex_read_space(0); c = lex_peek_unichar(0); } if (attr) { op_guard_update(attrs_sentinel, op_append_elem(OP_LIST, attrs_sentinel->op, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(attr)))); } if (c == ':') { lex_read_unichar(0); lex_read_space(0); c = lex_peek_unichar(0); } } } } /* body */ if (c != '{') /* '}' - hi, vim */ { Perl_croak(aTHX_ "In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c); } /* surprise predeclaration! */ if (saw_name && !spec->install_sub && !(spec->flags & FLAG_RUNTIME)) { /* 'sub NAME (PROTO);' to make name/proto known to perl before it starts parsing the body */ const I32 sub_ix = start_subparse(FALSE, 0); SAVEFREESV(PL_compcv); SvREFCNT_inc_simple_void(PL_compcv); #if HAVE_BUG_GH_15557 { CV *const outside = CvOUTSIDE(PL_compcv); if (outside) { CvOUTSIDE(PL_compcv) = NULL; if (!CvWEAKOUTSIDE(PL_compcv)) { SvREFCNT_dec_NN(outside); } } } #endif newATTRSUB( sub_ix, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(saw_name)), proto ? mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(proto)) : NULL, NULL, NULL ); } if (builtin_attrs & MY_ATTR_LVALUE) { CvLVALUE_on(PL_compcv); } if (builtin_attrs & MY_ATTR_METHOD) { CvMETHOD_on(PL_compcv); } if (builtin_attrs & MY_ATTR_SPECIAL) { CvSPECIAL_on(PL_compcv); } /* check number of arguments */ if (spec->flags & FLAG_CHECK_NARGS) { int amin, amax; amin = args_min(param_spec); if (amin > 0) { OP *chk, *cond, *err; err = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "Too few arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amin)); err = newBINOP( OP_CONCAT, 0, err, newAVREF(newGVOP(OP_GV, 0, PL_defgv)) ); err = newBINOP( OP_CONCAT, 0, err, mkconstpvs(")") ); err = mkcroak(aTHX_ err); cond = newBINOP(OP_LT, 0, newAVREF(newGVOP(OP_GV, 0, PL_defgv)), mkconstiv(aTHX_ amin)); chk = newLOGOP(OP_AND, 0, cond, err); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, chk))); } amax = args_max(param_spec); if (amax >= 0) { OP *chk, *cond, *err; err = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "Too many arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amax)); err = newBINOP( OP_CONCAT, 0, err, newAVREF(newGVOP(OP_GV, 0, PL_defgv)) ); err = newBINOP( OP_CONCAT, 0, err, mkconstpvs(")") ); err = mkcroak(aTHX_ err); cond = newBINOP( OP_GT, 0, newAVREF(newGVOP(OP_GV, 0, PL_defgv)), mkconstiv(aTHX_ amax) ); chk = newLOGOP(OP_AND, 0, cond, err); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, chk))); } if (count_named_params(param_spec) || (param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%')) { OP *chk, *cond, *err; const UV fixed = count_positional_params(param_spec); err = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "Odd number of paired arguments for %"SVf"", SVfARG(declarator))); err = mkcroak(aTHX_ err); cond = newBINOP(OP_GT, 0, newAVREF(newGVOP(OP_GV, 0, PL_defgv)), mkconstiv(aTHX_ fixed)); cond = newLOGOP(OP_AND, 0, cond, newBINOP(OP_MODULO, 0, fixed ? newBINOP(OP_SUBTRACT, 0, newAVREF(newGVOP(OP_GV, 0, PL_defgv)), mkconstiv(aTHX_ fixed)) : newAVREF(newGVOP(OP_GV, 0, PL_defgv)), mkconstiv(aTHX_ 2))); chk = newLOGOP(OP_AND, 0, cond, err); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, chk))); } } assert(param_spec->shift <= param_spec->positional_required.used); if (param_spec->shift) { bool all_anon = TRUE; { size_t i; for (i = 0; i < param_spec->shift; i++) { if (param_spec->positional_required.data[i].padoff != NOT_IN_PAD) { all_anon = FALSE; break; } } } if (param_spec->shift == 1) { if (all_anon) { /* shift; */ op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, newOP(OP_SHIFT, 0)))); } else { /* my $invocant = shift; */ OP *var; var = my_var( aTHX_ OPf_MOD | (OPpLVAL_INTRO << 8), param_spec->positional_required.data[0].padoff ); var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, var))); } } else { OP *const rhs = op_convert_list(OP_SPLICE, 0, op_append_elem( OP_LIST, op_append_elem( OP_LIST, newAVREF(newGVOP(OP_GV, 0, PL_defgv)), mkconstiv(aTHX_ 0) ), mkconstiv(aTHX_ param_spec->shift))); if (all_anon) { /* splice @_, 0, $n; */ op_guard_update( prelude_sentinel, op_append_list( OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, rhs))); } else { /* my (...) = splice @_, 0, $n; */ OP *lhs; size_t i, lim; lhs = NULL; for (i = 0, lim = param_spec->shift; i < lim; i++) { const PADOFFSET padoff = param_spec->positional_required.data[i].padoff; lhs = op_append_elem( OP_LIST, lhs, padoff == NOT_IN_PAD ? newOP(OP_UNDEF, 0) : my_var( aTHX_ OPf_WANT_LIST | (OPpLVAL_INTRO << 8), padoff ) ); } lhs->op_flags |= OPf_PARENS; op_guard_update(prelude_sentinel, op_append_list( OP_LINESEQ, prelude_sentinel->op, newSTATEOP( 0, NULL, newASSIGNOP(OPf_STACKED, lhs, 0, rhs) ) )); } } } /* my (...) = @_; */ { OP *lhs; size_t i, lim; lhs = NULL; for (i = param_spec->shift, lim = param_spec->positional_required.used; i < lim; i++) { const PADOFFSET padoff = param_spec->positional_required.data[i].padoff; lhs = op_append_elem( OP_LIST, lhs, padoff == NOT_IN_PAD ? newOP(OP_UNDEF, 0) : my_var( aTHX_ OPf_WANT_LIST | (OPpLVAL_INTRO << 8), padoff ) ); } for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) { const PADOFFSET padoff = param_spec->positional_optional.data[i].param.padoff; lhs = op_append_elem( OP_LIST, lhs, padoff == NOT_IN_PAD ? newOP(OP_UNDEF, 0) : my_var( aTHX_ OPf_WANT_LIST | (OPpLVAL_INTRO << 8), padoff ) ); } { PADOFFSET padoff; I32 type; bool slurpy_hash; /* * cases: * 1) no named params * 1.1) slurpy * => put it in * 1.2) no slurpy * => nop * 2) named params * 2.1) no slurpy * => synthetic %{__rest} * 2.2) slurpy is a hash * => put it in * 2.3) slurpy is an array * => synthetic %{__rest} * remember to declare array later */ slurpy_hash = param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%'; if (!count_named_params(param_spec)) { if (param_spec->slurpy.name && param_spec->slurpy.padoff != NOT_IN_PAD) { padoff = param_spec->slurpy.padoff; type = slurpy_hash ? OP_PADHV : OP_PADAV; } else { padoff = NOT_IN_PAD; type = OP_PADSV; } } else if (slurpy_hash && param_spec->slurpy.padoff != NOT_IN_PAD) { padoff = param_spec->slurpy.padoff; type = OP_PADHV; } else { padoff = pad_add_name_pvs("%{__rest}", 0, NULL, NULL); type = OP_PADHV; } if (padoff != NOT_IN_PAD) { OP *const var = my_var_g( aTHX_ type, OPf_WANT_LIST | (OPpLVAL_INTRO << 8), padoff ); lhs = op_append_elem(OP_LIST, lhs, var); if (type == OP_PADHV) { param_spec->rest_hash = padoff; } } } if (lhs) { OP *const rhs = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); lhs->op_flags |= OPf_PARENS; op_guard_update(prelude_sentinel, op_append_list( OP_LINESEQ, prelude_sentinel->op, newSTATEOP( 0, NULL, newASSIGNOP(OPf_STACKED, lhs, 0, rhs) ) )); } } /* default positional arguments */ { size_t i, lim, req; OP *nest, *sequ; nest = NULL; sequ = NULL; req = param_spec->positional_required.used - param_spec->shift; for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) { ParamInit *cur = ¶m_spec->positional_optional.data[i]; OP *cond, *init; { OP *const init_op = cur->init.op; if (init_op->op_type == OP_UNDEF && !(init_op->op_flags & OPf_KIDS)) { continue; } } switch (cur->cond) { case ICOND_DEFINED: init = op_guard_relinquish(&cur->init); if (cur->param.padoff == NOT_IN_PAD) { OP *arg = newBINOP( OP_AELEM, 0, newAVREF(newGVOP(OP_GV, 0, PL_defgv)), mkconstiv(aTHX_ req + i) ); init = newLOGOP(OP_DOR, 0, arg, init); } else { OP *var = my_var(aTHX_ 0, cur->param.padoff); init = newASSIGNOP(OPf_STACKED, var, OP_DORASSIGN, init); } sequ = op_append_list(OP_LINESEQ, sequ, nest); nest = NULL; sequ = op_append_list(OP_LINESEQ, sequ, init); break; case ICOND_EXISTS: cond = newBINOP( OP_LT, 0, newAVREF(newGVOP(OP_GV, 0, PL_defgv)), mkconstiv(aTHX_ req + i + 1) ); init = op_guard_relinquish(&cur->init); if (cur->param.padoff != NOT_IN_PAD) { OP *var = my_var(aTHX_ 0, cur->param.padoff); init = newASSIGNOP(OPf_STACKED, var, 0, init); } nest = op_append_list(OP_LINESEQ, nest, init); nest = newCONDOP(0, cond, nest, NULL); break; } } sequ = op_append_list(OP_LINESEQ, sequ, nest); op_guard_update(prelude_sentinel, op_append_list( OP_LINESEQ, prelude_sentinel->op, sequ )); } /* named parameters */ if (count_named_params(param_spec)) { size_t i, lim; assert(param_spec->rest_hash != NOT_IN_PAD); for (i = 0, lim = param_spec->named_required.used; i < lim; i++) { Param *cur = ¶m_spec->named_required.data[i]; size_t n; char *p = SvPV(cur->name, n); OP *var, *cond; assert(cur->padoff != NOT_IN_PAD); cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1)); if (spec->flags & FLAG_CHECK_NARGS) { OP *xcroak, *msg; var = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1)); var = newUNOP(OP_DELETE, 0, var); msg = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "In %"SVf": missing named parameter: %.*s", SVfARG(declarator), (int)(n - 1), p + 1)); xcroak = mkcroak(aTHX_ msg); cond = newUNOP(OP_EXISTS, 0, cond); cond = newCONDOP(0, cond, var, xcroak); } var = my_var( aTHX_ OPf_MOD | (OPpLVAL_INTRO << 8), cur->padoff ); var = newASSIGNOP(OPf_STACKED, var, 0, cond); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, var))); } for (i = 0, lim = param_spec->named_optional.used; i < lim; i++) { ParamInit *cur = ¶m_spec->named_optional.data[i]; size_t n; char *p = SvPV(cur->param.name, n); OP *var, *expr; expr = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1)); expr = newUNOP(OP_DELETE, 0, expr); { OP *const init = cur->init.op; if (!(init->op_type == OP_UNDEF && !(init->op_flags & OPf_KIDS))) { switch (cur->cond) { case ICOND_DEFINED: expr = newLOGOP(OP_DOR, 0, expr, op_guard_relinquish(&cur->init)); break; case ICOND_EXISTS: { OP *cond; cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1)); cond = newUNOP(OP_EXISTS, 0, cond); expr = newCONDOP(0, cond, expr, op_guard_relinquish(&cur->init)); break; } } } } var = my_var( aTHX_ OPf_MOD | (OPpLVAL_INTRO << 8), cur->param.padoff ); var = newASSIGNOP(OPf_STACKED, var, 0, expr); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, var))); } if (!param_spec->slurpy.name) { if (spec->flags & FLAG_CHECK_NARGS) { /* croak if %{__rest} */ OP *xcroak, *cond, *keys, *msg; keys = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash)); keys = newLISTOP(OP_SORT, 0, newOP(OP_PUSHMARK, 0), keys); keys->op_flags = (keys->op_flags & ~OPf_WANT) | OPf_WANT_LIST; keys = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, mkconstpvs(", "), keys)); keys->op_targ = pad_alloc(OP_JOIN, SVs_PADTMP); msg = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "In %"SVf": no such named parameter: ", SVfARG(declarator))); msg = newBINOP(OP_CONCAT, 0, msg, keys); xcroak = mkcroak(aTHX_ msg); cond = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash)); xcroak = newCONDOP(0, cond, xcroak, NULL); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, xcroak))); } else { OP *clear; clear = newASSIGNOP( OPf_STACKED, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash), 0, newNULLLIST() ); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, clear))); } } else if (param_spec->slurpy.padoff != param_spec->rest_hash) { OP *clear; assert(param_spec->rest_hash != NOT_IN_PAD); if (SvPV_nolen(param_spec->slurpy.name)[0] == '%') { assert(param_spec->slurpy.padoff == NOT_IN_PAD); } else { assert(SvPV_nolen(param_spec->slurpy.name)[0] == '@'); if (param_spec->slurpy.padoff != NOT_IN_PAD) { OP *var = my_var_g( aTHX_ OP_PADAV, OPf_MOD | (OPpLVAL_INTRO << 8), param_spec->slurpy.padoff ); var = newASSIGNOP(OPf_STACKED, var, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash)); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, var))); } } clear = newASSIGNOP( OPf_STACKED, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash), 0, newNULLLIST() ); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, clear))); } } if (spec->flags & FLAG_CHECK_TARGS) { size_t i, lim, base; base = 1; for (i = 0, lim = param_spec->positional_required.used; i < lim; i++) { Param *cur = ¶m_spec->positional_required.data[i]; if (cur->type) { const bool is_invocant = i < param_spec->shift; const size_t shift = param_spec->shift; assert(cur->padoff != NOT_IN_PAD); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckpv(aTHX_ sen, declarator, base + i - (is_invocant ? 0 : shift), cur, !is_invocant ? 0 : shift == 1 ? -1 : 1)))); } } base += i - param_spec->shift; for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) { Param *cur = ¶m_spec->positional_optional.data[i].param; if (cur->type) { assert(cur->padoff != NOT_IN_PAD); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckp(aTHX_ sen, declarator, base + i, cur)))); } } base += i; for (i = 0, lim = param_spec->named_required.used; i < lim; i++) { Param *cur = ¶m_spec->named_required.data[i]; if (cur->type) { assert(cur->padoff != NOT_IN_PAD); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckp(aTHX_ sen, declarator, base + i, cur)))); } } base += i; for (i = 0, lim = param_spec->named_optional.used; i < lim; i++) { Param *cur = ¶m_spec->named_optional.data[i].param; if (cur->type) { assert(cur->padoff != NOT_IN_PAD); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckp(aTHX_ sen, declarator, base + i, cur)))); } } base += i; if (param_spec->slurpy.type) { /* $type->valid($_) or croak $type->get_message($_) for @rest / values %rest */ OP *check, *list, *loop; assert(param_spec->slurpy.padoff != NOT_IN_PAD); check = mktypecheck(aTHX_ sen, declarator, base, param_spec->slurpy.name, NOT_IN_PAD, param_spec->slurpy.type); if (SvPV_nolen(param_spec->slurpy.name)[0] == '@') { list = my_var_g(aTHX_ OP_PADAV, 0, param_spec->slurpy.padoff); } else { list = my_var_g(aTHX_ OP_PADHV, 0, param_spec->slurpy.padoff); list = newUNOP(OP_VALUES, 0, list); } loop = newFOROP(0, NULL, list, check, NULL); op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, loop))); } } /* finally let perl parse the actual subroutine body */ body = parse_block(0); /* add '();' to make function return nothing by default */ /* (otherwise the invisible parameter initialization can "leak" into the return value: fun ($x) {}->("asdf", 0) == 2) */ if (prelude_sentinel->op) { body = newSTATEOP(0, NULL, body); } body = op_append_list(OP_LINESEQ, op_guard_relinquish(prelude_sentinel), body); /* it's go time. */ { const bool runtime = cBOOL(spec->flags & FLAG_RUNTIME); CV *cv; OP *const attrs = op_guard_relinquish(attrs_sentinel); SvREFCNT_inc_simple_void(PL_compcv); /* close outer block: '}' */ body = block_end(save_ix, body); cv = newATTRSUB( floor_ix, saw_name && !runtime && !spec->install_sub ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)) : NULL, proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, attrs, body ); if (cv) { assert(cv != CvOUTSIDE(cv)); register_info(aTHX_ PTR2UV(CvROOT(cv)), declarator, param_spec); } if (saw_name) { if (!runtime) { if (spec->install_sub) { SV *args[2]; args[0] = saw_name; args[1] = sentinel_mortalize(sen, newRV_noinc((SV *)cv)); call_from_curstash(aTHX_ sen, spec->install_sub, args, 2, G_VOID); } *pop = newOP(OP_NULL, 0); } else { *pop = newUNOP( OP_ENTERSUB, OPf_STACKED, op_append_elem( OP_LIST, op_append_elem( OP_LIST, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(saw_name)), mkanonsub(aTHX_ cv) ), newCVREF( OPf_WANT_SCALAR, mkconstsv(aTHX_ spec->install_sub ? SvREFCNT_inc_simple_NN(spec->install_sub) : newSVpvs(MY_PKG "::_defun") ) ) ) ); } return KEYWORD_PLUGIN_STMT; } *pop = mkanonsub(aTHX_ cv); return KEYWORD_PLUGIN_EXPR; } } static int kw_flags_enter(pTHX_ Sentinel **ppsen, const char *kw_ptr, STRLEN kw_len, KWSpec **ppspec) { HV *hints, *config; /* don't bother doing anything fancy after a syntax error */ if (PL_parser && PL_parser->error_count) { return FALSE; } STATIC_ASSERT_STMT(~(STRLEN)0 > (U32)I32_MAX); if (kw_len > (STRLEN)I32_MAX) { return FALSE; } if (!(hints = GvHV(PL_hintgv))) { return FALSE; } { SV **psv, *sv, *sv2; I32 kw_xlen = kw_len; if (!(psv = hv_fetchs(hints, HINTK_CONFIG, 0))) { return FALSE; } sv = *psv; if (!SvROK(sv)) { /* something is wrong: $^H{'Function::Parameters/config'} has turned into a string */ dSP; PUSHMARK(SP); call_pv(MY_PKG "::_warn_config_not_a_reference", G_VOID); /* don't warn twice within the same scope */ hv_delete(hints, HINTK_CONFIG, sizeof HINTK_CONFIG - 1, G_DISCARD); return FALSE; } sv2 = SvRV(sv); if (SvTYPE(sv2) != SVt_PVHV) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'} not a hashref: %"SVf, MY_PKG, HINTK_CONFIG, SVfARG(sv)); } if (lex_bufutf8()) { kw_xlen = -kw_xlen; } if (!(psv = hv_fetch((HV *)sv2, kw_ptr, kw_xlen, 0))) { return FALSE; } sv = *psv; if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVHV))) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'} not a hashref: %"SVf, MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, SVfARG(sv)); } config = (HV *)sv2; } ENTER; SAVETMPS; Newx(*ppsen, 1, Sentinel); ***ppsen = NULL; SAVEDESTRUCTOR_X(sentinel_clear_void, *ppsen); Newx(*ppspec, 1, KWSpec); (*ppspec)->flags = 0; (*ppspec)->reify_type = NULL; spv_init(&(*ppspec)->shift); (*ppspec)->attrs = sentinel_mortalize(**ppsen, newSVpvs("")); (*ppspec)->install_sub = NULL; sentinel_register(**ppsen, *ppspec, kws_free_void); #define FETCH_HINTSK_INTO(NAME, PSV) STMT_START { \ SV **hsk_psv_; \ if (!(hsk_psv_ = hv_fetchs(config, HINTSK_ ## NAME, 0))) { \ Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'} not set", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_ ## NAME); \ } \ *(PSV) = *hsk_psv_; \ } STMT_END { SV *sv; FETCH_HINTSK_INTO(FLAGS, &sv); (*ppspec)->flags = SvIV(sv); FETCH_HINTSK_INTO(REIFY, &sv); if (!sv || !SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVCV) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'} not a coderef: %"SVf, MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_REIFY, SVfARG(sv)); } (*ppspec)->reify_type = sv; FETCH_HINTSK_INTO(SHIFT, &sv); { STRLEN sv_len; const char *const sv_p = SvPVutf8(sv, sv_len); const char *const sv_p_end = sv_p + sv_len; const char *p = sv_p; AV *shift_types = NULL; SV *type = NULL; while (p < sv_p_end) { const char *const v_start = p, *v_end; if (*p != '$') { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: expected '$', found '%.*s'", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (int)(sv_p_end - p), p); } p++; if (p >= sv_p_end || !MY_UNI_IDFIRST_utf8(p, sv_p_end)) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: expected idfirst, found '%.*s'", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (int)(sv_p_end - p), p); } p += UTF8SKIP(p); while (p < sv_p_end && MY_UNI_IDCONT_utf8(p, sv_p_end)) { p += UTF8SKIP(p); } v_end = p; if (v_end == v_start + 2 && v_start[1] == '_') { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: can't use global $_ as a parameter", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT); } { size_t i, lim = (*ppspec)->shift.used; for (i = 0; i < lim; i++) { if (my_sv_eq_pvn(aTHX_ (*ppspec)->shift.data[i].name, v_start, v_end - v_start)) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: %"SVf" can't appear twice", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, SVfARG((*ppspec)->shift.data[i].name)); } } } if (p < sv_p_end && *p == '/') { SSize_t tix = 0; SV **ptype; p++; while (p < sv_p_end && isDIGIT(*p)) { tix = tix * 10 + (*p - '0'); p++; } if (!shift_types) { SV *sv2; FETCH_HINTSK_INTO(SHIF2, &sv); if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVAV))) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'} not an arrayref: %"SVf, MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIF2, SVfARG(sv)); } shift_types = (AV *)sv2; } if (tix < 0 || tix > av_len(shift_types)) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: tix [%ld] out of range [%ld]", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (long)tix, (long)(av_len(shift_types) + 1)); } ptype = av_fetch(shift_types, tix, 0); if (!ptype) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: tix [%ld] doesn't exist", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (long)tix); } type = *ptype; if (!sv_isobject(type)) { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: tix [%ld] is not an object (%"SVf")", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (long)tix, SVfARG(type)); } } spv_push(&(*ppspec)->shift, sentinel_mortalize(**ppsen, newSVpvn_utf8(v_start, v_end - v_start, TRUE)), type); if (p < sv_p_end) { if (*p != ' ') { Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: expected ' ', found '%.*s'", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (int)(sv_p_end - p), p); } p++; } } } FETCH_HINTSK_INTO(ATTRS, &sv); SvSetSV((*ppspec)->attrs, sv); FETCH_HINTSK_INTO(INSTL, &sv); if (SvTRUE(sv)) { assert(SvROK(sv) || !(isDIGIT(*SvPV_nolen(sv)))); (*ppspec)->install_sub = sv; } } #undef FETCH_HINTSK_INTO return TRUE; } static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { Sentinel *psen; KWSpec *pspec; int ret; if (kw_flags_enter(aTHX_ &psen, keyword_ptr, keyword_len, &pspec)) { /* scope was entered, 'psen' and 'pspec' are initialized */ ret = parse_fun(aTHX_ *psen, op_ptr, keyword_ptr, keyword_len, pspec); FREETMPS; LEAVE; } else { /* not one of our keywords, no allocation done */ ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); } return ret; } /* https://rt.perl.org/Public/Bug/Display.html?id=132413 */ #ifndef wrap_keyword_plugin #define wrap_keyword_plugin(A, B) S_wrap_keyword_plugin(aTHX_ A, B) static void S_wrap_keyword_plugin(pTHX_ Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p) { PERL_UNUSED_CONTEXT; if (*old_plugin_p) { return; } MUTEX_LOCK(&PL_op_mutex); if (!*old_plugin_p) { *old_plugin_p = PL_keyword_plugin; PL_keyword_plugin = new_plugin; } MUTEX_UNLOCK(&PL_op_mutex); } #endif static void my_boot(pTHX) { HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK)); newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK)); newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS)); newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS)); newCONSTSUB(stash, "FLAG_INVOCANT", newSViv(FLAG_INVOCANT)); newCONSTSUB(stash, "FLAG_NAMED_PARAMS", newSViv(FLAG_NAMED_PARAMS)); newCONSTSUB(stash, "FLAG_TYPES_OK", newSViv(FLAG_TYPES_OK)); newCONSTSUB(stash, "FLAG_CHECK_TARGS", newSViv(FLAG_CHECK_TARGS)); newCONSTSUB(stash, "FLAG_RUNTIME", newSViv(FLAG_RUNTIME)); newCONSTSUB(stash, "HINTK_CONFIG", newSVpvs(HINTK_CONFIG)); newCONSTSUB(stash, "HINTSK_FLAGS", newSVpvs(HINTSK_FLAGS)); newCONSTSUB(stash, "HINTSK_SHIFT", newSVpvs(HINTSK_SHIFT)); newCONSTSUB(stash, "HINTSK_SHIF2", newSVpvs(HINTSK_SHIF2)); newCONSTSUB(stash, "HINTSK_ATTRS", newSVpvs(HINTSK_ATTRS)); newCONSTSUB(stash, "HINTSK_REIFY", newSVpvs(HINTSK_REIFY)); newCONSTSUB(stash, "HINTSK_INSTL", newSVpvs(HINTSK_INSTL)); wrap_keyword_plugin(my_keyword_plugin, &next_keyword_plugin); } #ifndef assert_ #ifdef DEBUGGING #define assert_(X) assert(X), #else #define assert_(X) #endif #endif #ifndef gv_method_changed #define gv_method_changed(GV) ( \ assert_(isGV_with_GP(GV)) \ GvREFCNT(GV) > 1 \ ? (void)PL_sub_generation++ \ : mro_method_changed_in(GvSTASH(GV)) \ ) #endif WARNINGS_RESET MODULE = Function::Parameters PACKAGE = Function::Parameters PREFIX = fp_ PROTOTYPES: ENABLE UV fp__cv_root(sv) SV *sv PREINIT: CV *xcv; HV *hv; GV *gv; CODE: xcv = sv_2cv(sv, &hv, &gv, 0); RETVAL = PTR2UV(xcv ? CvROOT(xcv) : NULL); OUTPUT: RETVAL void fp__defun(name, body) SV *name CV *body PREINIT: GV *gv; CV *xcv; CODE: assert(SvTYPE(body) == SVt_PVCV); gv = gv_fetchsv(name, GV_ADDMULTI, SVt_PVCV); xcv = GvCV(gv); if (xcv) { if (!GvCVGEN(gv) && (CvROOT(xcv) || CvXSUB(xcv)) && ckWARN(WARN_REDEFINE)) { Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Subroutine %"SVf" redefined", SVfARG(name)); } SvREFCNT_dec_NN(xcv); } GvCVGEN(gv) = 0; GvASSUMECV_on(gv); if (GvSTASH(gv)) { gv_method_changed(gv); } GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(body)); CvGV_set(body, gv); CvANON_off(body); BOOT: my_boot(aTHX); Function-Parameters-2.002004/README0000664000175000017500000000242614454414615015513 0ustar maukemaukeNAME Function::Parameters - define functions and methods with parameter lists ("subroutine signatures") INSTALLATION To download and install this module, use your favorite CPAN client, e.g. "cpan": cpan Function::Parameters Or "cpanm": cpanm Function::Parameters To do it manually, run the following commands (after downloading and unpacking the tarball): perl Makefile.PL make make test make install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the "perldoc" command. perldoc Function::Parameters You can also look for information at . To see a list of open bugs, visit . To report a new bug, send an email to "bug-Function-Parameters [at] rt.cpan.org". COPYRIGHT & LICENSE Copyright (C) 2010-2014, 2017, 2023 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See for more information. Function-Parameters-2.002004/lib/0000755000175000017500000000000014454414615015373 5ustar maukemaukeFunction-Parameters-2.002004/lib/Function/0000755000175000017500000000000014454414615017160 5ustar maukemaukeFunction-Parameters-2.002004/lib/Function/Parameters.pm0000644000175000017500000014706414454413446021636 0ustar maukemaukepackage Function::Parameters; use v5.14.0; use warnings; use warnings::register; use Carp qw(croak confess); use Scalar::Util qw(blessed); sub _croak { my (undef, $file, $line) = caller 1; die @_, " at $file line $line.\n"; } use XSLoader; BEGIN { our $VERSION = '2.002004'; #$VERSION =~ s/-TRIAL[0-9]*\z//; XSLoader::load; } sub _warn_config_not_a_reference { warnings::warnif sprintf q{%s: $^H{'%s'} is not a reference; skipping: %s}, __PACKAGE__, HINTK_CONFIG, $^H{+HINTK_CONFIG}; } sub _assert_valid_identifier { my ($name, $with_dollar) = @_; my $bonus = $with_dollar ? '\$' : ''; $name =~ /\A${bonus}[^\W\d]\w*\z/ or confess qq{"$name" doesn't look like a valid identifier}; } sub _assert_valid_attributes { my ($attrs) = @_; $attrs =~ m{ \A \s*+ : \s*+ (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+ (?: (?: : \s*+ )? (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+ )*+ \z (?(DEFINE) (? [^\W\d] \w*+ ) (? \( [^()\\]*+ (?: (?: \\ . | (?¶m) ) [^()\\]*+ )*+ \) ) ) }sx or confess qq{"$attrs" doesn't look like valid attributes}; } sub _reify_type_moose { require Moose::Util::TypeConstraints; Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_[0]) } sub _malformed_type { my ($type, $msg) = @_; my $pos = pos $_[0]; substr $type, $pos, 0, ' <-- HERE '; croak "Malformed type: $msg marked by <-- HERE in '$type'"; } sub _reify_type_auto_parameterized { # (str, caller) $_[0] =~ /\G ( \w+ (?: :: \w+)* ) \s* /xgc or _malformed_type $_[0], "missing type name"; my $name = $1; $name = "$_[1]::$name" unless $name =~ /::/; my $fun = do { no strict 'refs'; defined &$name or croak "Undefined type name $name"; \&$name }; $_[0] =~ /\G \[ \s* /xgc or return $fun; my @args; until ($_[0] =~ /\G \] \s* /xgc) { $_[0] =~ /\G , \s* /xgc or _malformed_type $_[0], "missing ',' or ']'" if @args; push @args, &_reify_type_auto_union; } sub { $fun->([map $_->(), @args]) } } sub _reify_type_auto_term { # (str, caller) my $compl = 0; while ($_[0] =~ /\G ~ \s* /xgc) { $compl++; } my $inner; if ($_[0] =~ /\G \( \s* /xgc) { $inner = &_reify_type_auto_union; $_[0] =~ /\G \) \s* /xgc or _malformed_type $_[0], "missing ')'"; } else { $inner = &_reify_type_auto_parameterized; } !$compl ? $inner : sub { my $t = $inner->(); for my $i (1 .. $compl) { $t = ~$t; } $t } } sub _reify_type_auto_alternative { # (str, caller) my $fun = &_reify_type_auto_term; while ($_[0] =~ m!\G / \s* !xgc) { my $right = &_reify_type_auto_term; my $left = $fun; $fun = sub { $left->() / $right->() }; } $fun } sub _reify_type_auto_intersection { # (str, caller) my $fun = &_reify_type_auto_alternative; while ($_[0] =~ /\G & \s* /xgc) { my $right = &_reify_type_auto_alternative; my $left = $fun; $fun = sub { $left->() & $right->() }; } $fun } sub _reify_type_auto_union { # (str, caller) my $fun = &_reify_type_auto_intersection; while ($_[0] =~ /\G \| \s* /xgc) { my $right = &_reify_type_auto_intersection; my $left = $fun; $fun = sub { $left->() | $right->() }; } $fun } sub _reify_type_auto { my ($type) = @_; my $caller = caller; $type =~ /\G \s+ /xgc; my $tfun = _reify_type_auto_union $type, $caller; $type =~ /\G \z/xgc or _malformed_type $type, "trailing garbage"; $tfun->() } sub _delete_default { my ($href, $key, $default) = @_; exists $href->{$key} ? delete $href->{$key} : $default } sub _find_or_add_idx { my ($array, $x) = @_; my $index; for my $i (0 .. $#$array) { if ($array->[$i] == $x) { $index = $i; last; } } unless (defined $index) { $index = @$array; push @$array, $x; } $index } my %type_map = ( function_strict => {}, function_lax => { defaults => 'function_strict', strict => 0, }, function => { defaults => 'function_strict' }, method_strict => { defaults => 'function_strict', attributes => ':method', shift => '$self', invocant => 1, }, method_lax => { defaults => 'method_strict', strict => 0, }, method => { defaults => 'method_strict' }, classmethod_strict => { defaults => 'method_strict', shift => '$class', }, classmethod_lax => { defaults => 'classmethod_strict', strict => 0, }, classmethod => { defaults => 'classmethod_strict' }, around => { defaults => 'method', name => 'required', install_sub => 'around', shift => ['$orig', '$self'], runtime => 1, }, ( map +( $_ => { defaults => 'method', name => 'required', install_sub => $_, runtime => 1, } ), qw( before after augment override ), ), ); my %import_map = ( fun => 'function', ( map +($_ => $_), qw( method classmethod before after around augment override ) ), ':strict' => { fun => 'function_strict', method => 'method_strict', }, ':lax' => { fun => 'function_lax', method => 'method_lax', }, ':std' => [qw(fun method)], ':modifiers' => [qw( before after around augment override )], ); for my $v (values %import_map) { if (ref $v eq 'ARRAY') { $v = { map +($_ => $import_map{$_} || die "Internal error: $v => $_"), @$v }; } } sub import { my $class = shift; my %imports; @_ = qw(:std) if !@_; for my $item (@_) { my $part; if (ref $item) { $part = $item; } else { my $type = $import_map{$item} or croak qq{"$item" is not exported by the $class module}; $part = ref $type ? $type : { $item => $type }; } @imports{keys %$part} = values %$part; } my %spec; for my $name (sort keys %imports) { _assert_valid_identifier $name; my $proto_type = $imports{$name}; $proto_type = {defaults => $proto_type} unless ref $proto_type; my %type = %$proto_type; while (my $defaults = delete $type{defaults}) { my $base = $type_map{$defaults} or confess qq["$defaults" doesn't look like a valid type (one of ${\join ', ', sort keys %type_map})]; %type = (%$base, %type); } if (exists $type{strict}) { $type{check_argument_count} ||= $type{strict}; delete $type{strict}; } my %clean; $clean{name} = delete $type{name} // 'optional'; $clean{name} =~ /\A(?:optional|required|prohibited)\z/ or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)]; $clean{attrs} = delete $type{attributes} // ''; _assert_valid_attributes $clean{attrs} if $clean{attrs}; if (!exists $type{reify_type}) { $clean{reify_type} = \&_reify_type_auto; } else { my $rt = delete $type{reify_type} // '(undef)'; if (!ref $rt) { $rt = $rt eq 'auto' ? \&_reify_type_auto : $rt eq 'moose' ? \&_reify_type_moose : confess qq{"$rt" isn't a known predefined type reifier}; } elsif (ref $rt ne 'CODE') { confess qq{"$rt" doesn't look like a type reifier}; } $clean{reify_type} = $rt; } if (!exists $type{install_sub}) { $clean{install_sub} = ''; } else { my $is = delete $type{install_sub}; if (!ref $is) { _assert_valid_identifier $is; } elsif (ref $is ne 'CODE') { confess qq{"$is" doesn't look like a sub installer}; } $clean{install_sub} = $is; } $clean{shift} = do { my $shift = delete $type{shift} // []; $shift = [$shift] if !ref $shift; my $str = ''; my @shifty_types; for my $item (@$shift) { my ($name, $type); if (ref $item) { @$item == 2 or confess "A 'shift' item must have 2 elements, not " . @$item; ($name, $type) = @$item; } else { $name = $item; } _assert_valid_identifier $name, 1; $name eq '$_' and confess q[Using "$_" as a parameter is not supported]; $str .= $name; if (defined $type) { blessed($type) or confess "${name}'s type must be an object, not $type"; my $index = _find_or_add_idx \@shifty_types, $type; $str .= "/$index"; } $str .= ' '; } $clean{shift_types} = \@shifty_types; $str }; $clean{default_arguments} = _delete_default \%type, 'default_arguments', 1; $clean{named_parameters} = _delete_default \%type, 'named_parameters', 1; $clean{types} = _delete_default \%type, 'types', 1; $clean{invocant} = _delete_default \%type, 'invocant', 0; $clean{runtime} = _delete_default \%type, 'runtime', 0; $clean{check_argument_count} = _delete_default \%type, 'check_argument_count', 1; $clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 1; %type and confess "Invalid keyword property: @{[sort keys %type]}"; $spec{$name} = \%clean; } my %config = %{$^H{+HINTK_CONFIG} // {}}; for my $kw (keys %spec) { my $type = $spec{$kw}; my $flags = $type->{name} eq 'prohibited' ? FLAG_ANON_OK : $type->{name} eq 'required' ? FLAG_NAME_OK : FLAG_ANON_OK | FLAG_NAME_OK ; $flags |= FLAG_DEFAULT_ARGS if $type->{default_arguments}; $flags |= FLAG_CHECK_NARGS if $type->{check_argument_count}; $flags |= FLAG_CHECK_TARGS if $type->{check_argument_types}; $flags |= FLAG_INVOCANT if $type->{invocant}; $flags |= FLAG_NAMED_PARAMS if $type->{named_parameters}; $flags |= FLAG_TYPES_OK if $type->{types}; $flags |= FLAG_RUNTIME if $type->{runtime}; $config{$kw} = { HINTSK_FLAGS, => $flags, HINTSK_SHIFT, => $type->{shift}, HINTSK_ATTRS, => $type->{attrs}, HINTSK_REIFY, => $type->{reify_type}, HINTSK_INSTL, => $type->{install_sub}, !@{$type->{shift_types}} ? () : ( HINTSK_SHIF2, => $type->{shift_types}, ), }; } $^H{+HINTK_CONFIG} = \%config; } sub unimport { my $class = shift; if (!@_) { delete $^H{+HINTK_CONFIG}; return; } my %config = %{$^H{+HINTK_CONFIG}}; delete @config{@_}; $^H{+HINTK_CONFIG} = \%config; } our %metadata; sub _register_info { my ( $key, $declarator, $shift, $positional_required, $positional_optional, $named_required, $named_optional, $slurpy, $slurpy_type, ) = @_; my $info = { declarator => $declarator, shift => $shift, positional_required => $positional_required, positional_optional => $positional_optional, named_required => $named_required, named_optional => $named_optional, slurpy => defined $slurpy ? [$slurpy, $slurpy_type] : undef, }; $metadata{$key} = $info; } sub _mkparam1 { my ($pair) = @_; my ($v, $t) = @{$pair || []} or return undef; Function::Parameters::Param->new( name => $v, type => $t, ) } sub _mkparams { my @r; while (my ($v, $t) = splice @_, 0, 2) { push @r, Function::Parameters::Param->new( name => $v, type => $t, ); } \@r } sub info { my ($func) = @_; my $key = _cv_root $func or return undef; my $info = $metadata{$key} or return undef; require Function::Parameters::Info; Function::Parameters::Info->new( keyword => $info->{declarator}, nshift => $info->{shift}, slurpy => _mkparam1($info->{slurpy}), ( map +("_$_" => _mkparams @{$info->{$_}}), qw( positional_required positional_optional named_required named_optional ) ) ) } 'ok' __END__ =encoding UTF-8 =for highlighter language=perl =head1 NAME Function::Parameters - define functions and methods with parameter lists ("subroutine signatures") =head1 SYNOPSIS use Function::Parameters; # plain function fun foo($x, $y, $z = 5) { return $x + $y + $z; } print foo(1, 2), "\n"; # 8 # method with implicit $self method bar($label, $n) { return "$label: " . ($n * $self->scale); } # named arguments: order doesn't matter in the call fun create_point(:$x, :$y, :$color) { print "creating a $color point at ($x, $y)\n"; } create_point( color => "red", x => 10, y => 5, ); package Derived { use Function::Parameters qw(:std :modifiers); use Moo; extends 'Base'; has 'go_big' => ( is => 'ro', ); # "around" method with implicit $orig and $self around size() { return $self->$orig() * 2 if $self->go_big; return $self->$orig(); } } =head1 DESCRIPTION This module provides two new keywords, C and C, for defining functions and methods with parameter lists. At minimum this saves you from having to unpack C<@_> manually, but this module can do much more for you. The parameter lists provided by this module are similar to the C feature available in perl v5.20+. However, this module supports all perl versions starting from v5.14 and it offers far more features than core signatures. The downside is that you need a C compiler if you want to install it from source, as it uses Perl's L API in order to work reliably without requiring a source filter. =head2 Default functionality This module is a lexically scoped pragma: If you C inside a block or file, the keywords won't be available outside of that block or file. You can also disable C within a block: { no Function::Parameters; # disable all keywords ... } Or explicitly list the keywords you want to disable: { no Function::Parameters qw(method); # 'method' is a normal identifier here ... } You can also explicitly list the keywords you want to enable: use Function::Parameters qw(fun); # provides 'fun' but not 'method' use Function::Parameters qw(method); # provides 'method' but not 'fun' =head3 Simple parameter lists By default you get two keywords, C and C (but see L below). C is very similar to C. You can use it to define both named and anonymous functions: fun left_pad($str, $n) { return sprintf '%*s', $n, $str; } print left_pad("hello", 10), "\n"; my $twice = fun ($x) { $x * 2 }; print $twice->(21), "\n"; In the simplest case the parameter list is just a comma-separated list of zero or more scalar variables (enclosed in parentheses, following the function name, if any). C automatically validates the arguments your function is called with. If the number of arguments doesn't match the parameter list, an exception is thrown. Apart from that, the parameter variables are defined and initialized as if by: sub left_pad { sub left_pad; my ($str, $n) = @_; ... } In particular, C<@_> is still available in functions defined by C and holds the original argument list. The inner C declaration is intended to illustrate that the name of the function being defined is in scope in its own body, meaning you can call it recursively without having to use parentheses: fun fac($n) { return 1 if $n < 2; return $n * fac $n - 1; } In a normal C the last line would have had to be written C. C is almost the same as C but automatically creates a C<$self> variable as the first parameter (which is removed from C<@_>): method foo($x, $y) { ... } # works like: sub foo :method { my $self = shift; my ($x, $y) = @_; ... } As you can see, the C<:method> attribute is also added automatically (see L for details). In some cases (e.g. class methods) C<$self> is not the best name for the invocant of the method. You can override it on a case-by-case basis by putting a variable name followed by a C<:> (colon) as the first thing in the parameter list: method new($class: $x, $y) { return bless { x => $x, y => $y }, $class; } Here the invocant is named C<$class>, not C<$self>. It looks a bit weird but still works the same way if the remaining parameter list is empty: method from_env($class:) { return $class->new($ENV{x}, $ENV{y}); } =head3 Default arguments (Most of the following examples use C only. Unless specified otherwise, everything applies to C as well.) You can make some arguments optional by giving them default values. fun passthrough($x, $y //= 42, $z = []) { return ($x, $y, $z); } In this example the first parameter C<$x> is required, but C<$y> and C<$z> are optional. passthrough('a', 'b', 'c', 'd') # error: Too many arguments passthrough('a', 'b', 'c') # returns ('a', 'b', 'c') passthrough('a', 'b', undef) # returns ('a', 'b', undef) passthrough('a', 'b') # returns ('a', 'b', []) passthrough('a', undef) # returns ('a', 42, []) passthrough('a', undef, 'c') # returns ('a', 42, 'c') passthrough('a') # returns ('a', 42, []) passthrough() # error: Too few arguments Default arguments specified with C<=> are evaluated whenever a corresponding real argument is not passed in by the caller. C counts as a real argument; you can't use the default value for parameter I and still pass a value for parameter I. Default arguments specified with C are evaluated whenever a corresponding real argument is not passed in or when that argument is C. That is, passing in C to a C parameter lets you explicitly request the default. Both C<=> and C default arguments can be mixed freely in the same parameter list. C<$z = []> means each call that doesn't pass a third argument gets a new array reference (they're not shared between calls). Default arguments are evaluated as part of the function body, allowing for silliness such as: fun weird($name = return "nope") { print "Hello, $name!\n"; return $name; } weird("Larry"); # prints "Hello, Larry!" and returns "Larry" weird(); # returns "nope" immediately; function body doesn't run Preceding parameters are in scope for default arguments: fun dynamic_default($x, $y = length $x) { return "$x/$y"; } dynamic_default("hello", 0) # returns "hello/0" dynamic_default("hello") # returns "hello/5" dynamic_default("abc") # returns "abc/3" If you just want to make a parameter optional without giving it a special value, write C<$param = undef>. There is a special shortcut syntax for this case: C<$param = undef> can also be written C<$param => (with no following expression). fun foo($x = undef, $y = undef, $z = undef) { # three arguments, all optional ... } fun foo($x=, $y=, $z=) { # shorter syntax, same meaning ... } Optional parameters must come at the end. It is not possible to have a required parameter after an optional one. =head3 Slurpy/rest parameters The last parameter of a function or method can be an array. This lets you slurp up any number of arguments the caller passes (0 or more). fun scale($factor, @values) { return map { $_ * $factor } @values; } scale(10, 1 .. 4) # returns (10, 20, 30, 40) scale(10) # returns () You can also use a hash, but then the number of arguments has to be even. =head3 Named parameters As soon as your functions take more than three arguments, it gets harder to keep track of which argument means what: foo($handle, $w, $h * 2 + 15, 1, 24, 'icon'); # what do these arguments mean? C offers an alternative for these kinds of situations in the form of named parameters. Unlike the parameters described previously, which are identified by position, these parameters are identified by name: fun create_point(:$x, :$y, :$color) { ... } # Case 1 create_point( x => 50, y => 50, color => 0xff_00_00, ); To create a named parameter, put a C<:> (colon) in front of it in the parameter list. When the function is called, the arguments have to be supplied in the form of a hash initializer (a list of alternating keys/values). As with a hash, the order of key/value pairs doesn't matter (except in the case of duplicate keys, where the last occurrence wins): # Case 2 create_point( color => 0xff_00_00, x => 50, y => 50, ); # Case 3 create_point( x => 200, color => 0x12_34_56, color => 0xff_00_00, x => 50, y => 50, ); Case 1, Case 2, and Case 3 all mean the same thing. As with positional parameters, you can make named parameters optional by supplying a L with C<=> or C: # use default if no 'color' key exists in the argument list fun create_point(:$x, :$y, :$color = 0x00_00_00) { ... } create_point(x => 0, y => 64) # color => 0x00_00_00 is implicit Or: # use default if 'color' value is not defined fun create_point(:$x, :$y, :$color //= 0x00_00_00) { ... } create_point(x => 0, y => 64, color => undef) # color => 0x00_00_00 is implicit If you want to accept any key/value pairs, you can add a L (hashes are particularly useful): fun accept_all_keys(:$name, :$age, %rest) { ... } accept_all_keys( age => 42, gender => 2, name => "Jamie", marbles => [], ); # $name = "Jamie"; # $age = 42; # %rest = ( # gender => 2, # marbles => [], # ); You can combine positional and named parameters, but all positional parameters have to come first: method output( $data, :$handle = $self->output_handle, :$separator = $self->separator, :$quote_fields = 0, ) { ... } $obj->output(["greetings", "from", "space"]); $obj->output( ["a", "random", "example"], quote_fields => 1, separator => ";", ); =head3 Unnamed parameters If your function doesn't use a particular parameter at all, you can omit its name and just write a sigil in the parameter list: register_callback('click', fun ($target, $) { ... }); Here we're calling a hypothetical C function that registers our coderef to be called in response to a C event. It will pass two arguments to the click handler, but the coderef only cares about the first one (C<$target>). The second parameter doesn't even get a name (just a sigil, C<$>). This marks it as unused. This case typically occurs when your functions have to conform to an externally imposed interface, e.g. because they're called by someone else. It can happen with callbacks or methods that don't need all of the arguments they get. You can use unnamed L to accept and ignore all following arguments. In particular, C is a lot like C in that it accepts and ignores any number of arguments (and just leaves them in C<@_>). =head3 Type constraints It is possible to automatically check the types of arguments passed to your function. There are two ways to do this. =over =item 1. use Types::Standard qw(Str Int ArrayRef); fun foo(Str $label, ArrayRef[Int] $counts) { ... } In this variant you simply put the name of a type in front of a parameter. The way this works is that C parses the type using a restrictive set of rules: =over =item * A I is a simplified expression that only uses C<(>, C<)>, C<|>, C<&>, C, C<~>, and simple types, except the first character cannot be C<(> (see syntax #2 below). The relative operator precedence is as in Perl; see L. =item * C<(> C<)> can be used for grouping, but have no effect otherwise. =item * C<~> (highest precedence) is a unary prefix operator meant for complementary types (as provided by L). =item * C is a binary infix operator meant for alternative types (as provided by L). =item * C<&> is a binary infix operator meant for intersection types (as provided by L). =item * C<|> (lowest precedence) is a binary infix operator meant for union types (as provided by basically everyone doing type constraints, including L (see L and L) and L). =item * A I is an identifier, optionally followed by a list of one or more types, separated by C<,> (comma), enclosed in C<[> C<]> (square brackets). =back C then resolves simple types by looking for functions of the same name in your current package. A type specification like C ends up running the Perl code C (at compile time, while the function definition is being processed). In other words, C doesn't support any types natively; it simply uses whatever is in scope. You don't have to define these type constraints yourself; you can import them from a type library such as L or L. The only requirement is that the returned value (here referred to as C<$tc>, for "type constraint") is an object that provides C<< $tc->check($value) >> and C<< $tc->get_message($value) >> methods. C is called to determine whether a particular value is valid; it should return a true or false value. C is called on values that fail the C test; it should return a string that describes the error. Type constraints can optionally support two additional features: =over =item * Coercion. If the C<< $tc->has_coercion >> method exists and returns a true value, every incoming argument is automatically transformed by C<< $value = $tc->coerce($value) >> before being type-checked. =item * Inlining. If the C<< $tc->can_be_inlined >> method exists and returns a true value, the call to C<< $tc->check($value) >> is automatically replaced by the code returned (in string form) from C<< $tc->inline_check('$value') >>. (For compatibility with L, if C<$tc> has no C method, C<< $tc->_inline_check('$value') >> is used instead.) =back =item 2. my ($my_type, $some_other_type); BEGIN { $my_type = Some::Constraint::Class->new; $some_other_type = Some::Other::Class->new; } fun foo(($my_type) $label, ($some_other_type) $counts) { ... } In this variant you enclose an arbitrary Perl expression in C<(> C<)> (parentheses) and put it in front of a parameter. This expression is evaluated at compile time and must return a type constraint object as described above. (If you use variables here, make sure they're defined at compile time.) =back =head3 Method modifiers C has support for method modifiers as provided by L or L. They're not exported by default, so you have to say use Function::Parameters qw(:modifiers); to get them. This line gives you method modifiers I; C and C are not defined. To get both the standard keywords and method modifiers, you can either write two C lines: use Function::Parameters; use Function::Parameters qw(:modifiers); or explicitly list the keywords you want: use Function::Parameters qw(fun method :modifiers); or add the C<:std> import tag (which gives you the default import behavior): use Function::Parameters qw(:std :modifiers); This defines the following additional keywords: C, C, C, C, C. These work mostly like C, but they don't install the function into your package themselves. Instead they invoke whatever C, C, C, C, or C function (respectively) is in scope to do the job. before foo($x, $y, $z) { ... } works like &before('foo', method ($x, $y, $z) { ... }); C, C, and C work the same way. C is slightly different: Instead of shifting off the first element of C<@_> into C<$self> (as C does), it shifts off I values: around foo($x, $y, $z) { ... } works like &around('foo', sub :method { my $orig = shift; my $self = shift; my ($x, $y, $z) = @_; ... }); (except you also get the usual C features such as checking the number of arguments, etc). C<$orig> and C<$self> both count as invocants and you can override their names like this: around foo($original, $object: $x, $y, $z) { # $original is a reference to the wrapped method; # $object is the object we're being called on ... } If you use C<:> to pick your own invocant names in the parameter list of C, you must specify exactly two variables. These modifiers also differ from C and C (and C) in that they require a function name (there are no anonymous method modifiers) and they take effect at runtime, not compile time. When you say C, the C function is defined right after the closing C<}> of the function body is parsed. But with e.g. C, the declaration becomes a normal function call (to the C function in the current package), which is performed at runtime. =head3 Prototypes and attributes You can specify attributes (see L) for your functions using the usual syntax: fun deref($x) :lvalue { ${$x} } my $silly; deref(\$silly) = 42; To specify a prototype (see L), use the C attribute: fun mypush($aref, @values) :prototype(\@@) { push @{$aref}, @values; } =head3 Introspection The function C lets you introspect parameter lists at runtime. It is not exported, so you have to call it by its full name. It takes a reference to a function and returns either C (if it knows nothing about the function) or an object that describes the parameter list of the given function. See L for details. =head2 Customizing and extending =head3 Wrapping C Due to its nature as a lexical pragma, importing from C always affects the scope that is currently being compiled. If you want to write a wrapper module that enables C automatically, just call C<< Function::Parameters->import >> from your own C method (and C<< Function::Parameters->unimport >> from your C, as required). =head3 Gory details of importing At the lowest layer C takes a list of one or more hash references. Each key is a keyword to be defined as specified by the corresponding value, which must be another hash reference containing configuration options. use Function::Parameters { keyword_1 => { ... }, keyword_2 => { ... }, }, { keyword_3 => { ... }, }; If you don't specify a particular option, its default value is used. The available configuration options are: =over =item C (string) The attributes that every function declared with this keyword should have (in the form of source code, with a leading C<:>). Default: nothing =item C (boolean) Whether functions declared with this keyword should check how many arguments they are called with. If false, omitting a required argument sets it to C and excess arguments are silently ignored. If true, an exception is thrown if too few or too many arguments are passed. Default: C<1> =item C (boolean) Whether functions declared with this keyword should check the types of the arguments they are called with. If false, L are parsed but silently ignored. If true, an exception is thrown if an argument fails a type check. Default: C<1> =item C (boolean) Whether functions declared with this keyword should allow default arguments in their parameter list. If false, L are a compile-time error. Default: C<1> =item C (sub name or reference) If this is set, named functions declared with this keyword are not entered into the symbol table directly. Instead the subroutine specified here (by name or reference) is called with two arguments, the name of the function being declared and a reference to its body. Default: nothing =item C (boolean) Whether functions declared with this keyword should allow explicitly specifying invocant(s) at the beginning of the parameter list (as in C<($invocant: ...)> or C<($invocant1, $invocant2, $invocant3: ...)>). Default: 0 =item C (string) There are three possible values for this option. C<'required'> means functions declared with this keyword must have a name. C<'prohibited'> means specifying a name is not allowed. C<'optional'> means this keyword can be used for both named and anonymous functions. Default: C<'optional'> =item C (boolean) Whether functions declared with this keyword should allow named parameters. If false, L are a compile-time error. Default: C<1> =item C (coderef or C<'auto'> or C<'moose'>) The code reference used to resolve L in functions declared with this keyword. It is called once for each type constraint that doesn't use the C<( EXPR )> syntax, with one argument, the text of the type in the parameter list (e.g. C<'ArrayRef[Int]'>). The package the function declaration is in is available through L|perlfunc/caller EXPR>. The only requirement is that the returned value (here referred to as C<$tc>, for "type constraint") is an object that provides C<< $tc->check($value) >> and C<< $tc->get_message($value) >> methods. C is called to determine whether a particular value is valid; it should return a true or false value. C is called on values that fail the C test; it should return a string that describes the error. Type constraints can optionally support two additional features: =over =item * Coercion. If the C<< $tc->has_coercion >> method exists and returns a true value, every incoming argument is automatically transformed by C<< $value = $tc->coerce($value) >> before being type-checked. =item * Inlining. If the C<< $tc->can_be_inlined >> method exists and returns a true value, the call to C<< $tc->check($value) >> is automatically replaced by the code returned (in string form) from C<< $tc->inline_check('$value') >>. (For compatibility with L, if C<$tc> has no C method, C<< $tc->_inline_check('$value') >> is used instead.) =back Instead of a code reference you can also specify one of two strings. C<'auto'> stands for a built-in type reifier that treats identifiers as subroutine names, C<[> C<]> as an array reference, C<~> as bitwise complement, C as division, C<&> as bitwise and, and C<|> as bitwise or. In other words, it parses and executes type constraints (mostly) as if they had been Perl source code. C<'moose'> stands for a built-in type reifier that loads L and just forwards to L|Moose::Util::TypeConstraints/find_or_create_isa_type_constraint($type_name)>. Default: C<'auto'> =item C (boolean) Whether functions declared with this keyword should be installed into the symbol table at runtime. If false, named functions are defined (or their L|/C> is invoked if specified) immediately after their declaration is parsed (as with L|perlfunc/sub NAME BLOCK>). If true, function declarations become normal statements that only take effect at runtime (similar to C<*foo = sub { ... };> or C<< $install_sub->('foo', sub { ... }); >>, respectively). Default: C<0> =item C (string or arrayref) In its simplest form, this is the name of a variable that acts as the default invocant (a required leading argument that is removed from C<@_>) for all functions declared with this keyword (e.g. C<'$self'> for methods). You can also set this to an array reference of strings, which lets you specify multiple default invocants, or even to an array reference of array references of the form C<[ $name, $type ]> (where C<$name> is the variable name and C<$type> is a L), which lets you specify multiple default invocants with type constraints. If you define any default invocants here and also allow individual declarations to override the default (with C<< invocant => 1 >>), the number of overridden invocants must match the default. For example, C has a default invocant of C<$self>, so C is invalid because it tries to define two invocants. Default: C<[]> (meaning no invocants) =item C (boolean) Whether functions declared with this keyword should do "strict" checks on their arguments. Currently setting this simply sets L|/C> to the same value with no other effects. Default: nothing =item C (boolean) Whether functions declared with this keyword should allow type constraints in their parameter lists. If false, trying to use L is a compile-time error. Default: C<1> =back You can get the same effect as C by saying: use Function::Parameters { fun => { # 'fun' uses default settings only }, method => { attributes => ':method', shift => '$self', invocant => 1, # the rest is defaults }, }; =head3 Configuration bundles Because specifying all these configuration options from scratch each time is a lot of writing, C offers configuration bundles in the form of special strings. These strings can be used to replace a configuration hash completely or as the value of the C pseudo-option within a configuration hash. The latter lets you use the configuration bundle behind the string to provide defaults and tweak them with your own settings. The following bundles are available: =over =item C Equivalent to C<{}>, i.e. all defaults. =item C Equivalent to: { defaults => 'function_strict', strict => 0, } i.e. just like L|/C> but with L|/C> checks turned off. =item C Equivalent to C. This is what the default C keyword actually uses. (In version 1 of this module, C was equivalent to C.) =item C Equivalent to: { defaults => 'function_strict', attributes => ':method', shift => '$self', invocant => 1, } =item C Equivalent to: { defaults => 'method_strict', strict => 0, } i.e. just like L|/C> but with L|/C> checks turned off. =item C Equivalent to C. This is what the default C keyword actually uses. (In version 1 of this module, C was equivalent to C.) =item C Equivalent to: { defaults => 'method_strict', shift => '$class', } i.e. just like L|/C> but the implicit first parameter is called C<$class>, not C<$self>. =item C Equivalent to: { defaults => 'classmethod_strict', strict => 0, } i.e. just like L|/C> but with L|/C> checks turned off. =item C Equivalent to C. This is currently not used anywhere within C. =item C Equivalent to: { defaults => 'method', install_sub => 'around', shift => ['$orig', '$self'], runtime => 1, name => 'required', } i.e. just like L|/C> but with a custom installer (C<'around'>), two implicit first parameters, only taking effect at runtime, and a method name is required. =item C Equivalent to: { defaults => 'method', install_sub => 'before', runtime => 1, name => 'required', } i.e. just like L|/C> but with a custom installer (C<'before'>), only taking effect at runtime, and a method name is required. =item C Equivalent to: { defaults => 'method', install_sub => 'after', runtime => 1, name => 'required', } i.e. just like L|/C> but with a custom installer (C<'after'>), only taking effect at runtime, and a method name is required. =item C Equivalent to: { defaults => 'method', install_sub => 'augment', runtime => 1, name => 'required', } i.e. just like L|/C> but with a custom installer (C<'augment'>), only taking effect at runtime, and a method name is required. =item C Equivalent to: { defaults => 'method', install_sub => 'override', runtime => 1, name => 'required', } i.e. just like L|/C> but with a custom installer (C<'override'>), only taking effect at runtime, and a method name is required. =back You can get the same effect as C by saying: use Function::Parameters { fun => { defaults => 'function' }, method => { defaults => 'method' }, }; or: use Function::Parameters { fun => 'function', method => 'method', }; =head3 Import tags In addition to hash references you can also use special strings in your import list. The following import tags are available: =over =item C<'fun'> Equivalent to C<< { fun => 'function' } >>. =item C<'method'> Equivalent to C<< { method => 'method' } >>. =item C<'classmethod'> Equivalent to C<< { classmethod => 'classmethod' } >>. =item C<'before'> Equivalent to C<< { before => 'before' } >>. =item C<'after'> Equivalent to C<< { after => 'after' } >>. =item C<'around'> Equivalent to C<< { around => 'around' } >>. =item C<'augment'> Equivalent to C<< { augment => 'augment' } >>. =item C<'override'> Equivalent to C<< { override => 'override' } >>. =item C<':strict'> Equivalent to C<< { fun => 'function_strict', method => 'method_strict' } >> but that's just the default behavior anyway. =item C<':lax'> Equivalent to C<< { fun => 'function_lax', method => 'method_lax' } >>, i.e. it provides C and C keywords that define functions that don't check their arguments. =item C<':std'> Equivalent to C<< 'fun', 'method' >>. This is what's used by default: use Function::Parameters; is the same as: use Function::Parameters qw(:std); =item C<':modifiers'> Equivalent to C<< 'before', 'after', 'around', 'augment', 'override' >>. =back For example, when you say use Function::Parameters qw(:modifiers); C<:modifiers> is an import tag that L> use Function::Parameters qw(before after around augment override); Each of those is another import tag. Stepping through the first one: use Function::Parameters qw(before); is L>: use Function::Parameters { before => 'before' }; This says to define the keyword C according to the L|/C>: use Function::Parameters { before => { defaults => 'method', install_sub => 'before', runtime => 1, name => 'required', }, }; The C<< defaults => 'method' >> part L the contents of the L configuration bundle|/C> (which is the same as L|/C>): use Function::Parameters { before => { defaults => 'function_strict', attributes => ':method', shift => '$self', invocant => 1, install_sub => 'before', runtime => 1, name => 'required', }, }; This in turn uses the L configuration bundle|/C> (which is empty because it consists of default values only): use Function::Parameters { before => { attributes => ':method', shift => '$self', invocant => 1, install_sub => 'before', runtime => 1, name => 'required', }, }; But if we wanted to be completely explicit, we could write this as: use Function::Parameters { before => { check_argument_count => 1, check_argument_types => 1, default_arguments => 1, named_parameters => 1, reify_type => 'auto', types => 1, attributes => ':method', shift => '$self', invocant => 1, install_sub => 'before', runtime => 1, name => 'required', }, }; =head2 Incompatibilites with version 1 of C =over =item * Version 1 defaults to lax mode (no argument checks). To get the same behavior on both version 1 and version 2, explicitly write either C (the new default) or C (the old default). (Or write C to trigger an error if an older version of C is loaded.) =item * Parameter lists used to be optional. The syntax C would accept any number of arguments. This syntax has been removed; you now have to write C to accept (and ignore) all arguments. On the other hand, if you meant for the function to take no arguments, write C. =item * There used to be a shorthand syntax for prototypes: Using C<:(...)> (i.e. an attribute with an empty name) as the first attribute was equivalent to C<:prototype(...)>. This syntax has been removed. =item * The default type reifier used to be hardcoded to use L (as in C<< reify_type => 'moose' >>). This has been changed to use whatever type functions are in scope (C<< reify_type => 'auto' >>). =item * Type reifiers used to see the wrong package in L|perlfunc/caller EXPR>. As a workaround the correct calling package used to be passed as a second argument. This problem has been fixed and the second argument has been removed. (Technically this is a core perl bug (L) that wasn't so much fixed as worked around in C.) If you want your type reifier to be compatible with both versions, you can do this: sub my_reifier { my ($type, $package) = @_; $package //= caller; ... } Or using C itself: fun my_reifier($type, $package = caller) { ... } =back =head1 DIAGNOSTICS =over =item Function::Parameters: $^H{'Function::Parameters/config'} is not a reference; skipping: HASH(%s) Function::Parameters relies on being able to put references in C<%^H> (the lexical compilation context) and pull them out again at compile time. You may see the warning above if what used to be a reference got turned into a plain string. In this case, Function::Parameters gives up and automatically disables itself, as if by C. You can disable the warning in a given scope by saying C; see L. Currently the only case I'm aware of where this happens with core perl is embedded code blocks in regexes that are compiled at runtime (in a scope where L|re> is active): use strict; use warnings; use Function::Parameters; use re 'eval'; my $code = '(?{ print "embedded code\n"; })'; my $regex = qr/$code/; In my opinion, this is a bug in perl: L. This case used to be a hard error in versions 2.001005 and before of this module. =back =begin :README =head1 INSTALLATION To download and install this module, use your favorite CPAN client, e.g. L|cpan>: =for highlighter language=sh cpan Function::Parameters Or L|cpanm>: cpanm Function::Parameters To do it manually, run the following commands (after downloading and unpacking the tarball): perl Makefile.PL make make test make install =end :README =head1 SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the L|perldoc> command. =for highlighter language=sh perldoc Function::Parameters You can also look for information at L. To see a list of open bugs, visit L. To report a new bug, send an email to C. =head1 SEE ALSO L, L, L, L =head1 AUTHOR Lukas Mai, C<< >> =head1 COPYRIGHT & LICENSE Copyright (C) 2010-2014, 2017, 2023 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See L for more information. =cut Function-Parameters-2.002004/lib/Function/Parameters/0000755000175000017500000000000014454414615021263 5ustar maukemaukeFunction-Parameters-2.002004/lib/Function/Parameters/Info.pm0000644000175000017500000001264114454414454022521 0ustar maukemaukepackage Function::Parameters::Info; use v5.14.0; use warnings; use Function::Parameters; use Carp (); our $VERSION = '2.002004'; { package Function::Parameters::Param; use overload fallback => 1, '""' => method (@) { $self->{name} }, ; method new($class: :$name, :$type) { bless { @_ }, $class } method name() { $self->{name} } method type() { $self->{type} } } method new($class: :$keyword, :$nshift, :$_positional_required, :$_positional_optional, :$_named_required, :$_named_optional, :$slurpy, ) { bless {@_}, $class } method keyword() { $self->{keyword} } method nshift () { $self->{nshift} } method slurpy () { $self->{slurpy} } method positional_optional() { @{$self->{_positional_optional}} } method named_required () { @{$self->{_named_required}} } method named_optional () { @{$self->{_named_optional}} } method positional_required() { my @p = @{$self->{_positional_required}}; splice @p, 0, $self->nshift; @p } method args_min() { my $r = 0; $r += @{$self->{_positional_required}}; $r += $self->named_required * 2; $r } method args_max() { return 0 + 'Inf' if defined $self->slurpy || $self->named_required || $self->named_optional; my $r = 0; $r += @{$self->{_positional_required}}; $r += $self->positional_optional; $r } method invocant() { my $nshift = $self->nshift; return undef if $nshift == 0; return $self->{_positional_required}[0] if $nshift == 1; Carp::croak "Can't return a single invocant; this function has $nshift"; } method invocants() { my @p = @{$self->{_positional_required}}; splice @p, $self->nshift; @p } 'ok' __END__ =encoding UTF-8 =head1 NAME Function::Parameters::Info - Information about parameter lists =head1 SYNOPSIS use Function::Parameters; fun foo($x, $y, :$hello, :$world = undef) {} my $info = Function::Parameters::info \&foo; my @p0 = $info->invocants; # () my @p1 = $info->positional_required; # ('$x', '$y') my @p2 = $info->positional_optional; # () my @p3 = $info->named_required; # ('$hello') my @p4 = $info->named_optional; # ('$world') my $p5 = $info->slurpy; # undef my $min = $info->args_min; # 4 my $max = $info->args_max; # inf my @invocants = Function::Parameters::info(method () { 42 })->invocants; # ('$self') my $slurpy = Function::Parameters::info(fun (@) {})->slurpy; # '@' =head1 DESCRIPTION L|Function::Parameters/Introspection> returns objects of this class to describe parameter lists of functions. See below for L. The following methods are available: =head3 $info->invocants Returns a list of parameter objects for the variables into which initial arguments are L|perlfunc/shift ARRAY>ed automatically (or a count in scalar context). This will usually return C<()> for normal functions and C<('$self')> for methods. =head3 $info->positional_required Returns a list of parameter objects for the required positional parameters (or a count in scalar context). =head3 $info->positional_optional Returns a list of parameter objects for the optional positional parameters (or a count in scalar context). =head3 $info->named_required Returns a list of parameter objects for the required named parameters (or a count in scalar context). =head3 $info->named_optional Returns a list of parameter objects for the optional named parameters (or a count in scalar context). =head3 $info->slurpy Returns a parameter object for the final array or hash that gobbles up all remaining arguments, or C if no such thing exists. =head3 $info->args_min Returns the minimum number of arguments this function requires. This is computed as follows: Invocants and required positional parameters count 1 each. Optional parameters don't count. Required named parameters count 2 each (key + value). Slurpy parameters don't count either because they accept empty lists. =head3 $info->args_max Returns the maximum number of arguments this function accepts. This is computed as follows: If there are any named or slurpy parameters, the result is C. Otherwise the result is the number of all invocants and positional parameters. =head3 $info->invocant Similar to Linvocants> above: Returns C if the number of invocants is 0, a parameter object for the invocant if there is exactly 1, and throws an exception otherwise. =head3 Parameter Objects Many of the methods described above return parameter objects. These objects have two methods: C, which returns the name of the parameter (as a plain string), and C, which returns the corresponding type constraint object (or undef if there was no type specified). This should be invisible if you don't care about types because the objects also L stringification to call C. That is, if you treat parameter objects like strings, they behave like strings (i.e. their names). =head1 SEE ALSO L =head1 AUTHOR Lukas Mai, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2013, 2016 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut