Function-Parameters-2.001003/0000755000175000017500000000000013201556462014617 5ustar maukemaukeFunction-Parameters-2.001003/Makefile_PL_settings.plx0000644000175000017500000000276513154050043021375 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, 'Dir::Self' => 0, 'Hash::Util' => 0.07, 'Test::More' => 0, 'Test::Fatal' => 0, }, PREREQ_PM => { 'Carp' => 0, 'Scalar::Util' => 0, 'XSLoader' => 0, 'warnings' => 0, }, DEVELOP_REQUIRES => { 'Test::Pod' => 1.22, }, depend => { Makefile => '$(VERSION_FROM)', '$(OBJECT)' => join(' ', glob 'hax/*.c.inc'), }, REPOSITORY => [ github => 'mauke' ], }; Function-Parameters-2.001003/README0000644000175000017500000000241713201556462015503 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 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.001003/Changes0000644000175000017500000002370013201555304016106 0ustar maukemaukeRevision history for Function-Parameters 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 (#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 #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 #129090 / #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.001003/hax/0000755000175000017500000000000013201556460015375 5ustar maukemaukeFunction-Parameters-2.001003/hax/STATIC_ASSERT_STMT.c.inc0000644000175000017500000000224613125203755021235 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.001003/hax/pad_add_name_sv.c.inc0000644000175000017500000000464212765620656021420 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.001003/hax/block_end.c.inc0000644000175000017500000000216412416511721020232 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.001003/hax/pad_add_name_pvs.c.inc0000644000175000017500000000031212416511721021547 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.001003/hax/op_convert_list.c.inc0000644000175000017500000000276013062352237021530 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.001003/hax/pad_leavemy.c.inc0000644000175000017500000000411012416511721020571 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.001003/hax/pad_findmy_pvs.c.inc0000644000175000017500000000035112416511721021310 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.001003/hax/newDEFSVOP.c.inc0000644000175000017500000000071612416511721020133 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.001003/hax/scalarseq.c.inc0000644000175000017500000000136712726524075020306 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.001003/hax/intro_my.c.inc0000644000175000017500000000301012416511721020141 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.001003/hax/COP_SEQ_RANGE_LOW_set.c.inc0000644000175000017500000000027512416511721021754 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.001003/hax/COP_SEQ_RANGE_HIGH_set.c.inc0000644000175000017500000000030012416511721022017 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.001003/hax/block_start.c.inc0000644000175000017500000000073112416511721020617 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.001003/hax/pad_block_start.c.inc0000644000175000017500000000124512416511721021444 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.001003/hax/pad_alloc.c.inc0000644000175000017500000000345512416511721020234 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.001003/lib/0000755000175000017500000000000013201556460015363 5ustar maukemaukeFunction-Parameters-2.001003/lib/Function/0000755000175000017500000000000013201556460017150 5ustar maukemaukeFunction-Parameters-2.001003/lib/Function/Parameters.pm0000644000175000017500000013277013201555320021615 0ustar maukemaukepackage Function::Parameters; use v5.14.0; use warnings; 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.001003'; #$VERSION =~ s/-TRIAL[0-9]*\z//; XSLoader::load; } 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_term { # (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_union { # (str, caller) my $fun = &_reify_type_auto_term; while ($_[0] =~ /\G \| \s* /xgc) { my $right = &_reify_type_auto_term; 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, it offers far more features than core signatures, and it is not experimental. 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') # returns ('a', 'b', []) passthrough('a', undef) # returns ('a', undef, []) passthrough('a') # returns ('a', 42, []) passthrough() # error: Too few arguments Default arguments 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. 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 what 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: fun create_point(:$x, :$y, :$color = 0x00_00_00) { ... } create_point(x => 0, y => 64) # 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 (apart from leaving 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 very simple rules: =over =item * A I is a sequence of one or more simple types, separated by C<|> (pipe). C<|> is meant for union types (e.g. C would accept either a string or reference to an array of integers). =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 functions yourself. You can also import them from a type library such as L|Types::Standard> or L|MooseX::Types::Moose>. 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. =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|Moo> or L|Moose>. 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|Function::Parameters::Info> 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. 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, 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|Moose::Util::TypeConstraints> 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|Moose> (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 =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 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.001003/lib/Function/Parameters/0000755000175000017500000000000013201556460021253 5ustar maukemaukeFunction-Parameters-2.001003/lib/Function/Parameters/Info.pm0000644000175000017500000001261513201555312022504 0ustar maukemaukepackage Function::Parameters::Info; use v5.14.0; use warnings; use Function::Parameters; use Carp (); our $VERSION = '2.001003'; { 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 Function-Parameters-2.001003/Parameters.xs0000644000175000017500000022473713201175615017312 0ustar maukemauke/* Copyright 2012, 2014 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 #define HAVE_BUG_129090 (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("")); warner( 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: warner( packWARN(WARN_ILLEGALPROTO), "Illegal character in prototype for %"SVf" : %s", SVfARG(declarator), r ); return; case '_': if (r[1] && !strchr(";@%", r[1])) { warner( packWARN(WARN_ILLEGALPROTO), "Illegal character after '_' in prototype for %"SVf" : %s", SVfARG(declarator), r + 1 ); return; } break; case '@': case '%': if (r[1]) { warner( 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; } } warner( 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))) { croak("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 != ']') { croak("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(pTHX_ Sentinel sen, const SV *declarator, char prev) { I32 c; SV *t; t = parse_type_paramd(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_paramd(aTHX_ sen, declarator, '|'); 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)) { croak("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; }; DEFSTRUCT(ParamInit) { Param param; OpGuard init; }; 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_ const SV *declarator, size_t nr, SV *name, PADOFFSET padoff, SV *type, int is_invocant) { /* $type->check($value) or F:P::_croak "...: " . $type->get_message($value) */ OP *chk, *err, *msg, *xcroak; err = mkconstsv( aTHX_ is_invocant == -1 ? newSVpvf("In %"SVf": invocant (%"SVf"): ", SVfARG(declarator), SVfARG(name)) : newSVpvf("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); { 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) ); chk = op_convert_list( OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, args, newMETHOP(OP_METHOD, 0, mkconstpvs("check"))) ); } chk = newLOGOP(OP_OR, 0, chk, xcroak); return chk; } static OP *mktypecheck(pTHX_ const SV *declarator, size_t nr, SV *name, PADOFFSET padoff, SV *type) { return mktypecheckv(aTHX_ declarator, nr, name, padoff, type, 0); } static OP *mktypecheckp(pTHX_ const SV *declarator, size_t nr, const Param *param) { return mktypecheck(aTHX_ declarator, nr, param->name, param->padoff, param->type); } static OP *mktypecheckpv(pTHX_ const SV *declarator, size_t nr, const Param *param, int is_invocant) { return mktypecheckv(aTHX_ declarator, nr, param->name, param->padoff, param->type, is_invocant); } enum { PARAM_INVOCANT = 0x01, PARAM_NAMED = 0x02 }; 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; 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))) { croak("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 != ')') { croak("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)) { croak("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)) { *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) { croak("In %"SVf": unterminated parameter list", SVfARG(declarator)); } if (!(c == '$' || c == '@' || c == '%')) { croak("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 == '#') { croak("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, "_")) { croak("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); if (c == '=') { lex_read_unichar(0); lex_read_space(0); c = lex_peek_unichar(0); if (c == ',' || 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) { croak("In %"SVf": unterminated parameter list", SVfARG(declarator)); } croak("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 */ croak("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)) { croak("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 != '(') { croak("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) { croak("In %"SVf": named parameter %"SVf" can't be unnamed", SVfARG(declarator), SVfARG(name)); } if (flags & PARAM_INVOCANT) { croak("In %"SVf": invocant %"SVf" can't be a named parameter", SVfARG(declarator), SVfARG(name)); } if (sigil != '$') { croak("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) { croak("In %"SVf": invocant %"SVf" can't have a default value", SVfARG(declarator), SVfARG(name)); } if (sigil != '$') { croak("In %"SVf": invocant %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash"); } } else if (sigil != '$' && init_sentinel->op) { croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(name)); } if (type && padoff == NOT_IN_PAD) { croak("In %"SVf": unnamed parameter %"SVf" can't have a type", SVfARG(declarator), SVfARG(name)); } /* external constraints */ if (param_spec->slurpy.name) { croak("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)) { croak("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); croak("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)) { croak("In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(name)); } if (spec->shift.used && spec->shift.used != param_spec->positional_required.used + 1) { croak("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) { croak("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)) { croak("In %"SVf": default argument for %"SVf" not allowed here", SVfARG(declarator), SVfARG(name)); } if (padoff != NOT_IN_PAD && ps_contains(aTHX_ param_spec, name)) { croak("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)) { croak("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); param_spec->named_optional.used++; } else { if (param_spec->positional_optional.used) { croak("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); 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)) { croak("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))) { croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator)); } if (sv_eq_pvs(attr, "prototype")) { if (proto) { croak("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 */ { croak("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_129090 { 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_ newSVpvf("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_ newSVpvf("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_ newSVpvf("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; nest = 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; } } 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); } op_guard_update(prelude_sentinel, op_append_list( OP_LINESEQ, prelude_sentinel->op, nest )); } /* 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_ newSVpvf("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))) { 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)); } } 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_ newSVpvf("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_ 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_ 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_ 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_ 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_ 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)), newUNOP( OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, (SV *)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 = newUNOP( OP_REFGEN, 0, newSVOP( OP_ANONCODE, 0, (SV *)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) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVHV))) { croak("%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))) { croak("%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))) { \ croak("%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) { croak("%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 != '$') { croak("%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)) { croak("%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] == '_') { croak("%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)) { croak("%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))) { croak("%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)) { croak("%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) { croak("%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)) { croak("%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 != ' ') { croak("%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)) { warner(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.001003/META.yml0000644000175000017500000000160713201556460016072 0ustar maukemauke--- abstract: 'define functions and methods with parameter lists ("subroutine signatures")' author: - 'Lukas Mai ' build_requires: Dir::Self: '0' Hash::Util: '0.07' Test::Fatal: '0' Test::More: '0' constant: '0' strict: '0' utf8: '0' configure_requires: ExtUtils::MakeMaker: '0' File::Find: '0' File::Spec: '0' strict: '0' warnings: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.3, 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.001003' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Function-Parameters-2.001003/xt/0000755000175000017500000000000013201556460015250 5ustar maukemaukeFunction-Parameters-2.001003/xt/pod.t0000644000175000017500000000011312630137224016210 0ustar maukemauke#!perl use strict; use warnings; use Test::Pod 1.22; all_pod_files_ok(); Function-Parameters-2.001003/META.json0000644000175000017500000000346213201556461016244 0ustar maukemauke{ "abstract" : "define functions and methods with parameter lists (\"subroutine signatures\")", "author" : [ "Lukas Mai " ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.3, 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" : "0", "File::Find" : "0", "File::Spec" : "0", "strict" : "0", "warnings" : "0" } }, "develop" : { "requires" : { "Pod::Markdown" : "3.005", "Pod::Text" : "4.09", "Test::Pod" : "1.22" } }, "runtime" : { "requires" : { "Carp" : "0", "Scalar::Util" : "0", "XSLoader" : "0", "perl" : "5.014000", "warnings" : "0" } }, "test" : { "requires" : { "Dir::Self" : "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.001003", "x_serialization_backend" : "JSON::PP version 2.94" } Function-Parameters-2.001003/Makefile.PL0000644000175000017500000001221413154047776016603 0ustar maukemaukeuse strict; use warnings; use ExtUtils::MakeMaker; use File::Spec (); use File::Find (); 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: ", $@ || $!}; { $settings{depend}{Makefile} .= " $settings_file"; $settings{LICENSE} ||= 'perl'; $settings{PL_FILES} ||= {}; $settings{CONFIGURE_REQUIRES}{strict} ||= 0; $settings{CONFIGURE_REQUIRES}{warnings} ||= 0; $settings{CONFIGURE_REQUIRES}{'ExtUtils::MakeMaker'} ||= 0; $settings{CONFIGURE_REQUIRES}{'File::Find'} ||= 0; $settings{CONFIGURE_REQUIRES}{'File::Spec'} ||= 0; 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} ||= find_tests_recursively_in 't'; $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; } } (do './maint/eumm-fixup.pl' || die $@ || $!)->(\%settings) if $::MAINT_MODE; (my $mm_version = ExtUtils::MakeMaker->VERSION) =~ tr/_//d; if ($mm_version < 6.63_03) { $settings{META_MERGE}{resources}{repository} = $settings{META_MERGE}{resources}{repository}{url} if $settings{META_MERGE}{resources} && $settings{META_MERGE}{resources}{repository} && $settings{META_MERGE}{resources}{repository}{url}; delete $settings{META_MERGE}{'meta-spec'}{version}; } elsif ($mm_version < 6.67_04) { # Why? For the glory of satan, of course! no warnings qw(redefine); *ExtUtils::MM_Any::_add_requirements_to_meta_v1_4 = \&ExtUtils::MM_Any::_add_requirements_to_meta_v2; } { my $merge_key_into = sub { my ($target, $source) = @_; %{$settings{$target}} = (%{$settings{$target}}, %{delete $settings{$source}}); }; $merge_key_into->('BUILD_REQUIRES', 'TEST_REQUIRES') if $mm_version < 6.63_03; $merge_key_into->('CONFIGURE_REQUIRES', 'BUILD_REQUIRES') if $mm_version < 6.55_01; $merge_key_into->('PREREQ_PM', 'CONFIGURE_REQUIRES') if $mm_version < 6.51_03; } delete $settings{MIN_PERL_VERSION} if $mm_version < 6.47_01; delete $settings{META_MERGE} if $mm_version < 6.46; delete $settings{LICENSE} if $mm_version < 6.30_01; delete $settings{ABSTRACT_FROM} if $mm_version < 6.06_03; delete $settings{AUTHOR} if $mm_version < 6.06_03; WriteMakefile %settings; Function-Parameters-2.001003/MANIFEST0000644000175000017500000001114513201556462015752 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/00-load.t 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/foreign/Fun/anon.t t/foreign/Fun/basic.t t/foreign/Fun/closure-proto.t t/foreign/Fun/compile-time.t t/foreign/Fun/defaults.t t/foreign/Fun/name.t t/foreign/Fun/package.t t/foreign/Fun/recursion.t t/foreign/Fun/slurpy-syntax-errors.t t/foreign/Fun/slurpy.t t/foreign/Fun/state.t t/foreign/Method-Signatures-Simple/02-use.t t/foreign/Method-Signatures-Simple/03-config.t t/foreign/Method-Signatures-Simple/RT80505.t t/foreign/Method-Signatures-Simple/RT80507.t t/foreign/Method-Signatures-Simple/RT80508.t t/foreign/Method-Signatures-Simple/RT80510.t t/foreign/Method-Signatures/anon.t t/foreign/Method-Signatures/array_param.t t/foreign/Method-Signatures/at_underscore.t t/foreign/Method-Signatures/attributes.t t/foreign/Method-Signatures/begin.t t/foreign/Method-Signatures/caller.t t/foreign/Method-Signatures/comments.t t/foreign/Method-Signatures/defaults.t t/foreign/Method-Signatures/error_interruption.t t/foreign/Method-Signatures/func.t t/foreign/Method-Signatures/into.t t/foreign/Method-Signatures/invocant.t t/foreign/Method-Signatures/larna.t t/foreign/Method-Signatures/lib/Bad.pm t/foreign/Method-Signatures/lib/BarfyDie.pm t/foreign/Method-Signatures/lib/MooseLoadTest.pm t/foreign/Method-Signatures/method.t t/foreign/Method-Signatures/named.t t/foreign/Method-Signatures/odd_number.t t/foreign/Method-Signatures/one_line.t t/foreign/Method-Signatures/optional.t t/foreign/Method-Signatures/paren_on_own_line.t t/foreign/Method-Signatures/paren_plus_open_block.t t/foreign/Method-Signatures/required.t t/foreign/Method-Signatures/simple.plx t/foreign/Method-Signatures/slurpy.t t/foreign/Method-Signatures/syntax_errors.t t/foreign/Method-Signatures/too_many_args.t t/foreign/Method-Signatures/trailing_comma.t t/foreign/Method-Signatures/type_check.t t/foreign/Method-Signatures/typeload_moose.t t/foreign/Method-Signatures/typeload_notypes.t t/foreign/MooseX-Method-Signatures/attributes.t t/foreign/MooseX-Method-Signatures/caller.t t/foreign/MooseX-Method-Signatures/closure.t t/foreign/MooseX-Method-Signatures/errors.t t/foreign/MooseX-Method-Signatures/eval.t t/foreign/MooseX-Method-Signatures/lib/InvalidCase01.pm t/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/Long/Name/Space.pm t/foreign/MooseX-Method-Signatures/lib/Redefined.pm t/foreign/MooseX-Method-Signatures/list.t t/foreign/MooseX-Method-Signatures/named_defaults.t t/foreign/MooseX-Method-Signatures/no_signature.t t/foreign/MooseX-Method-Signatures/precedence.t t/foreign/MooseX-Method-Signatures/sigs-optional.t t/foreign/MooseX-Method-Signatures/too_many_args.t t/foreign/MooseX-Method-Signatures/type_alias.t t/foreign/MooseX-Method-Signatures/types.t t/foreign/MooseX-Method-Signatures/undef_method_arg.t t/foreign/MooseX-Method-Signatures/undef_method_arg2.t t/foreign/perl/signatures.t t/foreign/signatures/anon.t t/foreign/signatures/basic.t t/foreign/signatures/eval.t t/foreign/signatures/proto.t t/foreign/signatures/weird.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/threads.t t/threads2.t t/types_auto.t t/types_caller.t t/types_custom.t t/types_custom_2.t t/types_custom_3.t t/types_custom_4.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 xt/pod.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.001003/t/0000755000175000017500000000000013201556460015060 5ustar maukemaukeFunction-Parameters-2.001003/t/unicode.t0000644000175000017500000000140213076614102016666 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.001003/t/strict.t0000644000175000017500000000122613076614102016554 0ustar maukemaukeuse warnings; use strict; use Test::More tests => 10; use Dir::Self; for my $fail ( map [__DIR__ . "/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"; $exc or die "$file: $err" if $err; like $exc, $pat; } Function-Parameters-2.001003/t/checkered_3.t0000644000175000017500000001162613076614101017407 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.001003/t/strict_3.fail0000644000175000017500000000013412400633742017444 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters; fun bad_3($x, %y, $z) {} 'ok' Function-Parameters-2.001003/t/types_moose_3.t0000644000175000017500000000634113076614102020037 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.001003/t/bonus.t0000644000175000017500000000235013076614101016370 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.001003/t/defaults.t0000644000175000017500000000623313076614101017055 0ustar maukemauke#!perl use Test::More tests => 46; use warnings FATAL => 'all'; use strict; 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; is fun ($answer = 42) { $answer }->(), 42; fun sharingan($input, $x = [], $y = {}) { push @$x, $input; $y->{$#$x} = $input; $x, $y } { is_deeply [sharingan 'e'], [['e'], {0 => 'e'}]; my $sneaky = ['ants']; is_deeply [sharingan $sneaky], [[['ants']], {0 => ['ants']}]; unshift @$sneaky, 'thanks'; is_deeply [sharingan $sneaky], [[['thanks', 'ants']], {0 => ['thanks', 'ants']}]; @$sneaky = 'thants'; is_deeply [sharingan $sneaky], [[['thants']], {0 => ['thants']}]; } 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"; } 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/; 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]; } Function-Parameters-2.001003/t/croak.t0000644000175000017500000000455613172746704016367 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.001003/t/prototype.t0000644000175000017500000000671113076614102017315 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.001003/t/lineno-torture.t0000644000175000017500000001745512642731773020261 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.001003/t/precedence.t0000644000175000017500000000150413076614102017340 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.001003/t/recursion.t0000644000175000017500000000444213076614102017260 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.001003/t/threads.t0000644000175000017500000000107613125210456016700 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.001003/t/install.t0000644000175000017500000000356213076614102016717 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.001003/t/method_runtime.t0000644000175000017500000000306513076614102020272 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.001003/t/invocant.t0000644000175000017500000001076013076614102017070 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.001003/t/types_moosex_2.t0000644000175000017500000000403313076614102020222 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.001003/t/imports.t0000644000175000017500000000663313076614102016750 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.001003/t/types_caller.t0000644000175000017500000000360313076614102017733 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 46 "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.001003/t/checkered_2.t0000644000175000017500000001260613076614101017405 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.001003/t/defaults_regress.t0000644000175000017500000000056412642731735020623 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.001003/t/attributes.t0000644000175000017500000000204313076614101017427 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.001003/t/strict_2.fail0000644000175000017500000000013012400633742017437 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters; fun bad_2(@x, $y) {} 'ok' Function-Parameters-2.001003/t/00-load.t0000644000175000017500000000025212400633742016377 0ustar maukemauke#!perl use Test::More tests => 1; BEGIN { use_ok( 'Function::Parameters' ); } diag( "Testing Function::Parameters $Function::Parameters::VERSION, Perl $], $^X" ); Function-Parameters-2.001003/t/regress.t0000644000175000017500000000123413076614102016715 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.001003/t/types_moose.t0000644000175000017500000000646013076614102017617 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.001003/t/types_parse.t0000644000175000017500000000026012416721261017601 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.001003/t/info.t0000644000175000017500000001225213076614102016200 0ustar maukemauke#!perl -T use warnings FATAL => 'all'; 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.001003/t/types_msg.t0000644000175000017500000000421113126137720017255 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.001003/t/lexical.t0000644000175000017500000000214413125176576016702 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.001003/t/strict_4.fail0000644000175000017500000000013012400633742017441 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters; fun bad_4(@y, @z) {} 'ok' Function-Parameters-2.001003/t/foreign/0000755000175000017500000000000013201556460016511 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/Method-Signatures/0000755000175000017500000000000013201556460022053 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/Method-Signatures/slurpy.t0000644000175000017500000000322413076614101023574 0ustar maukemauke#!perl # Test slurpy parameters use strict; use warnings FATAL => 'all'; use Test::More; #use Test::Exception; { package Stuff; use Function::Parameters qw(:strict); use Test::More; method slurpy(@that) { return \@that } method slurpy_required(@that) { return \@that } method slurpy_last($this, @that) { return $this, \@that; } ok !eval q[fun slurpy_first(@that, $this) { return $this, \@that; }]; like $@, qr{\$this\b.+\@that\b}; # TODO: { # local $TODO = "error message incorrect inside an eval"; # like $@, qr{Stuff::}; like $@, qr{\bslurpy_first\b}; # } ok !eval q[fun slurpy_middle($this, @that, $other) { return $this, \@that, $other }]; like $@, qr{\$other\b.+\@that\b}; # TODO: { # local $TODO = "error message incorrect inside an eval"; # like $@, qr{Stuff::}; like $@, qr{\bslurpy_middle\b}; # } ok !eval q[fun slurpy_positional(:@that) { return \@that; }]; like $@, qr{\bnamed\b.+\@that\b.+\barray\b}; # TODO: { # local $TODO = "error message incorrect inside an eval"; # like $@, qr{Stuff::}; like $@, qr{\bslurpy_positional\b}; # } ok !eval q[fun slurpy_two($this, @that, @other) { return $this, \@that, \@other }]; like $@, qr{\@other\b.+\@that\b}; } note "Optional slurpy params accept 0 length list"; { is_deeply [Stuff->slurpy()], [[]]; is_deeply [Stuff->slurpy_last(23)], [23, []]; } #note "Required slurpy params require an argument"; { # throws_ok { Stuff->slurpy_required() } # qr{slurpy_required\Q()\E, missing required argument \@that at \Q$0\E line @{[__LINE__ - 1]}}; #} done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/paren_on_own_line.t0000644000175000017500000000040012400633742025724 0ustar maukemauke#!perl package Foo; use strict; use warnings FATAL => 'all'; use Function::Parameters qw(:strict); use Test::More 'no_plan'; # The problem goes away inside an eval STRING. method foo( $arg ) { return $arg; } is $@, ''; is( Foo->foo(42), 42 ); Function-Parameters-2.001003/t/foreign/Method-Signatures/defaults.t0000644000175000017500000000314612400633742024052 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More 'no_plan'; { package Stuff; use Test::More; use Function::Parameters qw(:strict); method add($this = 23, $that = 42) { return $this + $that; } method minus($this = 23, $that = 42) { return $this - $that; } is( Stuff->add(), 23 + 42 ); is( Stuff->add(99), 99 + 42 ); is( Stuff->add(2,3), 5 ); is( Stuff->minus(), 23 - 42 ); is( Stuff->minus(99), 99 - 42 ); is( Stuff->minus(2, 3), 2 - 3 ); # Test that undef overrides defaults method echo($message = "what?") { return $message } is( Stuff->echo(), "what?" ); is( Stuff->echo(undef), undef ); is( Stuff->echo("who?"), 'who?' ); # Test that you can reference earlier args in a default method copy_cat($this, $that = $this) { return $that; } is( Stuff->copy_cat("wibble"), "wibble" ); is( Stuff->copy_cat(23, 42), 42 ); } { package Bar; use Test::More; use Function::Parameters qw(:strict); method hello($msg = "Hello, world!") { return $msg; } is( Bar->hello, "Hello, world!" ); is( Bar->hello("Greetings!"), "Greetings!" ); method hi($msg = q,Hi,) { return $msg; } is( Bar->hi, "Hi" ); is( Bar->hi("Yo"), "Yo" ); # method list(@args = (1,2,3)) { # return @args; # } # # is_deeply [Bar->list()], [1,2,3]; method code($num, $code = sub { $num + 2 }) { return $code->(); } is( Bar->code(42), 44 ); } Function-Parameters-2.001003/t/foreign/Method-Signatures/comments.t0000644000175000017500000000350113076614101024061 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More eval { require Moose } ? (tests => 5) : (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' }, }; is exception { eval q{ fun foo ( Int :$foo, # this is foo Int :$bar # this is bar ) { } 1; } or die; }, undef, 'survives comments within the signature itself'; is exception { eval q{ fun bar ( Int :$foo, Int :$bar ) # this is a signature { } 1; } or die; }, undef, 'survives comments between signature and open brace'; #SKIP: #{ # eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; # is exception { eval q{ # use MooseX::Declare; # use Method::Signatures::Modifiers; package Foo { method bar ( Int :$foo, Int :$bar ) # this is a signature { } } 1; } or die; }, undef, 'survives comments between signature and open brace'; #} #TODO: { # local $TODO = "closing paren in comment: rt.cpan.org 81364"; is exception { # # When this fails, it produces 'Variable "$bar" is not imported' # # This is expected to fail, don't bother the user. # no warnings; eval q{ fun special_comment ( $foo, # ) $bar ) { 42 } 1; } or die; }, undef, 'closing paren in comment'; is eval q[special_comment("this", "that")], 42; #} #done_testing(); Function-Parameters-2.001003/t/foreign/Method-Signatures/typeload_moose.t0000644000175000017500000000176212400633742025270 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Dir::Self; use lib __DIR__ . '/lib'; use Test::More; use Test::Fatal; SKIP: { eval { require Moose } or skip "Moose required for testing Moose types", 1; require MooseLoadTest; my $foobar = Foo::Bar->new; # can't check for type module not being loaded here, because Moose will drag it in $foobar->check_int(42); # now we should have loaded Moose to do our type checking like $INC{'Moose/Util/TypeConstraints.pm'}, qr{Moose/Util/TypeConstraints\.pm$}, 'loaded Moose'; # tests for ScalarRef[X] have to live here, because they only work with Moose my $method = 'check_paramized_sref'; my $bad_ref = \'thing'; is exception { $foobar->$method(\42) }, undef, 'call with good value for paramized_sref passes'; like exception { $foobar->$method($bad_ref) }, qr/\bcheck_paramized_sref\b.+\$bar\b.+ScalarRef\[Num\]/, 'call with bad value for paramized_sref dies'; } done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/odd_number.t0000644000175000017500000000046112421103320024341 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 1; use Test::Fatal; use Function::Parameters qw(:strict); package Foo { method foo(:$name, :$value) { return $name, $value; } } like exception { Foo->foo(name => 42, value =>) }, qr/Too few arguments.+ line 17/; Function-Parameters-2.001003/t/foreign/Method-Signatures/method.t0000644000175000017500000000266313076614101023524 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More 'no_plan'; { package Foo; use Function::Parameters qw(:strict); method new (%args) { return bless {%args}, $self; } method set ($key, $val) { return $self->{$key} = $val; } method get ($key) { return $self->{$key}; } method no_proto(@) { return($self, @_); } method empty_proto() { return($self, @_); } # method echo(@_) { # return($self, @_); # } method caller($height = 0) { return (CORE::caller($height))[0..2]; } #line 39 method warn($foo = undef) { my $warning = ''; local $SIG{__WARN__} = sub { $warning = join '', @_; }; CORE::warn "Testing warn"; return $warning; } # Method with the same name as a loaded class. method strict () { 42 } } my $obj = Foo->new( foo => 42, bar => 23 ); isa_ok $obj, "Foo"; is $obj->get("foo"), 42; is $obj->get("bar"), 23; $obj->set(foo => 99); is $obj->get("foo"), 99; is_deeply [$obj->no_proto], [$obj]; for my $method (qw(empty_proto)) { is_deeply [$obj->$method], [$obj]; ok !eval { $obj->$method(23); 1 }; like $@, qr{\QToo many arguments}; } #is_deeply [$obj->echo(1,2,3)], [$obj,1,2,3], "echo"; is_deeply [$obj->caller], [__PACKAGE__, $0, __LINE__], 'caller works'; is $obj->warn, "Testing warn at $0 line 42.\n"; is eval { $obj->strict }, 42; Function-Parameters-2.001003/t/foreign/Method-Signatures/invocant.t0000644000175000017500000000262413076614101024062 0ustar maukemauke#!perl # Test that you can change the invocant. use strict; use warnings FATAL => 'all'; use Test::More eval { require Moose } ? (tests => 6) : (skip_all => "Moose required for testing types") ; our $skip_no_invocants; { package Stuff; use Test::More; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; sub new { bless {}, __PACKAGE__ } method bar($arg) { return ref $arg || $arg; } method invocant($class:) { $class->bar(0); } method with_arg($class: $arg) { $class->bar($arg); } method without_space($class:$arg) { $class->bar($arg); } eval q{ method no_invocant_class_type(Foo::Bar $arg) { $self->bar($arg); } method no_invocant_named_param(Foo :$arg) { $self->bar($arg); } }; is $@, '', 'compiles without invocant'; } { package Foo; sub new { bless {}, __PACKAGE__ } } { package Foo::Bar; sub new { bless {}, __PACKAGE__ } } is( Stuff->invocant, 0 ); is( Stuff->with_arg(42), 42 ); is( Stuff->without_space(42), 42 ); my $stuff = Stuff->new; is( $stuff->no_invocant_class_type(Foo::Bar->new), 'Foo::Bar' ); is( $stuff->no_invocant_named_param(arg => Foo->new), 'Foo' ); Function-Parameters-2.001003/t/foreign/Method-Signatures/array_param.t0000644000175000017500000000124713076614101024537 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 3; { package Bla; use Test::More; use Function::Parameters qw(:strict); method new ($class:) { bless {}, $class; } method array_param_at_end ($a, $b, @c) { return "$a|$b|@c"; } eval q{ method two_array_params ($a, @b, @c) {} }; like($@, qr{\btwo_array_params\b.+\@c\b.+\@b\b}, "Two array params"); eval q{ method two_slurpy_params ($a, %b, $c, @d, $e) {} }; like($@, qr{\btwo_slurpy_params\b.+\$c\b.+%b\b}, "Two slurpy params"); } is(Bla->new->array_param_at_end(1, 2, 3, 4), "1|2|3 4", "Array parameter at end"); Function-Parameters-2.001003/t/foreign/Method-Signatures/too_many_args.t0000644000175000017500000000222713076614101025101 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters qw(:strict); fun no_sig(@) { return @_ } fun no_args() { return @_ } fun one_arg($foo) { return $foo } fun two_args($foo, $bar) { return ($foo, $bar) } fun array_at_end($foo, @stuff) { return ($foo, @stuff) } fun one_named(:$foo) { return $foo; } fun one_named_one_positional($bar, :$foo) { return($foo, $bar) } note "too many arguments"; { is_deeply [no_sig(42)], [42]; ok !eval { no_args(42); 1 }, "no args"; like $@, qr{Too many arguments}; ok !eval { one_arg(23, 42); 1 }, "one arg"; like $@, qr{Too many arguments}; ok !eval { two_args(23, 42, 99); 1 }, "two args"; like $@, qr{Too many arguments}; is_deeply [array_at_end(23, 42, 99)], [23, 42, 99], "array at end"; } note "with positionals"; { is one_named(foo => 42), 42; is one_named(foo => 23, foo => 42), 42; is_deeply [one_named_one_positional(23, foo => 42)], [42, 23]; is_deeply [one_named_one_positional(23, foo => 42, foo => 23)], [23, 23]; } done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/anon.t0000644000175000017500000000051012400633742023166 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More 'no_plan'; { package Stuff; use Test::More; use Function::Parameters qw(:strict); method echo($arg) { return $arg } my $method = method ($arg) { return $self->echo($arg) }; is( Stuff->$method("foo"), "foo" ); } Function-Parameters-2.001003/t/foreign/Method-Signatures/attributes.t0000644000175000017500000000206613076614101024427 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More 'no_plan'; use attributes; { package Stuff; use Test::More; use Function::Parameters qw(:strict); method echo($arg) { return $arg; } is( Stuff->echo(42), 42 ); is_deeply( [attributes::get \&echo], ['method'] ); } { package Foo; use Test::More; use Function::Parameters qw(:strict); my $code = fun () : method {}; is_deeply( [attributes::get $code], ['method'] ); } { package Things; use Function::Parameters qw(:strict); my $attrs; my $cb_called; sub MODIFY_CODE_ATTRIBUTES { my ($pkg, $code, @attrs) = @_; $cb_called = 1; $attrs = \@attrs; return (); } method moo($foo, $bar) : Bar Baz(fubar) { } # Torture test for the attribute handling. method foo() : Bar :Moo(:Ko{oh) : Baz(fu{bar:): { return {} } ::ok($cb_called, 'attribute handler got called'); ::is_deeply($attrs, [qw/Bar Moo(:Ko{oh) Baz(fu{bar:)/], '... with the right attributes'); } Function-Parameters-2.001003/t/foreign/Method-Signatures/lib/0000755000175000017500000000000013201556460022621 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/Method-Signatures/lib/BarfyDie.pm0000644000175000017500000000114412477214057024653 0ustar maukemauke# For use with t/error_interruption.t package BarfyDie; use strict; use warnings; use Function::Parameters qw(:strict); # This _should_ produce a simple error like the following: # Global symbol "$foo" requires explicit package name at t/lib/BarfyDie.pm line 13. $foo = 'hi!'; # And, without the signature below, it would. # For that matter, if you compile this by itself, it still does. # However, when you require this file from inside an eval, Method::Signature's parser() method will # eat the error unless we localize $@ there. So this verifies that we're doing that. method foo (Str $bar) { } 1; Function-Parameters-2.001003/t/foreign/Method-Signatures/lib/MooseLoadTest.pm0000644000175000017500000000056713076614101025706 0ustar maukemauke# package for t/typeload_moose.t # (see comments there for why check_paramized_sref is here) package Foo::Bar; use Moose; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; method check_int (Int $bar) {}; method check_paramized_sref (ScalarRef[Num] $bar) {}; 1; Function-Parameters-2.001003/t/foreign/Method-Signatures/lib/Bad.pm0000644000175000017500000000030512400633742023642 0ustar maukemaukepackage Bad; use strict; use warnings; use Function::Parameters qw(:strict); ## $info->{} should be $info{} method meth1 ($foo) { my %info; $info->{xpto} = 1; } method meth2 ($bar) {} 'ok' Function-Parameters-2.001003/t/foreign/Method-Signatures/optional.t0000644000175000017500000000254012400633742024065 0ustar maukemauke#!perl # Test the $arg = undef optional syntax. use strict; use warnings FATAL => 'all'; use Test::More; { package Stuff; use Test::More; use Test::Fatal; use Function::Parameters qw(:strict); method whatever($this = undef) { return $this; } is( Stuff->whatever(23), 23 ); method things($this = 99) { return $this; } is( Stuff->things(), 99 ); method some_optional($that, $this = undef) { return $that + ($this || 0); } is( Stuff->some_optional(18, 22), 18 + 22 ); is( Stuff->some_optional(18), 18 ); method named_params(:$this = undef, :$that = undef) {} is exception { Stuff->named_params(this => 0) }, undef, 'can leave out some named params'; is exception { Stuff->named_params( ) }, undef, 'can leave out all named params'; # are slurpy parameters optional by default? # (throwing in a default just for a little feature interaction test) method slurpy_param($this, $that = 0, @other) {} my @a = (); is exception { Stuff->slurpy_param(0, 0, @a) }, undef, 'can pass empty array to slurpy param'; is exception { Stuff->slurpy_param(0, 0 ) }, undef, 'can omit slurpy param altogether'; is exception { Stuff->slurpy_param(0 ) }, undef, 'can omit other optional params as well as slurpy param'; } done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/one_line.t0000644000175000017500000000031513076614101024024 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 1; { package Thing; use Function::Parameters qw(:strict); method foo() {"wibble"} ::is( Thing->foo, "wibble" ); } Function-Parameters-2.001003/t/foreign/Method-Signatures/required.t0000644000175000017500000000105312421103320024041 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; { package Stuff; use Test::More; use Test::Fatal; use Function::Parameters qw(:strict); method whatever($this) { return $this; } is( Stuff->whatever(23), 23 ); like exception { Stuff->whatever() }, qr/Too few arguments/; method some_optional($that, $this = 22) { return $that + $this } is( Stuff->some_optional(18), 18 + 22 ); like exception { Stuff->some_optional() }, qr/Too few arguments/; } done_testing(); Function-Parameters-2.001003/t/foreign/Method-Signatures/at_underscore.t0000644000175000017500000000052713076614101025076 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; { package Foo; use Function::Parameters qw(:strict); fun foo(@) { return @_ } method bar(@) { return @_ } } is_deeply [Foo::foo()], []; is_deeply [Foo::foo(23, 42)], [23, 42]; is_deeply [Foo->bar()], []; is_deeply [Foo->bar(23, 42)], [23, 42]; done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/typeload_notypes.t0000644000175000017500000000131012400633742025634 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; { package Foo::Bar; use strict; use warnings; use Function::Parameters qw(:strict); method new ($class:) { bless {}, $class; } # not using a type here, so we won't expect Moose to get loaded method foo1 ($bar) {}; } my $foobar = Foo::Bar->new; # at this point, Moose should not be loaded is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; $foobar->foo1(42); # _still_ should have no Moose because we haven't requested any type checking is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/caller.t0000644000175000017500000000220112400633742023474 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; # Test that caller() works { package Foo; use Test::More 'no_plan'; use Function::Parameters qw(:strict); sub sub_caller { my($self, $level) = @_; #line 13 return caller($level); } sub sub_caller2 { my($self, $level) = @_; #line 20 return $self->sub_caller($level); } method method_caller($level) { #line 13 return caller($level); } method method_caller2($level) { #line 20 return $self->method_caller($level); } #line 36 my @expected = Foo->sub_caller2(0); my @expected2 = Foo->sub_caller2(1); #line 36 my @have = Foo->method_caller2(0); my @have2 = Foo->method_caller2(1); $expected[3] = 'Foo::method_caller'; $expected2[3] = 'Foo::method_caller2'; is_deeply([@have[0..7]], [@expected[0..7]]); is_deeply([@have2[0..7]], [@expected2[0..7]]); # hints and bitmask change and are twitchy so I'm just going to # check that they're there. isnt $have[8], undef; isnt $have2[8], undef; isnt $have[9], undef; isnt $have2[9], undef; } Function-Parameters-2.001003/t/foreign/Method-Signatures/error_interruption.t0000644000175000017500000000133312477214057026222 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Dir::Self; use lib __DIR__ . "/lib"; use Test::More do { # Trying to load modules (for parameter types) after a syntax error can # fail, hiding the real error message. To properly test this, we need to # know Moose is available but we can't load it up front. my $have_moose; for my $dir (@INC) { if (-r "$dir/Moose/Util/TypeConstraints.pm") { $have_moose = 1; last; } } $have_moose ? () : (skip_all => "Moose required for testing types") }; use Test::Fatal; like exception { require BarfyDie }, qr/requires explicit package name/, "F:P doesn't interrupt real compilation error"; done_testing(); Function-Parameters-2.001003/t/foreign/Method-Signatures/func.t0000644000175000017500000000027012400633742023171 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 1; use Function::Parameters qw(:strict); fun echo($arg) { return $arg; } is echo(42), 42, "basic func"; Function-Parameters-2.001003/t/foreign/Method-Signatures/named.t0000644000175000017500000000242212421103320023306 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More; { package Foo; use Test::More; use Test::Fatal;; use Function::Parameters qw(:strict); method formalize($text, :$justify = "left", :$case = undef) { my %params; $params{text} = $text; $params{justify} = $justify; $params{case} = $case if defined $case; return \%params; } is_deeply( Foo->formalize( "stuff" ), { text => "stuff", justify => "left" } ); like exception { Foo->formalize( "stuff", wibble => 23 ) }, qr/\bnamed\b.+\bwibble\b/; method foo( :$arg ) { return $arg; } is( Foo->foo( arg => 42 ), 42 ); like exception { foo() }, qr/Too few arguments/; # Compile time errors need internal refactoring before I can get file, line and method # information. eval q{ method wrong( :$named, $pos ) {} }; like $@, qr/\bpositional\b.+\$pos\b.+\bnamed\b.+\$named\b/; eval q{ method wrong( $foo, :$named, $bar ) {} }; like $@, qr/\bpositional\b.+\$bar\b.+\bnamed\b.+\$named\b/; eval q{ method wrong( $foo, $bar = undef, :$named ) {} }; like $@, qr/\boptional positional\b.+\$bar\b.+\brequired named\b.+\$named\b/; } done_testing(); Function-Parameters-2.001003/t/foreign/Method-Signatures/larna.t0000644000175000017500000000073212400633742023336 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters qw(:strict); { my $a; ok eval q{ $a = [ fun () {}, 1 ]; 1 }, 'anonymous function in list is okay' or diag "eval error: $@"; is ref $a->[0], "CODE"; is $a->[1], 1; } { my $a; ok eval q{ $a = [ method () {}, 1 ]; 1 }, 'anonymous method in list is okay' or diag "eval error: $@"; is ref $a->[0], "CODE"; is $a->[1], 1; } done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/type_check.t0000644000175000017500000001534513126140266024365 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More eval { require Moose } ? () : (skip_all => "Moose required for testing types") ; use Test::More; use Test::Fatal; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; { package Foo::Bar; sub new { bless {}, __PACKAGE__; } } { package Foo::Baz; sub new { bless {}, __PACKAGE__; } } our $foobar = Foo::Bar->new; our $foobaz = Foo::Baz->new; # types to check below # the test name needs to be interpolated into a method name, so it must be a valid identifier # either good value or bad value can be an array reference: # * if it is, it is taken to be multiple values to try # * if you want to pass an array reference, you have to put it inside another array reference # * so, [ 42, undef ] makes two calls: one with 42, and one with undef # * but [[ 42, undef ]] makes one call, passing [ 42, undef ] our @TYPES = ( ## Test Name => Type => Good Value => Bad Value int => 'Int' => 42 => 'foo' , bool => 'Bool' => 0 => 'fool' , aref => 'ArrayRef', => [[ 42, undef ]] => 42 , class => 'Foo::Bar' => $foobar => $foobaz , maybe_int => 'Maybe[Int]' => [ 42, undef ] => 'foo' , paramized_aref => 'ArrayRef[Num]' => [[ 6.5, 42, 1e23 ]] => [[ 6.5, 42, 'thing' ]] , paramized_href => 'HashRef[Num]' => { a => 6.5, b => 2, c => 1e23 } => { a => 6.5, b => 42, c => 'thing' } , paramized_nested=> 'HashRef[ArrayRef[Int]]' => { foo=>[1..3], bar=>[1] } => { foo=>['a'] } , ## ScalarRef[X] not implemented in Mouse, so this test is moved to typeload_moose.t ## if Mouse starts supporting it, the test could be restored here paramized_sref => 'ScalarRef[Num]' => \42 => \'thing' , int_or_aref => 'Int|ArrayRef[Int]' => [ 42 , [42 ] ] => 'foo' , int_or_aref_or_undef => 'Int|ArrayRef[Int]|Undef' => [ 42 , [42 ], undef ] => 'foo' , ); our $tester; { package TypeCheck::Class; use strict; use warnings; use Test::More; use Test::Fatal; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; method new ($class:) { bless {}, $class; } sub _list { return ref $_[0] eq 'ARRAY' ? @{$_[0]} : ( $_[0] ); } $tester = __PACKAGE__->new; while (@TYPES) { my ($name, $type, $goodval, $badval) = splice @TYPES, 0, 4; note "name/type/goodval/badval $name/$type/$goodval/$badval"; my $method = "check_$name"; no strict 'refs'; # make sure the declaration of the method doesn't throw a warning is eval qq{ method $method ($type \$bar) {} 42 }, 42; is $@, ''; # positive test--can we call it with a good value? my @vals = _list($goodval); my $count = 1; foreach (@vals) { my $tag = @vals ? ' (alternative ' . $count++ . ')' : ''; is exception { $tester->$method($_) }, undef, "call with good value for $name passes" . $tag; } # negative test--does calling it with a bad value throw an exception? @vals = _list($badval); $count = 1; foreach (@vals) { my $tag = @vals ? ' (#' . $count++ . ')' : ''; like exception { $tester->$method($_) }, qr/method \Q$method\E.+parameter 1\b.+\$bar\b.+Validation failed for '[^']+' with value\b/, "call with bad value for $name dies"; } } # try some mixed (i.e. some with a type, some without) and multiples my $method = 'check_mixed_type_first'; is eval qq{ method $method (Int \$bar, \$baz) {} 42 }, 42; is exception { $tester->$method(0, 'thing') }, undef, 'call with good values (type, notype) passes'; like exception { $tester->$method('thing1', 'thing2') }, qr/method \Q$method\E.+parameter 1\b.+\$bar\b.+Validation failed for '[^']+' with value\b/, 'call with bad values (type, notype) dies'; $method = 'check_mixed_type_second'; is eval qq{ method $method (\$bar, Int \$baz) {} 42 }, 42; is exception { $tester->$method('thing', 1) }, undef, 'call with good values (notype, type) passes'; like exception { $tester->$method('thing1', 'thing2') }, qr/method \Q$method\E.+parameter 2\b.+\$baz\b.+Validation failed for '[^']+' with value\b/, 'call with bad values (notype, type) dies'; $method = 'check_multiple_types'; is eval qq{ method $method (Int \$bar, Int \$baz) {} 42 }, 42; is exception { $tester->$method(1, 1) }, undef, 'call with good values (type, type) passes'; # with two types, and bad values for both, they should fail in order of declaration like exception { $tester->$method('thing1', 'thing2') }, qr/method \Q$method\E.+parameter 1\b.+\$bar\b.+Validation failed for '[^']+' with value\b/, 'call with bad values (type, type) dies'; # want to try one with undef as well to make sure we don't get an uninitialized warning like exception { $tester->check_int(undef) }, qr/method check_int.+parameter 1\b.+\$bar\b.+Validation failed for '[^']+' with value\b/, 'call with bad values (undef) dies'; # finally, some types that shouldn't be recognized my $type; ## Moose accepts unknown types as classes #$method = 'unknown_type'; #$type = 'Bmoogle'; #is eval qq{ method $method ($type \$bar) {} 42 }, 42; #like exception { $tester->$method(42) }, qr/ducks $tester, $type, "perhaps you forgot to load it?", $method/, # 'call with unrecognized type dies'; # this one is a bit specialer in that it involved an unrecognized parameterization $method = 'unknown_paramized_type'; $type = 'Bmoogle[Int]'; is eval qq{ method $method ($type \$bar) {} 42 }, undef; like $@, qr/\QCould not locate the base type (Bmoogle)/; like exception { $tester->$method(42) }, qr/\QCan't locate object method "unknown_paramized_type" via package "TypeCheck::Class"/; } done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/simple.plx0000644000175000017500000000020012400633742024060 0ustar maukemaukepackage Foo; use strict; use warnings; use Function::Parameters; method echo($msg) { return $msg } print Foo->echo(42); Function-Parameters-2.001003/t/foreign/Method-Signatures/paren_plus_open_block.t0000644000175000017500000000030612400633742026601 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; package Foo; use Test::More "no_plan"; use Function::Parameters qw(:strict); method foo( $arg ) { return $arg } is( Foo->foo(23), 23 ); Function-Parameters-2.001003/t/foreign/Method-Signatures/syntax_errors.t0000644000175000017500000000063512400633742025165 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Dir::Self; use lib __DIR__ . '/lib'; ok !eval { require Bad }; #TODO: { # local $TODO = "The user should see the actual syntax error"; like $@, qr{^Global symbol "\$info" requires explicit package name}m; # like($@, qr{^PPI failed to find statement for '\$bar'}m, # 'Bad syntax generates stack trace'); #} done_testing(); Function-Parameters-2.001003/t/foreign/Method-Signatures/into.t0000644000175000017500000000046512400633742023215 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; # Importing always affects the currently compiling scope. package Foo; use Test::More 'no_plan'; BEGIN { package Bar; require Function::Parameters; Function::Parameters->import; } is( Foo->foo(42), 42 ); method foo ($arg) { return $arg; } Function-Parameters-2.001003/t/foreign/Method-Signatures/trailing_comma.t0000644000175000017500000000036512400633742025230 0ustar maukemauke#!perl # Make sure we allow a trailing comma. use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters qw(:strict); fun foo($foo, $bar,) { return [$foo, $bar]; } is_deeply foo(23, 42), [23, 42]; done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures/begin.t0000644000175000017500000000326212400633742023326 0ustar maukemauke#!perl package Foo; use strict; use warnings FATAL => 'all'; use Test::More; use Test::Fatal; use Function::Parameters { method => { defaults => 'method', runtime => 0 } }; our $phase; BEGIN { $phase = 'compile-time' } INIT { $phase = 'run-time' } sub method_defined { my ($method) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; is exception { Foo->$method }, undef, "method $method is defined at $phase"; } sub method_undefined { my ($method) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; like exception { Foo->$method }, qr/Can't locate object method/, "method $method is undefined at $phase"; } # The default configuration with compile at BEGIN on. method top_level_default() {} # Turn it off. use Function::Parameters { method => { defaults => 'method', runtime => 1 } }; method top_level_off() {} # And on again. use Function::Parameters { method => { defaults => 'method', runtime => 0 } }; method top_level_on() {} # Now turn it off inside a lexical scope { use Function::Parameters { method => { defaults => 'method', runtime => 1 } }; method inner_scope_off() {} } # And it's restored. method outer_scope_on() {} # at compile-time, some should be defined and others shouldn't be BEGIN { method_defined('top_level_default'); method_undefined('top_level_off'); method_defined('top_level_on'); method_undefined('inner_scope_off'); method_defined('outer_scope_on'); } # by run-time, they should _all_ be defined method_defined('top_level_default'); method_defined('top_level_off'); method_defined('top_level_on'); method_defined('inner_scope_off'); method_defined('outer_scope_on'); done_testing; Function-Parameters-2.001003/t/foreign/Fun/0000755000175000017500000000000013201556460017241 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/Fun/compile-time.t0000644000175000017500000000022213076614101022003 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters; is(foo(), "FOO"); fun foo() { "FOO" } done_testing; Function-Parameters-2.001003/t/foreign/Fun/slurpy.t0000644000175000017500000000066412400633742020771 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters; fun test_array ( $foo, @bar ) { return [ $foo, @bar ]; } fun test_hash ( $foo, %bar ) { return { foo => $foo, %bar }; } is_deeply( test_array( 1, 2 .. 10 ), [ 1, 2 .. 10 ], '... slurpy array worked' ); is_deeply( test_hash( 1, ( two => 2, three => 3 ) ), { foo => 1, two => 2, three => 3 }, '... slurpy hash worked' ); done_testing; Function-Parameters-2.001003/t/foreign/Fun/state.t0000644000175000017500000000027212400633742020546 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use 5.10.0; use Function::Parameters; fun bar ($y) { state $x = 10; $x * $y; } is(bar(3), 30); done_testing; Function-Parameters-2.001003/t/foreign/Fun/defaults.t0000644000175000017500000000226413076614101021236 0ustar maukemauke#!perl use strict; use warnings; use Test::More; use Function::Parameters qw(:lax); fun foo ($x, $y = 5) { return $x + $y; } is(foo(3, 4), 7); is(foo(3), 8); { my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; is(foo, 5); like($warning, qr/Use of uninitialized value \$x in addition \(\+\)/); } fun bar ($baz, $quux = foo(1) * 2, $blorg = sub { return "ran sub, got " . $_[0] }) { $blorg->($baz + $quux); } is(bar(3, 4, sub { $_[0] }), 7); is(bar(5, 6), "ran sub, got 11"); is(bar(7), "ran sub, got 19"); { my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; is(bar, "ran sub, got 12"); like($warning, qr/Use of uninitialized value \$baz in addition \(\+\)/); } fun baz ($a, $b = our $FOO) { return "$a $b"; } { no warnings 'misc'; # 'not imported' warning because we use $FOO later eval '$FOO'; like($@, qr/Global symbol "\$FOO" requires explicit package name/, "doesn't leak scope"); } our $FOO = "abc"; is(baz("123"), "123 abc"); fun goorch ($x, $y = []) { return $y } my $goorch_y_1 = goorch( 10 ); my $goorch_y_2 = goorch( 10 ); isnt($goorch_y_1, $goorch_y_2, '... not the same reference'); done_testing; Function-Parameters-2.001003/t/foreign/Fun/recursion.t0000644000175000017500000000101312400633742021431 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; BEGIN { if (!eval { require 5.016; 1 }) { plan skip_all => "This test requires 5.16"; } } use 5.016; use Function::Parameters; fun fact ($n) { if ($n < 2) { return 1; } return $n * __SUB__->($n - 1); } is(fact(5), 120); is(fun ($n = 8) { $n < 2 ? 1 : $n * __SUB__->($n - 1) }->(), 40320); fun fact2 ($n) { if ($n < 2) { return 1; } return $n * fact2($n - 1); } is(fact2(5), 120); done_testing; Function-Parameters-2.001003/t/foreign/Fun/anon.t0000644000175000017500000000034612400633742020363 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters; my $fun = fun ($x, $y) { $x * $y }; is($fun->(3, 4), 12); my $fun2 = fun ($z, $w = 10) { $z / $w }; is($fun2->(60), 6); done_testing; Function-Parameters-2.001003/t/foreign/Fun/slurpy-syntax-errors.t0000644000175000017500000000070612400633742023624 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters; { eval 'fun ( $foo, @bar, $baz ) { return [] }'; ok $@, '... got an error'; } { eval 'fun ( $foo, %bar, $baz ) { return {} }'; ok $@, '... got an error'; } { eval 'fun ( $foo, @bar, %baz ) { return [] }'; ok $@, '... got an error'; } { eval 'fun ( $foo, %bar, @baz ) { return {} }'; ok $@, '... got an error'; } done_testing; Function-Parameters-2.001003/t/foreign/Fun/package.t0000644000175000017500000000032612400633742021021 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters; fun Foo::foo ($x, $y) { $x + $y; } ok(!main->can('foo')); ok(Foo->can('foo')); is(Foo::foo(1, 2), 3); done_testing; Function-Parameters-2.001003/t/foreign/Fun/basic.t0000644000175000017500000000061213076614101020503 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters; fun mul ($x, $y) { return $x * $y; } is(mul(3, 4), 12); fun sum (@nums) { my $sum; for my $num (@nums) { $sum += $num; } return $sum; } is(sum(1, 2, 3, 4), 10); { package Foo; use Function::Parameters; fun foo() { } } ok(exists $Foo::{foo}); done_testing; Function-Parameters-2.001003/t/foreign/Fun/name.t0000644000175000017500000000162512445730375020362 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Carp; my $file = __FILE__; my $line = __LINE__; { package Foo; use Function::Parameters; fun foo ($x, $y) { Carp::confess "$x $y"; } eval { foo("abc", "123"); }; my $line_confess = $line + 6; my $line_foo = $line + 10; ::like($@, qr/^abc 123 at \Q$file\E line $line_confess\.?\n\tFoo::foo\((["'])abc\1, 123\) called at \Q$file\E line $line_foo/); } SKIP: { skip "Sub::Name required", 1 unless eval { require Sub::Name }; { package Bar; use Function::Parameters; *bar = Sub::Name::subname(bar => fun ($a, $b) { Carp::confess($a + $b) }); eval { bar(4, 5); }; my $line_confess = $line + 24; my $line_bar = $line + 27; ::like($@, qr/^9 at \Q$file\E line $line_confess\.?\n\tBar::bar\(4, 5\) called at \Q$file\E line $line_bar/); } } done_testing; Function-Parameters-2.001003/t/foreign/Fun/closure-proto.t0000644000175000017500000000027312400633742022244 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Function::Parameters; { my $x = 10; fun bar ($y) { $x * $y } } is(bar(3), 30); done_testing; Function-Parameters-2.001003/t/foreign/signatures/0000755000175000017500000000000013201556460020675 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/signatures/anon.t0000644000175000017500000000030312400633742022010 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 1; use Function::Parameters; my $foo = fun ($bar, $baz) { return "${bar}-${baz}" }; is($foo->(qw/bar baz/), 'bar-baz'); Function-Parameters-2.001003/t/foreign/signatures/basic.t0000644000175000017500000000102112400633742022134 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 5; use Function::Parameters; fun foo ($bar) { $bar } fun korv ($wurst, $_unused, $birne) { return "${wurst}-${birne}"; } fun array ($scalar, @array) { return $scalar + @array; } fun hash (%hash) { return keys %hash; } fun Name::space ($moo) { $moo } is(foo('baz'), 'baz'); is(korv(qw/a b c/), 'a-c'); is(array(10, 1..10), 20); is_deeply( [sort(hash(foo => 1, bar => 2))], [sort(qw/foo bar/)], ); is(Name::space('kooh'), 'kooh'); Function-Parameters-2.001003/t/foreign/signatures/eval.t0000644000175000017500000000137312400633742022014 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 8; use Function::Parameters; eval 'fun foo ($bar) { $bar }'; ok(!$@, 'signatures parse in eval'); diag $@ if $@; ok(\&foo, 'fun declared in eval'); is(foo(42), 42, 'eval signature works'); no Function::Parameters; $SIG{__WARN__} = sub {}; eval 'fun bar ($baz) { $baz }'; like($@, qr/requires explicit package name/, 'string eval disabled'); { use Function::Parameters; eval 'fun bar ($baz) { $baz }'; ok(!$@, 'signatures parse in eval'); diag $@ if $@; ok(\&bar, 'fun declared in eval'); is(bar(42), 42, 'eval signature works'); } $SIG{__WARN__} = sub {}; eval 'fun moo ($kooh) { $kooh }'; like($@, qr/requires explicit package name/, 'string eval disabled'); Function-Parameters-2.001003/t/foreign/signatures/weird.t0000644000175000017500000000064712400633742022202 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 2; use Function::Parameters; fun foo ($bar, $baz) { return q{($bar, $baz) is }.qq{("$bar", "$baz")} } my $moo = fun ($bar, $baz) { return q{($bar, $baz) is }.qq{("$bar", "$baz")} }; is(foo(qw/affe zomtec/), '($bar, $baz) is ("affe", "zomtec")'); is($moo->(qw/korv wurst/), '($bar, $baz) is ("korv", "wurst")'); 1; Function-Parameters-2.001003/t/foreign/signatures/proto.t0000644000175000017500000000210113076614102022215 0ustar maukemauke#!perl use strict; use warnings; use Test::More tests => 7; use vars qw/@warnings/; BEGIN { $SIG{__WARN__} = sub { push @warnings, @_ } } BEGIN { is(@warnings, 0, 'no warnings yet') } use Function::Parameters; fun with_proto ($x, $y, $z) : prototype($$$) { return $x + $y + $z; } { my $foo; fun with_lvalue () : prototype() lvalue { $foo } } is(prototype('with_proto'), '$$$', ':proto attribute'); is(prototype('with_lvalue'), '', ':proto with other attributes'); with_lvalue = 1; is(with_lvalue, 1, 'other attributes still there'); BEGIN { is(@warnings, 0, 'no warnings with correct :proto declarations') } fun invalid_proto ($x) : prototype(invalid) { $x } BEGIN { #TODO: { # local $TODO = ':proto checks not yet implemented'; is(@warnings, 1, 'warning with illegal :proto'); like( $warnings[0], qr/Illegal character in prototype for fun invalid_proto : invalid at /, 'warning looks sane', ); #} } #eval 'sub foo ($bar) : proto { $bar }'; #like($@, qr/proto attribute requires argument/); Function-Parameters-2.001003/t/foreign/perl/0000755000175000017500000000000013201556460017453 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/perl/signatures.t0000644000175000017500000011574713076614102022041 0ustar maukemauke#!perl use Test::More tests => 842; use strict; use warnings FATAL => 'all'; no warnings 'void'; use Function::Parameters { sub => 'function_strict' }; our $a = 123; our $z; sub t001 (@) { $a || "z" } is prototype(\&t001), undef; is eval("t001()"), 123; is eval("t001(456)"), 123; is eval("t001(456, 789)"), 123; is $a, 123; sub t002 () { $a || "z" } is prototype(\&t002), undef; is eval("t002()"), 123; is eval("t002(456)"), undef; like $@, qr/\AToo many arguments for /; is eval("t002(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t003 ( ) { $a || "z" } is prototype(\&t003), undef; is eval("t003()"), 123; is eval("t003(456)"), undef; like $@, qr/\AToo many arguments for /; is eval("t003(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t006 ($a) { $a || "z" } is prototype(\&t006), undef; is eval("t006()"), undef; like $@, qr/\AToo few arguments for /; is eval("t006(0)"), "z"; is eval("t006(456)"), 456; is eval("t006(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t006(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t007 ($a, $b) { $a.$b } is prototype(\&t007), undef; is eval("t007()"), undef; like $@, qr/\AToo few arguments for /; is eval("t007(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t007(456, 789)"), "456789"; is eval("t007(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t007(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t008 ($a, $b, $c) { $a.$b.$c } is prototype(\&t008), undef; is eval("t008()"), undef; like $@, qr/\AToo few arguments for /; is eval("t008(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t008(456, 789)"), undef; like $@, qr/\AToo few arguments for /; is eval("t008(456, 789, 987)"), "456789987"; is eval("t008(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t009 ($abc, $def) { $abc.$def } is prototype(\&t009), undef; is eval("t009()"), undef; like $@, qr/\AToo few arguments for /; is eval("t009(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t009(456, 789)"), "456789"; is eval("t009(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t009(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t010 ($a, $) { $a || "z" } is prototype(\&t010), undef; is eval("t010()"), undef; like $@, qr/\AToo few arguments for /; is eval("t010(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t010(0, 789)"), "z"; is eval("t010(456, 789)"), 456; is eval("t010(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t010(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t011 ($, $a) { $a || "z" } is prototype(\&t011), undef; is eval("t011()"), undef; like $@, qr/\AToo few arguments for /; is eval("t011(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t011(456, 0)"), "z"; is eval("t011(456, 789)"), 789; is eval("t011(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t011(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t012 ($, $) { $a || "z" } is prototype(\&t012), undef; is eval("t012()"), undef; like $@, qr/\AToo few arguments for /; is eval("t012(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t012(0, 789)"), 123; is eval("t012(456, 789)"), 123; is eval("t012(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t012(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t013 ($) { $a || "z" } is prototype(\&t013), undef; is eval("t013()"), undef; like $@, qr/\AToo few arguments for /; is eval("t013(0)"), 123; is eval("t013(456)"), 123; is eval("t013(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t013(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t013(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t014 ($a = 222) { $a // "z" } is prototype(\&t014), undef; is eval("t014()"), 222; is eval("t014(0)"), 0; is eval("t014(undef)"), "z"; is eval("t014(456)"), 456; is eval("t014(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t014(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t015 ($a = undef) { $a // "z" } is prototype(\&t015), undef; is eval("t015()"), "z"; is eval("t015(0)"), 0; is eval("t015(undef)"), "z"; is eval("t015(456)"), 456; is eval("t015(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t015(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t016 ($a = do { $z++; 222 }) { $a // "z" } $z = 0; is prototype(\&t016), undef; is eval("t016()"), 222; is $z, 1; is eval("t016(0)"), 0; is eval("t016(undef)"), "z"; is eval("t016(456)"), 456; is eval("t016(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t016(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $z, 1; is eval("t016()"), 222; is $z, 2; is $a, 123; sub t018 (@) { join("/", @_) } sub t017 ($p = t018 222, $a = 333) { $p // "z" } is prototype(\&t017), undef; is eval("t017()"), "222/333"; is $a, 333; $a = 123; is eval("t017(0)"), 0; is eval("t017(undef)"), "z"; is eval("t017(456)"), 456; is eval("t017(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t017(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t019 ($p = 222, $a = 333) { "$p/$a" } is prototype(\&t019), undef; is eval("t019()"), "222/333"; is eval("t019(0)"), "0/333"; is eval("t019(456)"), "456/333"; is eval("t019(456, 789)"), "456/789"; is eval("t019(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t020 (@) :prototype($) { $_[0]."z" } sub t021 ($p = t020 222, $a = 333) { "$p/$a" } is prototype(\&t021), undef; is eval("t021()"), "222z/333"; is eval("t021(0)"), "0/333"; is eval("t021(456)"), "456/333"; is eval("t021(456, 789)"), "456/789"; is eval("t021(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t022 ($p = do { $z += 10; 222 }, $a = do { $z++; 333 }) { "$p/$a" } $z = 0; is prototype(\&t022), undef; is eval("t022()"), "222/333"; is $z, 11; is eval("t022(0)"), "0/333"; is $z, 12; is eval("t022(456)"), "456/333"; is $z, 13; is eval("t022(456, 789)"), "456/789"; is eval("t022(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $z, 13; is $a, 123; sub t023 ($a = sub (@) { $_[0]."z" }) { $a->("a")."y" } is prototype(\&t023), undef; is eval("t023()"), "azy"; is eval("t023(sub (@) { \"x\".\$_[0].\"x\" })"), "xaxy"; is eval("t023(sub (@) { \"x\".\$_[0].\"x\" }, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t036 ($a = $a."x") { $a."y" } is prototype(\&t036), undef; is eval("t036()"), "123xy"; is eval("t036(0)"), "0y"; is eval("t036(456)"), "456y"; is eval("t036(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t120 ($a = $_) { $a // "z" } is prototype(\&t120), undef; $_ = "___"; is eval("t120()"), "___"; $_ = "___"; is eval("t120(undef)"), "z"; $_ = "___"; is eval("t120(0)"), 0; $_ = "___"; is eval("t120(456)"), 456; $_ = "___"; is eval("t120(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t121 ($a = caller) { $a // "z" } is prototype(\&t121), undef; is eval("t121()"), "main"; is eval("t121(undef)"), "z"; is eval("t121(0)"), 0; is eval("t121(456)"), 456; is eval("t121(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("package T121::Z; ::t121()"), "T121::Z"; is eval("package T121::Z; ::t121(undef)"), "z"; is eval("package T121::Z; ::t121(0)"), 0; is eval("package T121::Z; ::t121(456)"), 456; is eval("package T121::Z; ::t121(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t129 ($a = return 222) { $a."x" } is prototype(\&t129), undef; is eval("t129()"), "222"; is eval("t129(0)"), "0x"; is eval("t129(456)"), "456x"; is eval("t129(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; SKIP: { skip "__SUB__ not available in this perl", 9 unless $] >= 5.016; eval q{ use feature "current_sub"; sub t122 ($c = 5, $r = $c > 0 ? __SUB__->($c - 1) : "") { $c.$r } }; die $@ if $@; is prototype(\&t122), undef; is eval("t122()"), "543210"; is eval("t122(0)"), "0"; is eval("t122(1)"), "10"; is eval("t122(5)"), "543210"; is eval("t122(5, 789)"), "5789"; is eval("t122(5, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; } sub t123 ($list = wantarray) { $list ? "list" : "scalar" } is prototype(\&t123), undef; is eval("scalar(t123())"), "scalar"; is eval("(t123())[0]"), "list"; is eval("scalar(t123(0))"), "scalar"; is eval("(t123(0))[0]"), "scalar"; is eval("scalar(t123(1))"), "list"; is eval("(t123(1))[0]"), "list"; is eval("t123(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t124 ($b = (local $a = $a + 1)) { "$a/$b" } is prototype(\&t124), undef; is eval("t124()"), "124/124"; is $a, 123; is eval("t124(456)"), "123/456"; is $a, 123; is eval("t124(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t125 ($c = (our $t125_counter)++) { $c } is prototype(\&t125), undef; is eval("t125()"), 0; is eval("t125()"), 1; is eval("t125()"), 2; is eval("t125(456)"), 456; is eval("t125(789)"), 789; is eval("t125()"), 3; is eval("t125()"), 4; is eval("t125(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; use feature "state"; sub t126 ($c = (state $s = $z++)) { $c } is prototype(\&t126), undef; $z = 222; is eval("t126(456)"), 456; is $z, 222; is eval("t126()"), 222; is $z, 223; is eval("t126(456)"), 456; is $z, 223; is eval("t126()"), 222; is $z, 223; is eval("t126(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $z, 223; is $a, 123; sub t127 ($c = do { state $s = $z++; $s++ }) { $c } is prototype(\&t127), undef; $z = 222; is eval("t127(456)"), 456; is $z, 222; is eval("t127()"), 222; is $z, 223; is eval("t127()"), 223; is eval("t127()"), 224; is $z, 223; is eval("t127(456)"), 456; is eval("t127(789)"), 789; is eval("t127()"), 225; is eval("t127()"), 226; is eval("t127(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is $z, 223; is $a, 123; sub t037 ($a = 222, $b = $a."x") { "$a/$b" } is prototype(\&t037), undef; is eval("t037()"), "222/222x"; is eval("t037(0)"), "0/0x"; is eval("t037(456)"), "456/456x"; is eval("t037(456, 789)"), "456/789"; is eval("t037(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t128 ($a = 222, $b = ($a = 333)) { "$a/$b" } is prototype(\&t128), undef; is eval("t128()"), "333/333"; is eval("t128(0)"), "333/333"; is eval("t128(456)"), "333/333"; is eval("t128(456, 789)"), "456/789"; is eval("t128(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t130 (@) { join(",", @_).";".scalar(@_) } sub t131 ($a = 222, $b = goto &t130) { "$a/$b" } is prototype(\&t131), undef; is eval("t131()"), ";0"; is eval("t131(0)"), "0;1"; is eval("t131(456)"), "456;1"; is eval("t131(456, 789)"), "456/789"; is eval("t131(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; #eval "#line 8 foo\nsub t024 (\$a =) { }"; #is $@, "Optional parameter lacks default expression at foo line 8\.\n"; sub t025 ($ = undef) { $a // "z" } is prototype(\&t025), undef; is eval("t025()"), 123; is eval("t025(0)"), 123; is eval("t025(456)"), 123; is eval("t025(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t025(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t025(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t026 ($ = 222) { $a // "z" } is prototype(\&t026), undef; is eval("t026()"), 123; is eval("t026(0)"), 123; is eval("t026(456)"), 123; is eval("t026(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t026(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t026(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t032 ($ = do { $z++; 222 }) { $a // "z" } $z = 0; is prototype(\&t032), undef; is eval("t032()"), 123; is $z, 1; is eval("t032(0)"), 123; is eval("t032(456)"), 123; is eval("t032(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t032(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t032(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $z, 1; is $a, 123; sub t027 ($ =) { $a // "z" } is prototype(\&t027), undef; is eval("t027()"), 123; is eval("t027(0)"), 123; is eval("t027(456)"), 123; is eval("t027(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t027(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t027(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t119 ($ =, $a = 333) { $a // "z" } is prototype(\&t119), undef; is eval("t119()"), 333; is eval("t119(0)"), 333; is eval("t119(456)"), 333; is eval("t119(456, 789)"), 789; is eval("t119(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t119(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t028 ($a, $b = 333) { "$a/$b" } is prototype(\&t028), undef; is eval("t028()"), undef; like $@, qr/\AToo few arguments for /; is eval("t028(0)"), "0/333"; is eval("t028(456)"), "456/333"; is eval("t028(456, 789)"), "456/789"; is eval("t028(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t045 ($a, $ = 333) { "$a/" } is prototype(\&t045), undef; is eval("t045()"), undef; like $@, qr/\AToo few arguments for /; is eval("t045(0)"), "0/"; is eval("t045(456)"), "456/"; is eval("t045(456, 789)"), "456/"; is eval("t045(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t046 ($, $b = 333) { "$a/$b" } is prototype(\&t046), undef; is eval("t046()"), undef; like $@, qr/\AToo few arguments for /; is eval("t046(0)"), "123/333"; is eval("t046(456)"), "123/333"; is eval("t046(456, 789)"), "123/789"; is eval("t046(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t047 ($, $ = 333) { "$a/" } is prototype(\&t047), undef; is eval("t047()"), undef; like $@, qr/\AToo few arguments for /; is eval("t047(0)"), "123/"; is eval("t047(456)"), "123/"; is eval("t047(456, 789)"), "123/"; is eval("t047(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t029 ($a, $b, $c = 222, $d = 333) { "$a/$b/$c/$d" } is prototype(\&t029), undef; is eval("t029()"), undef; like $@, qr/\AToo few arguments for /; is eval("t029(0)"), undef; like $@, qr/\AToo few arguments for /; is eval("t029(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t029(456, 789)"), "456/789/222/333"; is eval("t029(456, 789, 987)"), "456/789/987/333"; is eval("t029(456, 789, 987, 654)"), "456/789/987/654"; is eval("t029(456, 789, 987, 654, 321)"), undef; like $@, qr/\AToo many arguments for /; is eval("t029(456, 789, 987, 654, 321, 111)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t038 ($a, $b = $a."x") { "$a/$b" } is prototype(\&t038), undef; is eval("t038()"), undef; like $@, qr/\AToo few arguments for /; is eval("t038(0)"), "0/0x"; is eval("t038(456)"), "456/456x"; is eval("t038(456, 789)"), "456/789"; is eval("t038(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; eval "#line 8 foo\nsub t030 (\$a = 222, \$b) { }"; #is $@, "Mandatory parameter follows optional parameter at foo line 8\.\n"; is $@, "In sub t030: required parameter \$b can't appear after optional parameter \$a at foo line 8.\n"; eval "#line 8 foo\nsub t031 (\$a = 222, \$b = 333, \$c, \$d) { }"; #is $@, "Mandatory parameter follows optional parameter at foo line 8\.\n"; is $@, "In sub t031: required parameter \$c can't appear after optional parameter \$a at foo line 8.\n"; sub t034 (@abc) { join("/", @abc).";".scalar(@abc) } is prototype(\&t034), undef; is eval("t034()"), ";0"; is eval("t034(0)"), "0;1"; is eval("t034(456)"), "456;1"; is eval("t034(456, 789)"), "456/789;2"; is eval("t034(456, 789, 987)"), "456/789/987;3"; is eval("t034(456, 789, 987, 654)"), "456/789/987/654;4"; is eval("t034(456, 789, 987, 654, 321)"), "456/789/987/654/321;5"; is eval("t034(456, 789, 987, 654, 321, 111)"), "456/789/987/654/321/111;6"; is $a, 123; eval "#line 8 foo\nsub t136 (\@abc = 222) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/default value/; eval "#line 8 foo\nsub t137 (\@abc =) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/default value/; sub t035 (@) { $a } is prototype(\&t035), undef; is eval("t035()"), 123; is eval("t035(0)"), 123; is eval("t035(456)"), 123; is eval("t035(456, 789)"), 123; is eval("t035(456, 789, 987)"), 123; is eval("t035(456, 789, 987, 654)"), 123; is eval("t035(456, 789, 987, 654, 321)"), 123; is eval("t035(456, 789, 987, 654, 321, 111)"), 123; is $a, 123; eval "#line 8 foo\nsub t138 (\@ = 222) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/default value/; eval "#line 8 foo\nsub t139 (\@ =) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/default value/; sub t039 (%abc) { join("/", map { $_."=".$abc{$_} } sort keys %abc) } is prototype(\&t039), undef; is eval("t039()"), ""; is eval("t039(0)"), undef; like $@, qr#\AOdd#; is eval("t039(456)"), undef; like $@, qr#\AOdd#; is eval("t039(456, 789)"), "456=789"; is eval("t039(456, 789, 987)"), undef; like $@, qr#\AOdd#; is eval("t039(456, 789, 987, 654)"), "456=789/987=654"; is eval("t039(456, 789, 987, 654, 321)"), undef; like $@, qr#\AOdd#; is eval("t039(456, 789, 987, 654, 321, 111)"), "321=111/456=789/987=654"; is $a, 123; eval "#line 8 foo\nsub t140 (\%abc = 222) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/default value/; eval "#line 8 foo\nsub t141 (\%abc =) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/default value/; sub t040 (%) { $a } is prototype(\&t040), undef; is eval("t040()"), 123; is eval("t040(0)"), undef; like $@, qr#\AOdd#; is eval("t040(456)"), undef; like $@, qr#\AOdd#; is eval("t040(456, 789)"), 123; is eval("t040(456, 789, 987)"), undef; like $@, qr#\AOdd#; is eval("t040(456, 789, 987, 654)"), 123; is eval("t040(456, 789, 987, 654, 321)"), undef; like $@, qr#\AOdd#; is eval("t040(456, 789, 987, 654, 321, 111)"), 123; is $a, 123; eval "#line 8 foo\nsub t142 (\% = 222) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/default value/; eval "#line 8 foo\nsub t143 (\% =) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/default value/; sub t041 ($a, @b) { $a.";".join("/", @b) } is prototype(\&t041), undef; is eval("t041()"), undef; like $@, qr/\AToo few arguments for /; is eval("t041(0)"), "0;"; is eval("t041(456)"), "456;"; is eval("t041(456, 789)"), "456;789"; is eval("t041(456, 789, 987)"), "456;789/987"; is eval("t041(456, 789, 987, 654)"), "456;789/987/654"; is eval("t041(456, 789, 987, 654, 321)"), "456;789/987/654/321"; is eval("t041(456, 789, 987, 654, 321, 111)"), "456;789/987/654/321/111"; is $a, 123; sub t042 ($a, @) { $a.";" } is prototype(\&t042), undef; is eval("t042()"), undef; like $@, qr/\AToo few arguments for /; is eval("t042(0)"), "0;"; is eval("t042(456)"), "456;"; is eval("t042(456, 789)"), "456;"; is eval("t042(456, 789, 987)"), "456;"; is eval("t042(456, 789, 987, 654)"), "456;"; is eval("t042(456, 789, 987, 654, 321)"), "456;"; is eval("t042(456, 789, 987, 654, 321, 111)"), "456;"; is $a, 123; sub t043 ($, @b) { $a.";".join("/", @b) } is prototype(\&t043), undef; is eval("t043()"), undef; like $@, qr/\AToo few arguments for /; is eval("t043(0)"), "123;"; is eval("t043(456)"), "123;"; is eval("t043(456, 789)"), "123;789"; is eval("t043(456, 789, 987)"), "123;789/987"; is eval("t043(456, 789, 987, 654)"), "123;789/987/654"; is eval("t043(456, 789, 987, 654, 321)"), "123;789/987/654/321"; is eval("t043(456, 789, 987, 654, 321, 111)"), "123;789/987/654/321/111"; is $a, 123; sub t044 ($, @) { $a.";" } is prototype(\&t044), undef; is eval("t044()"), undef; like $@, qr/\AToo few arguments for /; is eval("t044(0)"), "123;"; is eval("t044(456)"), "123;"; is eval("t044(456, 789)"), "123;"; is eval("t044(456, 789, 987)"), "123;"; is eval("t044(456, 789, 987, 654)"), "123;"; is eval("t044(456, 789, 987, 654, 321)"), "123;"; is eval("t044(456, 789, 987, 654, 321, 111)"), "123;"; is $a, 123; sub t049 ($a, %b) { $a.";".join("/", map { $_."=".$b{$_} } sort keys %b) } is prototype(\&t049), undef; is eval("t049()"), undef; like $@, qr/\AToo few arguments for /; is eval("t049(222)"), "222;"; is eval("t049(222, 456)"), undef; like $@, qr#\AOdd#; is eval("t049(222, 456, 789)"), "222;456=789"; is eval("t049(222, 456, 789, 987)"), undef; like $@, qr#\AOdd#; is eval("t049(222, 456, 789, 987, 654)"), "222;456=789/987=654"; is eval("t049(222, 456, 789, 987, 654, 321)"), undef; like $@, qr#\AOdd#; is eval("t049(222, 456, 789, 987, 654, 321, 111)"), "222;321=111/456=789/987=654"; is $a, 123; sub t051 ($a, $b, $c, @d) { "$a;$b;$c;".join("/", @d).";".scalar(@d) } is prototype(\&t051), undef; is eval("t051()"), undef; like $@, qr/\AToo few arguments for /; is eval("t051(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t051(456, 789)"), undef; like $@, qr/\AToo few arguments for /; is eval("t051(456, 789, 987)"), "456;789;987;;0"; is eval("t051(456, 789, 987, 654)"), "456;789;987;654;1"; is eval("t051(456, 789, 987, 654, 321)"), "456;789;987;654/321;2"; is eval("t051(456, 789, 987, 654, 321, 111)"), "456;789;987;654/321/111;3"; is $a, 123; sub t052 ($a, $b, %c) { "$a;$b;".join("/", map { $_."=".$c{$_} } sort keys %c) } is prototype(\&t052), undef; is eval("t052()"), undef; like $@, qr/\AToo few arguments for /; is eval("t052(222)"), undef; like $@, qr/\AToo few arguments for /; is eval("t052(222, 333)"), "222;333;"; is eval("t052(222, 333, 456)"), undef; like $@, qr#\AOdd#; is eval("t052(222, 333, 456, 789)"), "222;333;456=789"; is eval("t052(222, 333, 456, 789, 987)"), undef; like $@, qr#\AOdd#; is eval("t052(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654"; is eval("t052(222, 333, 456, 789, 987, 654, 321)"), undef; like $@, qr#\AOdd#; is eval("t052(222, 333, 456, 789, 987, 654, 321, 111)"), "222;333;321=111/456=789/987=654"; is $a, 123; sub t053 ($a, $b, $c, %d) { "$a;$b;$c;".join("/", map { $_."=".$d{$_} } sort keys %d) } is prototype(\&t053), undef; is eval("t053()"), undef; like $@, qr/\AToo few arguments for /; is eval("t053(222)"), undef; like $@, qr/\AToo few arguments for /; is eval("t053(222, 333)"), undef; like $@, qr/\AToo few arguments for /; is eval("t053(222, 333, 444)"), "222;333;444;"; is eval("t053(222, 333, 444, 456)"), undef; like $@, qr#\AOdd#; is eval("t053(222, 333, 444, 456, 789)"), "222;333;444;456=789"; is eval("t053(222, 333, 444, 456, 789, 987)"), undef; like $@, qr#\AOdd#; is eval("t053(222, 333, 444, 456, 789, 987, 654)"), "222;333;444;456=789/987=654"; is eval("t053(222, 333, 444, 456, 789, 987, 654, 321)"), undef; like $@, qr#\AOdd#; is eval("t053(222, 333, 444, 456, 789, 987, 654, 321, 111)"), "222;333;444;321=111/456=789/987=654"; is $a, 123; sub t048 ($a = 222, @b) { $a.";".join("/", @b).";".scalar(@b) } is prototype(\&t048), undef; is eval("t048()"), "222;;0"; is eval("t048(0)"), "0;;0"; is eval("t048(456)"), "456;;0"; is eval("t048(456, 789)"), "456;789;1"; is eval("t048(456, 789, 987)"), "456;789/987;2"; is eval("t048(456, 789, 987, 654)"), "456;789/987/654;3"; is eval("t048(456, 789, 987, 654, 321)"), "456;789/987/654/321;4"; is eval("t048(456, 789, 987, 654, 321, 111)"), "456;789/987/654/321/111;5"; is $a, 123; sub t054 ($a = 222, $b = 333, @c) { "$a;$b;".join("/", @c).";".scalar(@c) } is prototype(\&t054), undef; is eval("t054()"), "222;333;;0"; is eval("t054(456)"), "456;333;;0"; is eval("t054(456, 789)"), "456;789;;0"; is eval("t054(456, 789, 987)"), "456;789;987;1"; is eval("t054(456, 789, 987, 654)"), "456;789;987/654;2"; is eval("t054(456, 789, 987, 654, 321)"), "456;789;987/654/321;3"; is eval("t054(456, 789, 987, 654, 321, 111)"), "456;789;987/654/321/111;4"; is $a, 123; sub t055 ($a = 222, $b = 333, $c = 444, @d) { "$a;$b;$c;".join("/", @d).";".scalar(@d) } is prototype(\&t055), undef; is eval("t055()"), "222;333;444;;0"; is eval("t055(456)"), "456;333;444;;0"; is eval("t055(456, 789)"), "456;789;444;;0"; is eval("t055(456, 789, 987)"), "456;789;987;;0"; is eval("t055(456, 789, 987, 654)"), "456;789;987;654;1"; is eval("t055(456, 789, 987, 654, 321)"), "456;789;987;654/321;2"; is eval("t055(456, 789, 987, 654, 321, 111)"), "456;789;987;654/321/111;3"; is $a, 123; sub t050 ($a = 211, %b) { $a.";".join("/", map { $_."=".$b{$_} } sort keys %b) } is prototype(\&t050), undef; is eval("t050()"), "211;"; is eval("t050(222)"), "222;"; is eval("t050(222, 456)"), undef; like $@, qr#\AOdd#; is eval("t050(222, 456, 789)"), "222;456=789"; is eval("t050(222, 456, 789, 987)"), undef; like $@, qr#\AOdd#; is eval("t050(222, 456, 789, 987, 654)"), "222;456=789/987=654"; is eval("t050(222, 456, 789, 987, 654, 321)"), undef; like $@, qr#\AOdd#; is eval("t050(222, 456, 789, 987, 654, 321, 111)"), "222;321=111/456=789/987=654"; is $a, 123; sub t056 ($a = 211, $b = 311, %c) { "$a;$b;".join("/", map { $_."=".$c{$_} } sort keys %c) } is prototype(\&t056), undef; is eval("t056()"), "211;311;"; is eval("t056(222)"), "222;311;"; is eval("t056(222, 333)"), "222;333;"; is eval("t056(222, 333, 456)"), undef; like $@, qr#\AOdd#; is eval("t056(222, 333, 456, 789)"), "222;333;456=789"; is eval("t056(222, 333, 456, 789, 987)"), undef; like $@, qr#\AOdd#; is eval("t056(222, 333, 456, 789, 987, 654)"), "222;333;456=789/987=654"; is eval("t056(222, 333, 456, 789, 987, 654, 321)"), undef; like $@, qr#\AOdd#; is eval("t056(222, 333, 456, 789, 987, 654, 321, 111)"), "222;333;321=111/456=789/987=654"; is $a, 123; sub t057 ($a = 211, $b = 311, $c = 411, %d) { "$a;$b;$c;".join("/", map { $_."=".$d{$_} } sort keys %d) } is prototype(\&t057), undef; is eval("t057()"), "211;311;411;"; is eval("t057(222)"), "222;311;411;"; is eval("t057(222, 333)"), "222;333;411;"; is eval("t057(222, 333, 444)"), "222;333;444;"; is eval("t057(222, 333, 444, 456)"), undef; like $@, qr#\AOdd#; is eval("t057(222, 333, 444, 456, 789)"), "222;333;444;456=789"; is eval("t057(222, 333, 444, 456, 789, 987)"), undef; like $@, qr#\AOdd#; is eval("t057(222, 333, 444, 456, 789, 987, 654)"), "222;333;444;456=789/987=654"; is eval("t057(222, 333, 444, 456, 789, 987, 654, 321)"), undef; like $@, qr#\AOdd#; is eval("t057(222, 333, 444, 456, 789, 987, 654, 321, 111)"), "222;333;444;321=111/456=789/987=654"; is $a, 123; sub t058 ($a, $b = 333, @c) { "$a;$b;".join("/", @c).";".scalar(@c) } is prototype(\&t058), undef; is eval("t058()"), undef; like $@, qr/\AToo few arguments for /; is eval("t058(456)"), "456;333;;0"; is eval("t058(456, 789)"), "456;789;;0"; is eval("t058(456, 789, 987)"), "456;789;987;1"; is eval("t058(456, 789, 987, 654)"), "456;789;987/654;2"; is eval("t058(456, 789, 987, 654, 321)"), "456;789;987/654/321;3"; is eval("t058(456, 789, 987, 654, 321, 111)"), "456;789;987/654/321/111;4"; is $a, 123; eval "#line 8 foo\nsub t059 (\@a, \$b) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t060 (\@a, \$b = 222) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t061 (\@a, \@b) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t062 (\@a, \%b) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t063 (\@, \$b) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t064 (\@, \$b = 222) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t065 (\@, \@b) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t066 (\@, \%b) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t067 (\@a, \$) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t068 (\@a, \$ = 222) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t069 (\@a, \@) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t070 (\@a, \%) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t071 (\@, \$) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t072 (\@, \$ = 222) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t073 (\@, \@) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t074 (\@, \%) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t075 (\%a, \$b) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t076 (\%, \$b) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t077 (\$a, \@b, \$c) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t078 (\$a, \%b, \$c) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; eval "#line 8 foo\nsub t079 (\$a, \@b, \$c, \$d) { }"; #is $@, "Slurpy parameter not last at foo line 8\.\n"; ok $@; #sub t080 ($a,,, $b) { $a.$b } #is prototype(\&t080), undef; #is eval("t080()"), undef; #like $@, qr/\AToo few arguments for /; #is eval("t080(456)"), undef; #like $@, qr/\AToo few arguments for /; #is eval("t080(456, 789)"), "456789"; #is eval("t080(456, 789, 987)"), undef; #like $@, qr/\AToo many arguments for /; #is eval("t080(456, 789, 987, 654)"), undef; #like $@, qr/\AToo many arguments for /; #is $a, 123; #sub t081 ($a, $b,,) { $a.$b } #is prototype(\&t081), undef; #is eval("t081()"), undef; #like $@, qr/\AToo few arguments for /; #is eval("t081(456)"), undef; #like $@, qr/\AToo few arguments for /; #is eval("t081(456, 789)"), "456789"; #is eval("t081(456, 789, 987)"), undef; #like $@, qr/\AToo many arguments for /; #is eval("t081(456, 789, 987, 654)"), undef; #like $@, qr/\AToo many arguments for /; #is $a, 123; eval "#line 8 foo\nsub t082 (, \$a) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected ','/; eval "#line 8 foo\nsub t083 (,) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected ','/; sub t084($a,$b){ $a.$b } is prototype(\&t084), undef; is eval("t084()"), undef; like $@, qr/\AToo few arguments for /; is eval("t084(456)"), undef; like $@, qr/\AToo few arguments for /; is eval("t084(456, 789)"), "456789"; is eval("t084(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is eval("t084(456, 789, 987, 654)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; #sub t085 # ( # $ # a # , # , # $ # b # = # 333 # , # , # ) # { $a.$b } #is prototype(\&t085), undef; #is eval("t085()"), undef; #like $@, qr/\AToo few arguments for /; #is eval("t085(456)"), "456333"; #is eval("t085(456, 789)"), "456789"; #is eval("t085(456, 789, 987)"), undef; #like $@, qr/\AToo many arguments for /; #is eval("t085(456, 789, 987, 654)"), undef; #like $@, qr/\AToo many arguments for /; #is $a, 123; #sub t086 # ( #foo))) # $ #foo))) # a #foo))) # , #foo))) # , #foo))) # $ #foo))) # b #foo))) # = #foo))) # 333 #foo))) # , #foo))) # , #foo))) # ) #foo))) # { $a.$b } #is prototype(\&t086), undef; #is eval("t086()"), undef; #like $@, qr/\AToo few arguments for /; #is eval("t086(456)"), "456333"; #is eval("t086(456, 789)"), "456789"; #is eval("t086(456, 789, 987)"), undef; #like $@, qr/\AToo many arguments for /; #is eval("t086(456, 789, 987, 654)"), undef; #like $@, qr/\AToo many arguments for /; #is $a, 123; #sub t087 # (#foo))) # $ #foo))) # a#foo))) # ,#foo))) # ,#foo))) # $ #foo))) # b#foo))) # =#foo))) # 333#foo))) # ,#foo))) # ,#foo))) # )#foo))) # { $a.$b } #is prototype(\&t087), undef; #is eval("t087()"), undef; #like $@, qr/\AToo few arguments for /; #is eval("t087(456)"), "456333"; #is eval("t087(456, 789)"), "456789"; #is eval("t087(456, 789, 987)"), undef; #like $@, qr/\AToo many arguments for /; #is eval("t087(456, 789, 987, 654)"), undef; #like $@, qr/\AToo many arguments for /; #is $a, 123; eval "#line 8 foo\nsub t088 (\$ #foo\na) { }"; is $@, ""; eval "#line 8 foo\nsub t089 (\$#foo\na) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected '\$#'/; eval "#line 8 foo\nsub t090 (\@ #foo\na) { }"; is $@, ""; eval "#line 8 foo\nsub t091 (\@#foo\na) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected '\@#'/; eval "#line 8 foo\nsub t092 (\% #foo\na) { }"; is $@, ""; eval "#line 8 foo\nsub t093 (\%#foo\na) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected '%#'/; eval "#line 8 foo\nsub t094 (123) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected '1'/; eval "#line 8 foo\nsub t095 (\$a, 123) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected '1'/; eval "#line 8 foo\nsub t096 (\$a 123) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected '1'/; eval "#line 8 foo\nsub t097 (\$a { }) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected '\{'/; eval "#line 8 foo\nsub t098 (\$a; \$b) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected ';'/; eval "#line 8 foo\nsub t099 (\$\$) { }"; #like $@, qr/\AParse error at foo line 8\.\n/; like $@, qr/unexpected '\$'/; #sub t100 ($_) { "$::_/$_" } #is prototype(\&t100), undef; #$_ = "___"; #is eval("t100()"), undef; #like $@, qr/\AToo few arguments for /; #$_ = "___"; #is eval("t100(0)"), "___/0"; #$_ = "___"; #is eval("t100(456)"), "___/456"; #$_ = "___"; #is eval("t100(456, 789)"), undef; #like $@, qr/\AToo many arguments for /; #$_ = "___"; #is eval("t100(456, 789, 987)"), undef; #like $@, qr/\AToo many arguments for /; #is $a, 123; eval "#line 8 foo\nsub t101 (\@_) { }"; like $@, qr/\bCan't use global \@_ .* at foo line 8/; eval "#line 8 foo\nsub t102 (\%_) { }"; like $@, qr/\bCan't use global \%_ .* at foo line 8/; my $t103 = sub ($a) { $a || "z" }; is prototype($t103), undef; is eval("\$t103->()"), undef; like $@, qr/\AToo few arguments for /; is eval("\$t103->(0)"), "z"; is eval("\$t103->(456)"), 456; is eval("\$t103->(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("\$t103->(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; my $t118 = sub ($a) :prototype($) { $a || "z" }; is prototype($t118), "\$"; is eval("\$t118->()"), undef; like $@, qr/\AToo few arguments for /; is eval("\$t118->(0)"), "z"; is eval("\$t118->(456)"), 456; is eval("\$t118->(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("\$t118->(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t033 ($a = sub ($a) { $a."z" }) { $a->("a")."y" } is prototype(\&t033), undef; is eval("t033()"), "azy"; is eval("t033(sub (@) { \"x\".\$_[0].\"x\" })"), "xaxy"; is eval("t033(sub (@) { \"x\".\$_[0].\"x\" }, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t133 ($a = sub ($a = 222) { $a."z" }) { $a->()."/".$a->("a") } is prototype(\&t133), undef; is eval("t133()"), "222z/az"; is eval("t133(sub (@) { \"x\".(\$_[0] // \"u\").\"x\" })"), "xux/xax"; is eval("t133(sub (@) { \"x\".(\$_[0] // \"u\").\"x\" }, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t134 ($a = sub ($a, $t = sub (@) { $_[0]."p" }) { $t->($a)."z" }) { $a->("a")."/".$a->("b", sub (@) { $_[0]."q" } ) } is prototype(\&t134), undef; is eval("t134()"), "apz/bqz"; is eval("t134(sub (@) { \"x\".(\$_[1] // sub (@) {\$_[0]})->(\$_[0]).\"x\" })"), "xax/xbqx"; is eval("t134(sub (@) { \"x\".(\$_[1] // sub (@) {\$_[0]})->(\$_[0]).\"x\" }, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t135 ($a = sub ($a, $t = sub ($p) { $p."p" }) { $t->($a)."z" }) { $a->("a")."/".$a->("b", sub (@) { $_[0]."q" } ) } is prototype(\&t135), undef; is eval("t135()"), "apz/bqz"; is eval("t135(sub (@) { \"x\".(\$_[1] // sub (@) {\$_[0]})->(\$_[0]).\"x\" })"), "xax/xbqx"; is eval("t135(sub (@) { \"x\".(\$_[1] // sub (@) {\$_[0]})->(\$_[0]).\"x\" }, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t132 ( $a = sub ($a, $t = sub ($p = 222) { $p."p" }) { $t->($a)."z".$t->() }, ) { $a->("a")."/".$a->("b", sub (@) { ($_[0] // "u")."q" } ) } is prototype(\&t132), undef; is eval("t132()"), "apz222p/bqzuq"; is eval("t132(sub (@) { \"x\".(\$_[1] // sub (@) {\$_[0]})->(\$_[0]).\"x\" })"), "xax/xbqx"; is eval("t132(sub (@) { \"x\".(\$_[1] // sub (@) {\$_[0]})->(\$_[0]).\"x\" }, 789)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t104 ($a) :method { $a || "z" } is prototype(\&t104), undef; is eval("t104()"), undef; like $@, qr/\AToo few arguments for /; is eval("t104(0)"), "z"; is eval("t104(456)"), 456; is eval("t104(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t104(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; sub t105 ($a) :prototype($) { $a || "z" } is prototype(\&t105), "\$"; is eval("t105()"), undef; like $@, qr/\ANot enough arguments for main::t105 /; is eval("t105(0)"), "z"; is eval("t105(456)"), 456; is eval("t105(456, 789)"), undef; like $@, qr/\AToo many arguments for main::t105 at/; is eval("t105(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for main::t105 at/; is $a, 123; sub t106 ($a) :prototype(@) { $a || "z" } is prototype(\&t106), "\@"; is eval("t106()"), undef; like $@, qr/\AToo few arguments for /; is eval("t106(0)"), "z"; is eval("t106(456)"), 456; is eval("t106(456, 789)"), undef; like $@, qr/\AToo many arguments for /; is eval("t106(456, 789, 987)"), undef; like $@, qr/\AToo many arguments for /; is $a, 123; #eval "#line 8 foo\nsub t107 (\$a) :method { }"; #isnt $@, ""; # #eval "#line 8 foo\nsub t108 (\$a) :prototype(\$) { }"; #isnt $@, ""; sub t109 (@) { } is prototype(\&t109), undef; is scalar(@{[ t109() ]}), 0; is scalar(t109()), undef; sub t110 () { } is prototype(\&t110), undef; is scalar(@{[ t110() ]}), 0; is scalar(t110()), undef; sub t111 ($a) { } is prototype(\&t111), undef; is scalar(@{[ t111(222) ]}), 0; is scalar(t111(222)), undef; sub t112 ($) { } is prototype(\&t112), undef; is scalar(@{[ t112(222) ]}), 0; is scalar(t112(222)), undef; sub t114 ($a = undef) { } is prototype(\&t114), undef; is scalar(@{[ t114() ]}), 0; is scalar(t114()), undef; is scalar(@{[ t114(333) ]}), 0; is scalar(t114(333)), undef; sub t113 ($a = 222) { } is prototype(\&t113), undef; is scalar(@{[ t113() ]}), 0; is scalar(t113()), undef; is scalar(@{[ t113(333) ]}), 0; is scalar(t113(333)), undef; sub t115 ($a = do { $z++; 222 }) { } is prototype(\&t115), undef; $z = 0; is scalar(@{[ t115() ]}), 0; is $z, 1; is scalar(t115()), undef; is $z, 2; is scalar(@{[ t115(333) ]}), 0; is scalar(t115(333)), undef; is $z, 2; sub t116 (@a) { } is prototype(\&t116), undef; is scalar(@{[ t116() ]}), 0; is scalar(t116()), undef; is scalar(@{[ t116(333) ]}), 0; is scalar(t116(333)), undef; sub t117 (%a) { } is prototype(\&t117), undef; is scalar(@{[ t117() ]}), 0; is scalar(t117()), undef; is scalar(@{[ t117(333, 444) ]}), 0; is scalar(t117(333, 444)), undef; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/0000755000175000017500000000000013201556460023263 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/closure.t0000644000175000017500000000157613076614101025132 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More eval { require Moose } ? (tests => 7) : (skip_all => "Moose required for testing types") ; { package Foo; use Moose; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; for my $meth (qw/foo bar baz/) { Foo->meta->add_method("anon_$meth" => method (Str $bar) { $meth . $bar }); eval qq{ method str_$meth (Str \$bar) { \$meth . \$bar } }; die $@ if $@; } } can_ok('Foo', map { ("anon_$_", "str_$_") } qw/foo bar baz/); my $foo = Foo->new; for my $meth (qw/foo bar baz/) { is($foo->${\"anon_$meth"}('bar'), $meth . 'bar'); is($foo->${\"str_$meth"}('bar'), $meth . 'bar'); } Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/sigs-optional.t0000644000175000017500000000057712400633742026250 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 4; { package Optional; use Function::Parameters qw(:strict); method foo ($class: $arg = undef) { $arg; } method bar ($class: $hr = {}) { ++$hr->{bar}; } } is( Optional->foo(), undef); is( Optional->foo(1), 1); is( Optional->bar(), 1); is( Optional->bar({bar=>1}), 2); Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/list.t0000644000175000017500000000542713076614101024430 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More eval { require Moose } ? (tests => 25) : (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' }, }; my $o = bless {} => 'Foo'; { my %meths = ( rest_list => method ($foo, $bar, @rest) { return join q{,}, @rest; }, rest_named => method ($foo, $bar, %rest) { return join q{,}, map { $_ => $rest{$_} } sort keys %rest; }, ); for my $meth_name (keys %meths) { my $meth = $meths{$meth_name}; like(exception { $o->$meth() }, qr/Too few arguments/, "$meth_name dies without args"); like(exception { $o->$meth('foo') }, qr/Too few arguments/, "$meth_name dies with one arg"); is(exception { is($o->$meth('foo', 'bar'), q{}, "$meth_name - empty \@rest list"); }, undef, '...and validates'); is(exception { is($o->$meth('foo', 'bar', 1 .. 6), q{1,2,3,4,5,6}, "$meth_name - non-empty \@rest list"); }, undef, '...and validates'); } } { my $meth = method (Str $foo, Int $bar, Int @rest) { return join q{,}, @rest; }; is(exception { is($o->$meth('foo', 42), q{}, 'empty @rest list passed through'); }, undef, '...and validates'); is(exception { is($o->$meth('foo', 42, 23, 13), q{23,13}, 'non-empty int @rest list passed through'); }, undef, '...and validates'); like(exception { $o->$meth('foo', 42, 'moo', 13, 'non-empty str @rest list passed through'); }, qr/\@rest\b.+\bValidation failed/, "...and doesn't validate"); } { my $meth = method (ArrayRef[Int] @foo) { return join q{,}, map { @{ $_ } } @foo; }; is(exception { is($o->$meth([42, 23], [12], [18]), '42,23,12,18', 'int lists passed through'); }, undef, '...and validates'); like(exception { $o->$meth([42, 23], 12, [18]); }, qr/Validation failed/, "int doesn't validate against int list"); } { my $meth = method (Str $foo, Int @_rest) {}; is(exception { $meth->($o, 'foo') }, undef, 'empty unnamed list validates'); is(exception { $meth->($o, 'foo', 42) }, undef, '1 element of unnamed list validates'); is(exception { $meth->($o, 'foo', 42, 23) }, undef, '2 elements of unnamed list validates'); } { eval 'my $meth = method (:$foo, :@bar) { }'; like $@, qr/\bnamed\b.+\bbar\b.+\barray\b/, 'arrays or hashes cannot be named'; eval 'my $meth = method ($foo, @bar, :$baz) { }'; like $@, qr/"\$baz\" can't appear after slurpy parameter "\@bar"/, 'named parameters cannot be combined with slurpy positionals'; } Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/undef_method_arg.t0000644000175000017500000000177412400633742026752 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Test::Fatal; { package Foo; use Function::Parameters qw(:strict); method new($class:) { bless {}, $class } method m1(:$bar ) { } method m2(:$bar = undef) { } method m3(:$bar ) { } method m4( $bar ) { } method m5( $bar = undef) { } method m6( $bar ) { } } my $foo = Foo->new; is(exception { $foo->m1(bar => undef) }, undef, 'Explicitly pass undef to named implicit required arg'); is(exception { $foo->m2(bar => undef) }, undef, 'Explicitly pass undef to named explicit optional arg'); is(exception { $foo->m3(bar => undef) }, undef, 'Explicitly pass undef to named implicit required arg'); is(exception { $foo->m4(undef) }, undef, 'Explicitly pass undef to implicit required arg'); is(exception { $foo->m5(undef) }, undef, 'Explicitly pass undef to explicit required arg'); is(exception { $foo->m6(undef) }, undef, 'Explicitly pass undef to implicit required arg'); done_testing; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/precedence.t0000644000175000017500000000036013076614102025542 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 4; use Function::Parameters qw(:strict); my @methods = (method () { 1 }, method () { 2 }, method () { 3 }); is(scalar @methods, 3); isa_ok($_, 'CODE') for @methods; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/too_many_args.t0000644000175000017500000000054312400633742026312 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Test::Fatal; { package Foo; use Function::Parameters qw(:strict); method new($class:) { bless {}, $class } method foo ($bar) { $bar } } my $o = Foo->new; is(exception { $o->foo(42) }, undef); like(exception { $o->foo(42, 23) }, qr/Too many arguments/); done_testing; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/attributes.t0000644000175000017500000000101413076614101025627 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 2; use attributes; use Function::Parameters qw(:strict); my $attrs; my $cb_called; sub MODIFY_CODE_ATTRIBUTES { my ($pkg, $code, @attrs) = @_; $cb_called = 1; $attrs = \@attrs; return (); } method moo ($a, $b) : Bar Baz(fubar) { } method foo() : Bar :Moo(:Ko{oh) : Baz(fu{bar:): { return {} } ok($cb_called, 'attribute handler got called'); is_deeply($attrs, [qw/Bar Moo(:Ko{oh) Baz(fu{bar:)/], '... with the right attributes'); Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/lib/0000755000175000017500000000000013201556460024031 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/lib/InvalidCase01.pm0000644000175000017500000000043313076614101026707 0ustar maukemaukepackage InvalidCase01; use strict; use warnings; no warnings 'syntax'; use Function::Parameters qw(:strict); use Carp qw/croak/; method meth1(@){ croak "Binary operator $op expects 2 children, got " . $#$_ if @{$_} > 3; } method meth2(){ { "a" "b" } method meth3() {} 1; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/lib/My/0000755000175000017500000000000013201556460024416 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/0000755000175000017500000000000013201556460026545 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/Long/0000755000175000017500000000000013201556460027444 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/Long/Name/0000755000175000017500000000000013201556460030324 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/lib/My/Annoyingly/Long/Name/Space.pm0000644000175000017500000000007112400633742031712 0ustar maukemaukepackage My::Annoyingly::Long::Name::Space; use Moose; 1; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/lib/Redefined.pm0000644000175000017500000000050013076614101026244 0ustar maukemaukepackage Redefined; use strict; use warnings; use Function::Parameters qw(:strict); use Carp qw/croak/; method meth1() {} method meth1() {} # this one should not trigger a redfined warning sub meth2 {} method meth2() {} # This one shouldn't either method meth3() {} { no warnings 'redefine'; method meth3() {} } 1; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/types.t0000644000175000017500000000167512400633742024624 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More eval { require Moose; require MooseX::Types } ? (tests => 4) : (skip_all => "Moose, MooseX::Types required for testing types") ; use Test::Fatal; { package MyTypes; use MooseX::Types::Moose qw/Str/; use Moose::Util::TypeConstraints; use MooseX::Types -declare => [qw/CustomType/]; BEGIN { subtype CustomType, as Str, where { length($_) == 2 }; } } { package TestClass; use Function::Parameters qw(:strict); BEGIN { MyTypes->import('CustomType') }; use MooseX::Types::Moose qw/ArrayRef/; #use namespace::clean; method foo ((CustomType) $bar) { } method bar ((ArrayRef[CustomType]) $baz) { } } my $o = bless {} => 'TestClass'; is(exception { $o->foo('42') }, undef); ok(exception { $o->foo('bar') }); is(exception { $o->bar(['42', '23']) }, undef); ok(exception { $o->bar(['foo', 'bar']) }); Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/undef_method_arg2.t0000644000175000017500000000373613076614102027033 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More eval { require Moose; require Test::Deep; } ? (tests => 4) : (skip_all => "Moose, Test::Deep required for testing types") ; # assigned to by each 'foo' method my $captured_args; { package Named; use Moose; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; # use Data::Dumper; method foo ( Str :$foo_a, Maybe[Str] :$foo_b = undef) { $captured_args = \@_; } } { package Positional; use Moose; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; # use Data::Dumper; method foo ( Str $foo_a, Maybe[Str] $foo_b = undef) { $captured_args = \@_; } } use Test::Deep; #use Data::Dumper; my $positional = Positional->new; $positional->foo('str', undef); cmp_deeply( $captured_args, [ #noclass({}), 'str', undef, ], 'positional: explicit undef shows up in @_ correctly', ); $positional->foo('str'); cmp_deeply( $captured_args, [ #noclass({}), 'str', ], 'positional: omitting an argument results in no entry in @_', ); my $named = Named->new; $named->foo(foo_a => 'str', foo_b => undef); cmp_deeply( $captured_args, [ #noclass({}), foo_a => 'str', foo_b => undef, ], 'named: explicit undef shows up in @_ correctly', ); $named->foo(foo_a => 'str'); #TODO: { # local $TODO = 'this fails... should work the same as for positional args.'; cmp_deeply( $captured_args, [ #noclass({}), foo_a => 'str', ], 'named: omitting an argument results in no entry in @_', ); #print "### named captured args: ", Dumper($captured_args); #} Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/caller.t0000644000175000017500000000070412400633742024712 0ustar maukemaukeuse strict; use warnings FATAL => 'all'; use Test::More tests => 1; { package TestClass; use Function::Parameters qw(:strict); use Carp (); method callstack_inner($class:) { return Carp::longmess("Callstack is"); } method callstack($class:) { return $class->callstack_inner; } } my $callstack = TestClass->callstack(); unlike $callstack, qr/Test::Class::.*?__ANON__/, "No anon methods in call chain"; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/eval.t0000644000175000017500000000125213076614101024374 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 3; # last test to print use Function::Parameters qw(:strict); my $evalcode = do { local $/ = undef; ; }; ok( do { my $r = eval $evalcode; die $@ if not $r; 1; }, 'Basic Eval Moose' ); my $foo = foo->new({}); is ($foo->example (), 1, 'First method declared'); is ($foo->example2(), 2, 'Second method declared (after injected semicolon)'); __DATA__ { package foo; use Function::Parameters qw(:strict); method new($class: $init) { bless $init, $class } method example() { 1 } # look Ma, no semicolon! method example2() { 2 } } 1; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/named_defaults.t0000644000175000017500000000045312400633742026424 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; { package Foo; use Function::Parameters qw(:strict); method new($class:) { bless {}, $class } method bar (:$baz = 42) { $baz } } my $o = Foo->new; is($o->bar, 42); is($o->bar(baz => 0xaffe), 0xaffe); done_testing; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/errors.t0000644000175000017500000000127312416511721024765 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Dir::Self; use lib __DIR__ . "/lib"; eval "use InvalidCase01;"; ok($@, "Got an error"); #TODO: { # #local $TODO = 'Devel::Declare and Eval::Closure have unresolved issues' # if Eval::Closure->VERSION > 0.06; like($@, qr/^Global symbol "\$op" requires explicit package name .*?\bInvalidCase01.pm line 8\b/, "Sane error message for syntax error"); #} { my $warnings = ""; local $SIG{__WARN__} = sub { $warnings .= $_[0] }; eval "use Redefined;"; is($@, '', "No error"); like($warnings, qr/^Subroutine meth1 redefined at .*?\bRedefined.pm line 9\b/, "Redefined method warning"); } done_testing; Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/type_alias.t0000644000175000017500000000151413076614102025601 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More eval { require Moose; require aliased } ? (tests => 2) : (skip_all => "Moose, aliased required for testing types") ; use Test::Fatal; use Dir::Self; use lib __DIR__ . '/lib'; { package TestClass; use Moose; use Function::Parameters { fun => { defaults => 'function', reify_type => 'moose' }, method => { defaults => 'method', reify_type => 'moose' }, }; use aliased 'My::Annoyingly::Long::Name::Space', 'Shortcut'; ::is(::exception { method alias_sig ((Shortcut) $affe) { } }, undef, 'method with aliased type constraint compiles'); } my $o = TestClass->new; my $affe = My::Annoyingly::Long::Name::Space->new; is(exception { $o->alias_sig($affe); }, undef, 'calling method with aliased type constraint'); Function-Parameters-2.001003/t/foreign/MooseX-Method-Signatures/no_signature.t0000644000175000017500000000071213076614102026143 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More; use Test::Fatal; { package Foo; use Function::Parameters qw(:strict); method new($class:) { bless {}, $class } method bar(@) { 42 } } my $foo = Foo->new; is(exception { $foo->bar }, undef, 'method without signature succeeds when called without args'); is(exception { $foo->bar(42) }, undef, 'method without signature succeeds when called with args'); done_testing; Function-Parameters-2.001003/t/foreign/Method-Signatures-Simple/0000755000175000017500000000000013201556460023302 5ustar maukemaukeFunction-Parameters-2.001003/t/foreign/Method-Signatures-Simple/03-config.t0000644000175000017500000000246413076614101025157 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 3; # testing that we can install several different keywords into the same scope { package Monster; use Function::Parameters; use Function::Parameters { action => { defaults => 'method', shift => '$monster' }, constructor => { defaults => 'method', shift => '$species' }, function => 'function', }; constructor spawn (@) { bless {@_}, $species; } action speak (@words) { return join ' ', $monster->{name}, $monster->{voices}, @words; } action attack ($me: $you) { $you->take_damage($me->{strength}); } method take_damage ($hits) { $self->{hitpoints} = calculate_damage($self->{hitpoints}, $hits); if($self->{hitpoints} <= 0) { $self->{is_dead} = 1; } } function calculate_damage ($hitpoints, $damage) { return $hitpoints - $damage; } } package main; my $hellhound = Monster->spawn( name => "Hellhound", voices => "barks", strength => 22, hitpoints => 100 ); is $hellhound->speak(qw(arf arf)), 'Hellhound barks arf arf'; my $human = Monster->spawn( name => 'human', voices => 'whispers', strength => 4, hitpoints => 16 ); $hellhound->attack($human); is $human->{is_dead}, 1; is $human->{hitpoints}, -6; Function-Parameters-2.001003/t/foreign/Method-Signatures-Simple/RT80510.t0000644000175000017500000000043713076614101024413 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 2; use Function::Parameters qw(:lax); fun empty ($x) {} is scalar empty(1), undef, "empty func returns nothing (scalar context)"; is_deeply [empty(1,2)], [], "empty func returns nothing (list context)"; __END__ Function-Parameters-2.001003/t/foreign/Method-Signatures-Simple/02-use.t0000644000175000017500000000112213076614101024473 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 7; BEGIN { use_ok 'Function::Parameters' } { package My::Obj; use Function::Parameters qw(:strict); method make($class: %opts) { bless {%opts}, $class; } method first() : lvalue { $self->{first}; } method second() { $self->first + 1; } method nth($inc) { $self->first + $inc; } } my $o = My::Obj->make(first => 1); is $o->first, 1; is $o->second, 2; is $o->nth(10), 11; $o->first = 10; is $o->first, 10; is $o->second, 11; is $o->nth(10), 20; Function-Parameters-2.001003/t/foreign/Method-Signatures-Simple/RT80507.t0000644000175000017500000000066112400633742024422 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Function::Parameters qw(:strict); use Test::More tests => 2; { my $uniq = 0; method fresh_name() { $self->prefix . $uniq++ } } method prefix() { $self->{prefix} } my $o = bless {prefix => "foo_" }, main::; is $o->fresh_name, 'foo_0'; #TODO: { # local $TODO = 'do not know how to handle the scope change in line 7'; is __LINE__, 24; #} __END__ Function-Parameters-2.001003/t/foreign/Method-Signatures-Simple/RT80505.t0000644000175000017500000000105212400633742024413 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 2; { package My::Obj; use Function::Parameters qw(:strict); method new () { bless {}, $self; } method foo ( $x, # the X $y, # the Y ) { return $x * $y; } my $bar = method ( $P, # comment $Q, # comment ) { # comment $P + $Q }; } my $o = My::Obj->new; is $o->foo(4, 5), 20, "should allow comments and newlines in proto"; is __LINE__, 28, "should leave line number intact"; __END__ Function-Parameters-2.001003/t/foreign/Method-Signatures-Simple/RT80508.t0000644000175000017500000000053112400633742024417 0ustar maukemauke#!perl use strict; use warnings FATAL => 'all'; use Test::More tests => 1; { package My::Obj; use Function::Parameters qw(:strict); method with_space ( $this : $that ) { return ($this, $that); } } is_deeply [ My::Obj->with_space (1) ], [ 'My::Obj', 1 ], 'space between invocant name and colon should parse'; __END__ Function-Parameters-2.001003/t/name_4.fail0000644000175000017500000000043112642733037017063 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.001003/t/name_2.fail0000644000175000017500000000037512642733033017064 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.001003/t/types_auto.t0000644000175000017500000000316013076614102017437 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 12; { package MyTC; use overload '|' => 'union', '&{}' => 'apply', fallback => 1; 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 union { 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, Tj | Tk[Tl], To [ Tq, Tr ] | Tt ] $x) {}, fun ((' Ta[Tb] | Td | Tf [ Tg, Ti, Tj | Tk[Tl], To [ Tq, Tr ] | Tt ] ') $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,Tj|Tk[Tl],To[Tq,Tr]|Tt]'; } Function-Parameters-2.001003/t/gorn.t0000644000175000017500000000046713076614102016217 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.001003/t/lineno.t0000644000175000017500000000223313076614102016527 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.001003/t/03-compiles.t0000644000175000017500000000215313076614101017276 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.001003/t/checkered.t0000644000175000017500000001167513076614101017171 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.001003/t/strict_1.fail0000644000175000017500000000013412400633742017442 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters; fun bad_1($x, @y, $z) {} 'ok' Function-Parameters-2.001003/t/01-compiles.t0000644000175000017500000000201413076614101017270 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.001003/t/named_params.t0000644000175000017500000002424013076614102017674 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.001003/t/hueg.t0000644000175000017500000001663713076614102016210 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.001003/t/types_moose_2.t0000644000175000017500000000662213076614102020040 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.001003/t/types_custom.t0000644000175000017500000000333112642732145020007 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.001003/t/eval.t0000644000175000017500000000302113121164547016172 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.001003/t/name.t0000644000175000017500000000200613076614102016161 0ustar maukemaukeuse warnings; use strict; use Test::More tests => 12; use Dir::Self; 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 [__DIR__ . "/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"; $exc or die "$file: $err"; like $exc, $pat; } Function-Parameters-2.001003/t/name_1.fail0000644000175000017500000000041212642733030017050 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.001003/t/02-compiles.t0000644000175000017500000000206513076614101017277 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.001003/t/eating_strict_error.t0000644000175000017500000000076712642731744021337 0ustar maukemauke#!perl use Test::More tests => 4; use warnings FATAL => 'all'; use strict; use Dir::Self; for my $thing (map [__DIR__ . "/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"; 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.001003/t/lifetime.t0000644000175000017500000000205213076614102017040 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.001003/t/strict_5.fail0000644000175000017500000000016612642733046017461 0ustar maukemauke#!perl use warnings; use strict; use Function::Parameters { spike => { rarity => 'best', }, }; 'ok' Function-Parameters-2.001003/t/eating_strict_error.fail0000644000175000017500000000024212642733023021763 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.001003/t/checkered_4.t0000644000175000017500000001164313076614101017407 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.001003/t/eating_strict_error_2.fail0000644000175000017500000000024212642733026022207 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.001003/t/types_custom_3.t0000644000175000017500000000146513076614102020231 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.001003/t/name_3.fail0000644000175000017500000000042012642733035017056 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.001003/t/types_custom_4.t0000644000175000017500000000326313076614102020230 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.001003/t/rename.t0000644000175000017500000000057512630134355016523 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.001003/t/elsewhere.t0000644000175000017500000000055213076614101017227 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.001003/t/defaults_bare.t0000644000175000017500000000151612416746644020064 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.001003/t/types_custom_2.t0000644000175000017500000000300712642732150020224 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.001003/t/threads2.t0000644000175000017500000000120113200666361016754 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.001003/t/types_moosex.t0000644000175000017500000000626713076614102020014 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.001003/t/unicode2.t0000644000175000017500000000234413076614102016756 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.001003/t/method_cache.t0000644000175000017500000000065712642732107017662 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.001003/MANIFEST.SKIP0000644000175000017500000000030412472241327016512 0ustar maukemauke\.tar\.gz$ ^Build$ ^Function-Parameters- ^MANIFEST\.(?!SKIP$) ^MYMETA\. ^Makefile$ ^Makefile\.old$ ^Parameters\.(?:[iocs]|bs)$ ^\. ^_build ^blib ^cover_db$ ^pm_to_blib ^remote$ ^untracked ^maint/