@@ -1,5 +1,38 @@
Revision history for Function-Parameters
+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
@@ -4,9 +4,21 @@ MANIFEST.SKIP
Makefile.PL
Parameters.xs
README
+hax/COP_SEQ_RANGE_HIGH_set.c.inc
+hax/COP_SEQ_RANGE_LOW_set.c.inc
+hax/block_end.c.inc
+hax/block_start.c.inc
+hax/intro_my.c.inc
+hax/newDEFSVOP.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
lib/Function/Parameters.pm
lib/Function/Parameters/Info.pm
-padop_on_crack.c.inc
t/00-load.t
t/01-compiles.t
t/02-compiles.t
@@ -17,6 +29,7 @@ t/checkered.t
t/checkered_2.t
t/checkered_3.t
t/defaults.t
+t/defaults_bare.t
t/defaults_regress.t
t/eating_strict_error.fail
t/eating_strict_error.t
@@ -90,6 +103,7 @@ 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
@@ -129,6 +143,7 @@ t/types_moose.t
t/types_moose_2.t
t/types_moose_3.t
t/types_moosex.t
+t/types_parse.t
t/unicode.t
t/unicode2.t
META.yml Module YAML meta-data (added by MakeMaker)
@@ -4,7 +4,7 @@
"Lukas Mai <l.mai@web.de>"
],
"dynamic_config" : 1,
- "generated_by" : "ExtUtils::MakeMaker version 6.78, CPAN::Meta::Converter version 2.132661",
+ "generated_by" : "ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640",
"license" : [
"perl_5"
],
@@ -23,6 +23,13 @@
"build" : {
"requires" : {}
},
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "6.48",
+ "strict" : "0",
+ "warnings" : "0"
+ }
+ },
"runtime" : {
"requires" : {
"Carp" : "0",
@@ -50,5 +57,5 @@
"web" : "https://github.com/mauke/Function-Parameters"
}
},
- "version" : "1.0401"
+ "version" : "1.0601"
}
@@ -3,28 +3,32 @@ abstract: 'subroutine definitions with parameter lists'
author:
- 'Lukas Mai <l.mai@web.de>'
build_requires:
- Dir::Self: 0
- Test::Fatal: 0
- Test::More: 0
- constant: 0
- strict: 0
- utf8: 0
+ Dir::Self: '0'
+ Test::Fatal: '0'
+ Test::More: '0'
+ constant: '0'
+ strict: '0'
+ utf8: '0'
+configure_requires:
+ ExtUtils::MakeMaker: '6.48'
+ strict: '0'
+ warnings: '0'
dynamic_config: 1
-generated_by: 'ExtUtils::MakeMaker version 6.78, CPAN::Meta::Converter version 2.132661'
+generated_by: 'ExtUtils::MakeMaker version 6.98, CPAN::Meta::Converter version 2.140640'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ version: '1.4'
name: Function-Parameters
no_index:
directory:
- t
- inc
requires:
- Carp: 0
- XSLoader: 0
- perl: 5.014000
- warnings: 0
+ Carp: '0'
+ XSLoader: '0'
+ perl: '5.014000'
+ warnings: '0'
resources:
repository: git://github.com/mauke/Function-Parameters
-version: 1.0401
+version: '1.0601'
@@ -3,75 +3,78 @@ use warnings;
use ExtUtils::MakeMaker;
sub merge_key_into {
- my ($href, $target, $source) = @_;
- %{$href->{$target}} = (%{$href->{$target}}, %{delete $href->{$source}});
+ my ($href, $target, $source) = @_;
+ %{$href->{$target}} = (%{$href->{$target}}, %{delete $href->{$source}});
}
my %opt = (
- NAME => 'Function::Parameters',
- AUTHOR => q{Lukas Mai <l.mai@web.de>},
- VERSION_FROM => 'lib/Function/Parameters.pm',
- ABSTRACT_FROM => 'lib/Function/Parameters.pm',
+ NAME => 'Function::Parameters',
+ AUTHOR => q{Lukas Mai <l.mai@web.de>},
+ VERSION_FROM => 'lib/Function/Parameters.pm',
+ ABSTRACT_FROM => 'lib/Function/Parameters.pm',
- LICENSE => 'perl',
- PL_FILES => {},
+ LICENSE => 'perl',
+ PL_FILES => {},
- MIN_PERL_VERSION => '5.14.0',
- CONFIGURE_REQUIRES => {
- 'strict' => 0,
- 'warnings' => 0,
- 'ExtUtils::MakeMaker' => '6.48',
- },
- BUILD_REQUIRES => {},
- TEST_REQUIRES => {
- 'constant' => 0,
- 'strict' => 0,
- 'utf8' => 0,
- 'Dir::Self' => 0,
- 'Test::More' => 0,
- 'Test::Fatal' => 0,
- },
- PREREQ_PM => {
- 'Carp' => 0,
- 'XSLoader' => 0,
- 'warnings' => 0,
- },
+ MIN_PERL_VERSION => '5.14.0',
+ CONFIGURE_REQUIRES => {
+ 'strict' => 0,
+ 'warnings' => 0,
+ 'ExtUtils::MakeMaker' => '6.48',
+ },
+ BUILD_REQUIRES => {},
+ TEST_REQUIRES => {
+ 'constant' => 0,
+ 'strict' => 0,
+ 'utf8' => 0,
+ 'Dir::Self' => 0,
+ 'Test::More' => 0,
+ 'Test::Fatal' => 0,
+ },
+ PREREQ_PM => {
+ 'Carp' => 0,
+ 'XSLoader' => 0,
+ 'warnings' => 0,
+ },
- depend => { Makefile => '$(VERSION_FROM)' },
- test => { TESTS => 't/*.t t/foreign/*.t t/foreign/*/*.t' },
- dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
- clean => { FILES => 'Function-Parameters-*' },
+ depend => {
+ Makefile => '$(VERSION_FROM)',
+ '$(OBJECT)' => join(' ', glob 'hax/*.c.inc'),
+ },
+ test => { TESTS => 't/*.t t/foreign/*.t t/foreign/*/*.t' },
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ clean => { FILES => 'Function-Parameters-*' },
- META_MERGE => {
- 'meta-spec' => { version => 2 },
- resources => {
- repository => {
- url => 'git://github.com/mauke/Function-Parameters',
- web => 'https://github.com/mauke/Function-Parameters',
- type => 'git',
- },
- },
- },
+ META_MERGE => {
+ 'meta-spec' => { version => 2 },
+ resources => {
+ repository => {
+ url => 'git://github.com/mauke/Function-Parameters',
+ web => 'https://github.com/mauke/Function-Parameters',
+ type => 'git',
+ },
+ },
+ },
);
(my $mm_version = ExtUtils::MakeMaker->VERSION) =~ tr/_//d;
if ($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;
+ # 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;
}
if ($mm_version < 6.63_03) {
- merge_key_into \%opt, 'BUILD_REQUIRES', 'TEST_REQUIRES';
+ merge_key_into \%opt, 'BUILD_REQUIRES', 'TEST_REQUIRES';
}
if ($mm_version < 6.55_01) {
- merge_key_into \%opt, 'CONFIGURE_REQUIRES', 'BUILD_REQUIRES';
+ merge_key_into \%opt, 'CONFIGURE_REQUIRES', 'BUILD_REQUIRES';
}
if ($mm_version < 6.51_03) {
- merge_key_into \%opt, 'PREREQ_PM', 'CONFIGURE_REQUIRES';
+ merge_key_into \%opt, 'PREREQ_PM', 'CONFIGURE_REQUIRES';
}
WriteMakefile %opt;
@@ -1,5 +1,5 @@
/*
-Copyright 2012 Lukas Mai.
+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
@@ -23,18 +23,18 @@ See http://dev.perl.org/licenses/ for more information.
#define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
#define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #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(-Wnested-externs) wtf? */ \
- WARNINGS_ENABLEW(-Wstrict-prototypes) \
- WARNINGS_ENABLEW(-Wmissing-prototypes) \
- WARNINGS_ENABLEW(-Winline) \
- WARNINGS_ENABLEW(-Wdisabled-optimization)
+ 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(-Wnested-externs) wtf? */ \
+ WARNINGS_ENABLEW(-Wstrict-prototypes) \
+ WARNINGS_ENABLEW(-Wmissing-prototypes) \
+ WARNINGS_ENABLEW(-Winline) \
+ WARNINGS_ENABLEW(-Wdisabled-optimization)
#else
#define WARNINGS_RESET
@@ -52,9 +52,12 @@ See http://dev.perl.org/licenses/ for more information.
WARNINGS_ENABLE
+#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))))))
+ (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
#if HAVE_PERL_VERSION(5, 16, 0)
#define IF_HAVE_PERL_5_16(YES, NO) YES
@@ -62,20 +65,16 @@ WARNINGS_ENABLE
#define IF_HAVE_PERL_5_16(YES, NO) NO
#endif
-#if 0
- #if HAVE_PERL_VERSION(5, 17, 6)
- #error "internal error: missing definition of KEY_my (your perl is too new)"
- #elif HAVE_PERL_VERSION(5, 15, 8)
- #define S_KEY_my 134
- #elif HAVE_PERL_VERSION(5, 15, 6)
- #define S_KEY_my 133
- #elif HAVE_PERL_VERSION(5, 15, 5)
- #define S_KEY_my 132
- #elif HAVE_PERL_VERSION(5, 13, 0)
- #define S_KEY_my 131
- #else
- #error "internal error: missing definition of KEY_my (your perl is too old)"
- #endif
+#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
+
+#if HAVE_PERL_VERSION(5, 19, 4)
+ #define IF_HAVE_PERL_5_19_4(YES, NO) YES
+#else
+ #define IF_HAVE_PERL_5_19_4(YES, NO) NO
#endif
@@ -90,72 +89,74 @@ WARNINGS_ENABLE
#define DEFSTRUCT(T) typedef struct T T; struct T
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
+ 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(KWSpec) {
- unsigned flags;
- I32 reify_type;
- SV *shift;
- SV *attrs;
+ unsigned flags;
+ I32 reify_type;
+ SV *shift;
+ SV *attrs;
};
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
DEFSTRUCT(Resource) {
- Resource *next;
- void *data;
- void (*destroy)(pTHX_ void *);
+ Resource *next;
+ void *data;
+ void (*destroy)(pTHX_ void *);
};
typedef Resource *Sentinel[1];
-static void sentinel_clear_void(pTHX_ void *p) {
- Resource **pp = p;
- while (*pp) {
- Resource *cur = *pp;
- if (cur->destroy) {
- cur->destroy(aTHX_ cur->data);
- }
- cur->data = (void *)"no";
- cur->destroy = NULL;
- *pp = cur->next;
- Safefree(cur);
- }
+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;
+ Resource *cur;
- Newx(cur, 1, Resource);
- cur->data = data;
- cur->destroy = destroy;
- cur->next = *sen;
- *sen = cur;
+ Newx(cur, 1, Resource);
+ cur->data = data;
+ cur->destroy = destroy;
+ cur->next = *sen;
+ *sen = cur;
- return cur;
+ return cur;
}
static void sentinel_disarm(Resource *p) {
- p->destroy = NULL;
+ p->destroy = NULL;
}
static void my_sv_refcnt_dec_void(pTHX_ void *p) {
- SV *sv = p;
- SvREFCNT_dec(sv);
+ 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;
+ sentinel_register(sen, sv, my_sv_refcnt_dec_void);
+ return sv;
}
@@ -166,74 +167,85 @@ static SV *sentinel_mortalize(Sentinel sen, SV *sv) {
#endif
DEFSTRUCT(OpGuard) {
- OP *op;
- bool needs_freed;
+ OP *op;
+ bool needs_freed;
};
static void op_guard_init(OpGuard *p) {
- p->op = NULL;
- p->needs_freed = FALSE;
+ p->op = NULL;
+ p->needs_freed = FALSE;
}
static OpGuard op_guard_transfer(OpGuard *p) {
- OpGuard r = *p;
- op_guard_init(p);
- return r;
+ 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;
+ 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);
+ 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);
- }
+ 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);
+ OpGuard *p = vp;
+ op_guard_clear(aTHX_ p);
+ Safefree(p);
}
static void free_op_void(pTHX_ void *vp) {
- OP *p = vp;
- op_free(p);
+ OP *p = vp;
+ op_free(p);
}
-#define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1)
+#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 memcmp(sv_p, p, n) == 0;
+ STRLEN sv_len;
+ const char *sv_p = SvPV(sv, sv_len);
+ return sv_len == n && memcmp(sv_p, p, n) == 0;
}
-#include "padop_on_crack.c.inc"
+#ifndef SvREFCNT_dec_NN
+#define SvREFCNT_dec_NN(SV) SvREFCNT_dec(SV)
+#endif
+
+#include "hax/pad_alloc.c.inc" /* 5.14 */
+#include "hax/pad_add_name_sv.c.inc" /* 5.14 */
+#include "hax/pad_add_name_pvs.c.inc" /* 5.14 */
+
+#include "hax/newDEFSVOP.c.inc"
+#include "hax/intro_my.c.inc"
+#include "hax/block_start.c.inc"
+#include "hax/block_end.c.inc"
enum {
- MY_ATTR_LVALUE = 0x01,
- MY_ATTR_METHOD = 0x02,
- MY_ATTR_SPECIAL = 0x04
+ 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);
+ 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);
}
@@ -241,1836 +253,1921 @@ static void my_sv_cat_c(pTHX_ SV *sv, U32 c) {
#define MY_UNI_IDCONT(C) isALNUM_uni(C)
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;
+ 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;
+ 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 = SvPV(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)) {
- warner(
- packWARN(WARN_ILLEGALPROTO),
- "Illegal character after '_' in prototype for %"SVf" : %s",
- SVfARG(declarator), r
- );
- 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;
- }
- }
+ 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)) {
+ warner(
+ packWARN(WARN_ILLEGALPROTO),
+ "Illegal character after '_' in prototype for %"SVf" : %s",
+ SVfARG(declarator), r
+ );
+ 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 *);
+static SV *parse_type(pTHX_ Sentinel, const SV *, char);
-static SV *parse_type_paramd(pTHX_ Sentinel sen, const SV *declarator) {
- I32 c;
- SV *t;
+static SV *parse_type_paramd(pTHX_ Sentinel sen, const SV *declarator, char prev) {
+ I32 c;
+ SV *t;
- t = my_scan_word(aTHX_ sen, TRUE);
- lex_read_space(0);
+ 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 == '[') {
- SV *u;
+ c = lex_peek_unichar(0);
+ if (c == '[') {
+ SV *u;
- lex_read_unichar(0);
- lex_read_space(0);
- my_sv_cat_c(aTHX_ t, c);
+ lex_read_unichar(0);
+ lex_read_space(0);
+ my_sv_cat_c(aTHX_ t, c);
- u = parse_type(aTHX_ sen, declarator);
- sv_catsv(t, u);
+ u = parse_type(aTHX_ sen, declarator, '[');
+ sv_catsv(t, u);
- c = lex_peek_unichar(0);
- if (c != ']') {
- croak("In %"SVf": missing ']' after '%"SVf"'", SVfARG(declarator), SVfARG(t));
- }
- lex_read_unichar(0);
- lex_read_space(0);
+ c = lex_peek_unichar(0);
+ 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);
- }
+ my_sv_cat_c(aTHX_ t, c);
+ }
- return t;
+ return t;
}
-static SV *parse_type(pTHX_ Sentinel sen, const SV *declarator) {
- I32 c;
- SV *t;
+static SV *parse_type(pTHX_ Sentinel sen, const SV *declarator, char prev) {
+ I32 c;
+ SV *t;
- t = parse_type_paramd(aTHX_ sen, declarator);
+ t = parse_type_paramd(aTHX_ sen, declarator, prev);
- c = lex_peek_unichar(0);
- while (c == '|') {
- SV *u;
+ c = lex_peek_unichar(0);
+ while (c == '|') {
+ SV *u;
- lex_read_unichar(0);
- lex_read_space(0);
+ 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);
+ my_sv_cat_c(aTHX_ t, c);
+ u = parse_type_paramd(aTHX_ sen, declarator, '|');
+ sv_catsv(t, u);
- c = lex_peek_unichar(0);
- }
+ c = lex_peek_unichar(0);
+ }
- return t;
+ return t;
}
static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, const KWSpec *spec, SV *name) {
- AV *type_reifiers;
- SV *t, *sv, **psv;
- int n;
- dSP;
+ AV *type_reifiers;
+ SV *t, *sv, **psv;
+ int n;
+ dSP;
- type_reifiers = get_av(MY_PKG "::type_reifiers", 0);
- assert(type_reifiers != NULL);
+ type_reifiers = get_av(MY_PKG "::type_reifiers", 0);
+ assert(type_reifiers != NULL);
- if (spec->reify_type < 0 || spec->reify_type > av_len(type_reifiers)) {
- croak("In %"SVf": internal error: reify_type [%ld] out of range [%ld]", SVfARG(declarator), (long)spec->reify_type, (long)(av_len(type_reifiers) + 1));
- }
+ if (spec->reify_type < 0 || spec->reify_type > av_len(type_reifiers)) {
+ croak("In %"SVf": internal error: reify_type [%ld] out of range [%ld]", SVfARG(declarator), (long)spec->reify_type, (long)(av_len(type_reifiers) + 1));
+ }
- psv = av_fetch(type_reifiers, spec->reify_type, 0);
- assert(psv != NULL);
- sv = *psv;
+ psv = av_fetch(type_reifiers, spec->reify_type, 0);
+ assert(psv != NULL);
+ sv = *psv;
- ENTER;
- SAVETMPS;
+ ENTER;
+ SAVETMPS;
- PUSHMARK(SP);
- EXTEND(SP, 2);
- PUSHs(name);
- PUSHs(PL_curstname);
- PUTBACK;
+ PUSHMARK(SP);
+ EXTEND(SP, 2);
+ PUSHs(name);
+ PUSHs(PL_curstname);
+ PUTBACK;
- n = call_sv(sv, G_SCALAR);
- SPAGAIN;
+ n = call_sv(sv, G_SCALAR);
+ SPAGAIN;
- assert(n == 1);
- /* don't warn about n being unused if assert() is compiled out */
- n = n;
+ assert(n == 1);
+ /* don't warn about n being unused if assert() is compiled out */
+ n = n;
- t = sentinel_mortalize(sen, SvREFCNT_inc(POPs));
+ t = sentinel_mortalize(sen, SvREFCNT_inc(POPs));
- PUTBACK;
- FREETMPS;
- LEAVE;
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
- if (!SvTRUE(t)) {
- croak("In %"SVf": undefined type '%"SVf"'", SVfARG(declarator), SVfARG(name));
- }
+ if (!SvTRUE(t)) {
+ croak("In %"SVf": undefined type '%"SVf"'", SVfARG(declarator), SVfARG(name));
+ }
- return t;
+ return t;
}
DEFSTRUCT(Param) {
- SV *name;
- PADOFFSET padoff;
- SV *type;
+ SV *name;
+ PADOFFSET padoff;
+ SV *type;
};
DEFSTRUCT(ParamInit) {
- Param param;
- OpGuard init;
+ Param param;
+ OpGuard init;
};
#define VEC(B) B ## _Vec
#define DEFVECTOR(B) DEFSTRUCT(VEC(B)) { \
- B (*data); \
- size_t used, size; \
+ B (*data); \
+ size_t used, size; \
}
DEFVECTOR(Param);
DEFVECTOR(ParamInit);
#define DEFVECTOR_INIT(N, B) static void N(VEC(B) *p) { \
- p->used = 0; \
- p->size = 23; \
- Newx(p->data, p->size, B); \
+ p->used = 0; \
+ p->size = 23; \
+ Newx(p->data, p->size, B); \
} static void N(VEC(B) *)
DEFSTRUCT(ParamSpec) {
- Param invocant;
- VEC(Param) positional_required;
- VEC(ParamInit) positional_optional;
- VEC(Param) named_required;
- VEC(ParamInit) named_optional;
- Param slurpy;
- PADOFFSET rest_hash;
+ Param invocant;
+ 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;
+ p->name = NULL;
+ p->padoff = NOT_IN_PAD;
+ p->type = NULL;
}
static void ps_init(ParamSpec *ps) {
- p_init(&ps->invocant);
- 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;
+ p_init(&ps->invocant);
+ 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;
}
#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]; \
+ 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) *))
DEFVECTOR_EXTEND(pv_extend, Param);
DEFVECTOR_EXTEND(piv_extend, ParamInit);
#define DEFVECTOR_CLEAR(N, B, F) static void N(pTHX_ VEC(B) *p) { \
- while (p->used) { \
- p->used--; \
- F(aTHX_ &p->data[p->used]); \
- } \
- Safefree(p->data); \
- p->data = NULL; \
- p->size = 0; \
+ while (p->used) { \
+ p->used--; \
+ F(aTHX_ &p->data[p->used]); \
+ } \
+ Safefree(p->data); \
+ p->data = NULL; \
+ p->size = 0; \
} static void N(pTHX_ VEC(B) *)
static void p_clear(pTHX_ Param *p) {
- p->name = NULL;
- p->padoff = NOT_IN_PAD;
- p->type = NULL;
+ p->name = NULL;
+ p->padoff = NOT_IN_PAD;
+ p->type = NULL;
}
static void pi_clear(pTHX_ ParamInit *pi) {
- p_clear(aTHX_ &pi->param);
- op_guard_clear(aTHX_ &pi->init);
+ p_clear(aTHX_ &pi->param);
+ op_guard_clear(aTHX_ &pi->init);
}
DEFVECTOR_CLEAR(pv_clear, Param, p_clear);
DEFVECTOR_CLEAR(piv_clear, ParamInit, pi_clear);
static void ps_clear(pTHX_ ParamSpec *ps) {
- p_clear(aTHX_ &ps->invocant);
+ p_clear(aTHX_ &ps->invocant);
- pv_clear(aTHX_ &ps->positional_required);
- piv_clear(aTHX_ &ps->positional_optional);
+ pv_clear(aTHX_ &ps->positional_required);
+ piv_clear(aTHX_ &ps->positional_optional);
- pv_clear(aTHX_ &ps->named_required);
- piv_clear(aTHX_ &ps->named_optional);
+ pv_clear(aTHX_ &ps->named_required);
+ piv_clear(aTHX_ &ps->named_optional);
- p_clear(aTHX_ &ps->slurpy);
+ p_clear(aTHX_ &ps->slurpy);
}
static int ps_contains(pTHX_ const ParamSpec *ps, SV *sv) {
- size_t i, lim;
-
- if (ps->invocant.name && sv_eq(sv, ps->invocant.name)) {
- return 1;
- }
-
- 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;
+ size_t i, lim;
+
+ if (ps->invocant.name && sv_eq(sv, ps->invocant.name)) {
+ return 1;
+ }
+
+ 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);
+ ps_clear(aTHX_ p);
+ Safefree(p);
}
static int args_min(pTHX_ const ParamSpec *ps, const KWSpec *ks) {
- int n = 0;
- if (!ps) {
- return SvTRUE(ks->shift) ? 1 : 0;
- }
- if (ps->invocant.name) {
- n++;
- }
- n += ps->positional_required.used;
- n += ps->named_required.used * 2;
- return n;
+ int n = 0;
+ if (!ps) {
+ return SvTRUE(ks->shift) ? 1 : 0;
+ }
+ if (ps->invocant.name) {
+ n++;
+ }
+ n += ps->positional_required.used;
+ n += ps->named_required.used * 2;
+ return n;
}
static int args_max(const ParamSpec *ps) {
- int n = 0;
- if (!ps) {
- return -1;
- }
- if (ps->invocant.name) {
- n++;
- }
- n += ps->positional_required.used;
- n += ps->positional_optional.used;
- if (ps->named_required.used || ps->named_optional.used || ps->slurpy.name) {
- n = -1;
- }
- return n;
+ int n = 0;
+ if (!ps) {
+ return -1;
+ }
+ if (ps->invocant.name) {
+ n++;
+ }
+ n += ps->positional_required.used;
+ n += ps->positional_optional.used;
+ if (ps->named_required.used || ps->named_optional.used || ps->slurpy.name) {
+ n = -1;
+ }
+ return n;
}
static size_t count_positional_params(const ParamSpec *ps) {
- return ps->positional_required.used + ps->positional_optional.used;
+ 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;
+ return ps->named_required.used + ps->named_optional.used;
}
static SV *my_eval(pTHX_ Sentinel sen, I32 floor, OP *op) {
- SV *sv;
- CV *cv;
- dSP;
-
- cv = newATTRSUB(floor, NULL, NULL, NULL, op);
+ SV *sv;
+ CV *cv;
+ dSP;
- ENTER;
- SAVETMPS;
+ cv = newATTRSUB(floor, NULL, NULL, NULL, op);
- PUSHMARK(SP);
- call_sv((SV *)cv, G_SCALAR | G_NOARGS);
- SPAGAIN;
- sv = sentinel_mortalize(sen, SvREFCNT_inc(POPs));
+ ENTER;
+ SAVETMPS;
- PUTBACK;
- FREETMPS;
- LEAVE;
+ PUSHMARK(SP);
+ call_sv((SV *)cv, G_SCALAR | G_NOARGS);
+ SPAGAIN;
+ sv = sentinel_mortalize(sen, SvREFCNT_inc(POPs));
- return sv;
-}
-
-enum {
- PARAM_INVOCANT = 0x01,
- PARAM_NAMED = 0x02
-};
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
-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;
- OP *expr;
- Resource *expr_sentinel;
-
- lex_read_unichar(0);
-
- floor = 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, expr);
- if (!SvROK(*ptype)) {
- *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype);
- }
- if (!sv_isobject(*ptype)) {
- croak("In %"SVf": (%"SVf") doesn't look like 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);
- lex_read_space(0);
-
- if (!(name = my_scan_word(aTHX_ sen, FALSE))) {
- croak("In %"SVf": missing identifier after '%c'", 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);
-
-
- if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
- param_spec->invocant.name = spec->shift;
- param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
- }
-
- 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 pad_add_name_sv(*pname, IF_HAVE_PERL_5_16(padadd_NO_DUP_CHECK, 0), NULL, NULL);
+ return sv;
}
static OP *my_var_g(pTHX_ I32 type, I32 flags, PADOFFSET padoff) {
- OP *var = newOP(type, flags);
- var->op_targ = padoff;
- return var;
+ 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);
+ 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);
+ 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);
+ return newSVOP(OP_CONST, 0, sv);
}
static OP *mkconstiv(pTHX_ IV i) {
- return mkconstsv(aTHX_ newSViv(i));
+ return mkconstsv(aTHX_ newSViv(i));
}
static OP *mkconstpv(pTHX_ const char *p, size_t n) {
- return mkconstsv(aTHX_ newSVpv(p, n));
+ return mkconstsv(aTHX_ newSVpv(p, n));
}
#define mkconstpvs(S) mkconstpv(aTHX_ "" S "", sizeof S - 1)
static OP *mktypecheck(pTHX_ const SV *declarator, int nr, SV *name, PADOFFSET padoff, SV *type) {
- /* $type->check($value) or Carp::croak "...: " . $type->get_message($value) */
- OP *chk, *err, *msg, *xcroak;
-
- err = mkconstsv(aTHX_ newSVpvf("In %"SVf": parameter %d (%"SVf"): ", SVfARG(declarator), 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
- ? S_newDEFSVOP(aTHX)
- : my_var(aTHX_ 0, padoff)
- );
- args = op_append_elem(OP_LIST, args, newUNOP(OP_METHOD, 0, mkconstpvs("get_message")));
-
- msg = args;
- msg->op_type = OP_ENTERSUB;
- msg->op_ppaddr = PL_ppaddr[OP_ENTERSUB];
- msg->op_flags |= OPf_STACKED;
- }
-
- msg = newBINOP(OP_CONCAT, 0, err, msg);
-
- xcroak = newCVREF(
- OPf_WANT_SCALAR,
- newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
- );
- xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
-
- {
- 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
- ? S_newDEFSVOP(aTHX)
- : my_var(aTHX_ 0, padoff)
- );
- args = op_append_elem(OP_LIST, args, newUNOP(OP_METHOD, 0, mkconstpvs("check")));
-
- chk = args;
- chk->op_type = OP_ENTERSUB;
- chk->op_ppaddr = PL_ppaddr[OP_ENTERSUB];
- chk->op_flags |= OPf_STACKED;
- }
-
- chk = newLOGOP(OP_OR, 0, chk, xcroak);
- return chk;
+ /* $type->check($value) or Carp::croak "...: " . $type->get_message($value) */
+ OP *chk, *err, *msg, *xcroak;
+
+ err = mkconstsv(aTHX_ newSVpvf("In %"SVf": parameter %d (%"SVf"): ", SVfARG(declarator), 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)
+ );
+ args = op_append_elem(OP_LIST, args, newUNOP(OP_METHOD, 0, mkconstpvs("get_message")));
+
+ msg = args;
+ msg->op_type = OP_ENTERSUB;
+ msg->op_ppaddr = PL_ppaddr[OP_ENTERSUB];
+ msg->op_flags |= OPf_STACKED;
+ }
+
+ msg = newBINOP(OP_CONCAT, 0, err, msg);
+
+ xcroak = newCVREF(
+ OPf_WANT_SCALAR,
+ newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
+ );
+ xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
+
+ {
+ 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)
+ );
+ args = op_append_elem(OP_LIST, args, newUNOP(OP_METHOD, 0, mkconstpvs("check")));
+
+ chk = args;
+ chk->op_type = OP_ENTERSUB;
+ chk->op_ppaddr = PL_ppaddr[OP_ENTERSUB];
+ chk->op_flags |= OPf_STACKED;
+ }
+
+ chk = newLOGOP(OP_OR, 0, chk, xcroak);
+ return chk;
}
static OP *mktypecheckp(pTHX_ const SV *declarator, int nr, const Param *param) {
- return mktypecheck(aTHX_ declarator, nr, param->name, param->padoff, param->type);
+ return mktypecheck(aTHX_ declarator, nr, param->name, param->padoff, param->type);
+}
+
+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;
+ OP *expr;
+ Resource *expr_sentinel;
+
+ lex_read_unichar(0);
+
+ floor = 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, expr);
+ if (!SvROK(*ptype)) {
+ *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype);
+ }
+ if (!sv_isobject(*ptype)) {
+ croak("In %"SVf": (%"SVf") doesn't look like 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->invocant.name && SvTRUE(spec->shift)) {
+ param_spec->invocant.name = spec->shift;
+ param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
+ }
+
+ 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, IF_HAVE_PERL_5_16(padadd_NO_DUP_CHECK, 0), NULL, NULL)
+ ;
}
static void register_info(pTHX_ UV key, SV *declarator, const KWSpec *kws, const ParamSpec *ps) {
- dSP;
-
- ENTER;
- SAVETMPS;
-
- PUSHMARK(SP);
- EXTEND(SP, 10);
-
- /* 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);
- }
- if (!ps) {
- if (SvTRUE(kws->shift)) {
- PUSHs(kws->shift);
- } else {
- PUSHmortal;
- }
- PUSHmortal;
- mPUSHs(newRV_noinc((SV *)newAV()));
- mPUSHs(newRV_noinc((SV *)newAV()));
- mPUSHs(newRV_noinc((SV *)newAV()));
- mPUSHs(newRV_noinc((SV *)newAV()));
- mPUSHp("@_", 2);
- PUSHmortal;
- } else {
- /* 2, 3 */ {
- if (ps->invocant.name) {
- PUSHs(ps->invocant.name);
- if (ps->invocant.type) {
- PUSHs(ps->invocant.type);
- } else {
- PUSHmortal;
- }
- } else {
- PUSHmortal;
- PUSHmortal;
- }
- }
- /* 4 */ {
- 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));
- }
- /* 5 */ {
- 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));
- }
- /* 6 */ {
- 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));
- }
- /* 7 */ {
- 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));
- }
- /* 8, 9 */ {
- 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;
+ dSP;
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ EXTEND(SP, 10);
+
+ /* 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);
+ }
+ if (!ps) {
+ if (SvTRUE(kws->shift)) {
+ PUSHs(kws->shift);
+ } else {
+ PUSHmortal;
+ }
+ PUSHmortal;
+ mPUSHs(newRV_noinc((SV *)newAV()));
+ mPUSHs(newRV_noinc((SV *)newAV()));
+ mPUSHs(newRV_noinc((SV *)newAV()));
+ mPUSHs(newRV_noinc((SV *)newAV()));
+ mPUSHp("@_", 2);
+ PUSHmortal;
+ } else {
+ /* 2, 3 */ {
+ if (ps->invocant.name) {
+ PUSHs(ps->invocant.name);
+ if (ps->invocant.type) {
+ PUSHs(ps->invocant.type);
+ } else {
+ PUSHmortal;
+ }
+ } else {
+ PUSHmortal;
+ PUSHmortal;
+ }
+ }
+ /* 4 */ {
+ 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));
+ }
+ /* 5 */ {
+ 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));
+ }
+ /* 6 */ {
+ 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));
+ }
+ /* 7 */ {
+ 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));
+ }
+ /* 8, 9 */ {
+ 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 function body, 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 = S_block_start(aTHX_ TRUE);
-
- /* initialize synthetic optree */
- Newx(prelude_sentinel, 1, OpGuard);
- op_guard_init(prelude_sentinel);
- sentinel_register(sen, prelude_sentinel, free_op_guard_void);
-
- /* parameters */
- param_spec = NULL;
-
- c = lex_peek_unichar(0);
- if (c == '(') {
- OpGuard *init_sentinel;
-
- Newx(init_sentinel, 1, OpGuard);
- op_guard_init(init_sentinel);
- sentinel_register(sen, init_sentinel, free_op_guard_void);
-
- Newx(param_spec, 1, ParamSpec);
- ps_init(param_spec);
- sentinel_register(sen, param_spec, ps_free_void);
-
- lex_read_unichar(0);
- lex_read_space(0);
-
- 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);
-
- S_intro_my(aTHX);
-
- sigil = SvPV_nolen(name)[0];
-
- /* internal consistency */
- if (flags & PARAM_NAMED) {
- 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));
- }
-
- /* external constraints */
- if (param_spec->slurpy.name) {
- croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(param_spec->slurpy.name), SVfARG(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->invocant.name) {
- croak("In %"SVf": invalid double invocants %"SVf", %"SVf"", SVfARG(declarator), SVfARG(param_spec->invocant.name), SVfARG(name));
- }
- if (count_positional_params(param_spec) || count_named_params(param_spec)) {
- croak("In %"SVf": invocant %"SVf" must be first in parameter list", SVfARG(declarator), SVfARG(name));
- }
- if (!(spec->flags & FLAG_INVOCANT)) {
- croak("In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
- }
- param_spec->invocant.name = name;
- param_spec->invocant.padoff = padoff;
- param_spec->invocant.type = type;
- continue;
- }
-
- if (init_sentinel->op && !(spec->flags & FLAG_DEFAULT_ARGS)) {
- croak("In %"SVf": default argument for %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
- }
-
- if (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 {
- Param *p;
-
- 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));
- }
-
- p = pv_extend(¶m_spec->named_required);
- p->name = name;
- p->padoff = padoff;
- p->type = type;
- param_spec->named_required.used++;
- }
- } else {
- if (init_sentinel->op || param_spec->positional_optional.used) {
- 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 {
- Param *p = pv_extend(¶m_spec->positional_required);
- p->name = name;
- p->padoff = padoff;
- p->type = type;
- param_spec->positional_required.used++;
- }
- }
-
- }
- lex_read_unichar(0);
- lex_read_space(0);
-
- if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
- if (ps_contains(aTHX_ param_spec, spec->shift)) {
- croak("In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(spec->shift));
- }
-
- param_spec->invocant.name = spec->shift;
- param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
- }
- }
-
- /* prototype */
- proto = NULL;
- c = lex_peek_unichar(0);
- if (c == ':') {
- lex_read_unichar(0);
- lex_read_space(0);
-
- c = lex_peek_unichar(0);
- if (c != '(') {
- lex_stuff_pvs(":", 0);
- c = ':';
- } else {
- lex_read_unichar(0);
- if (!(proto = my_scan_parens_tail(aTHX_ sen, FALSE))) {
- croak("In %"SVf": prototype not terminated", SVfARG(declarator));
- }
- my_check_prototype(aTHX_ sen, declarator, proto);
- lex_read_space(0);
- c = lex_peek_unichar(0);
- if (!(c == ':' || c == '{')) {
- lex_stuff_pvs(":", 0);
- c = ':';
- }
- }
- }
-
- /* attributes */
- Newx(attrs_sentinel, 1, OpGuard);
- op_guard_init(attrs_sentinel);
- sentinel_register(sen, attrs_sentinel, free_op_guard_void);
-
- 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));
- }
- 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->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);
-
- 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(aTHX_ param_spec, spec);
- if (amin > 0) {
- OP *chk, *cond, *err, *xcroak;
-
- err = mkconstsv(aTHX_ newSVpvf("Not enough 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(")")
- );
-
- xcroak = newCVREF(OPf_WANT_SCALAR,
- newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
- err = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, err, xcroak));
-
- 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, *xcroak;
-
- 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(")")
- );
-
- xcroak = newCVREF(
- OPf_WANT_SCALAR,
- newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
- );
- err = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, err, xcroak));
-
- 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 (param_spec && (count_named_params(param_spec) || (param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%'))) {
- OP *chk, *cond, *err, *xcroak;
- const UV fixed = count_positional_params(param_spec) + !!param_spec->invocant.name;
-
- err = mkconstsv(aTHX_ newSVpvf("Odd number of paired arguments for %"SVf"", SVfARG(declarator)));
-
- xcroak = newCVREF(
- OPf_WANT_SCALAR,
- newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
- );
- err = newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST, err, xcroak));
-
- 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)));
- }
- }
-
- if (!param_spec) {
- /* my $invocant = shift; */
- if (SvTRUE(spec->shift)) {
- OP *var;
-
- var = my_var(
- aTHX_
- OPf_MOD | (OPpLVAL_INTRO << 8),
- pad_add_name_sv(spec->shift, 0, NULL, NULL)
- );
- 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 {
- /* my $invocant = shift; */
- if (param_spec->invocant.name) {
- OP *var;
-
- var = my_var(
- aTHX_
- OPf_MOD | (OPpLVAL_INTRO << 8),
- param_spec->invocant.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)));
-
- if (param_spec->invocant.type && (spec->flags & FLAG_CHECK_TARGS)) {
- op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckp(aTHX_ declarator, 0, ¶m_spec->invocant))));
- }
- }
-
- /* my (...) = @_; */
- {
- OP *lhs;
- size_t i, lim;
-
- lhs = NULL;
-
- for (i = 0, lim = param_spec->positional_required.used; i < lim; i++) {
- OP *const var = my_var(
- aTHX_
- OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
- param_spec->positional_required.data[i].padoff
- );
- lhs = op_append_elem(OP_LIST, lhs, var);
- }
-
- for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
- OP *const var = my_var(
- aTHX_
- OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
- param_spec->positional_optional.data[i].param.padoff
- );
- lhs = op_append_elem(OP_LIST, lhs, var);
- }
-
- {
- 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) {
- padoff = param_spec->slurpy.padoff;
- type = slurpy_hash ? OP_PADHV : OP_PADAV;
- } else {
- padoff = NOT_IN_PAD;
- type = OP_PADSV;
- }
- } else if (slurpy_hash) {
- padoff = param_spec->slurpy.padoff;
- type = OP_PADHV;
- } else {
- padoff = param_spec->rest_hash = 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 *rhs;
- lhs->op_flags |= OPf_PARENS;
- rhs = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
-
- 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;
- for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
- ParamInit *cur = ¶m_spec->positional_optional.data[i];
- OP *var, *cond;
-
- cond = newBINOP(
- OP_LT, 0,
- newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
- mkconstiv(aTHX_ req + i + 1)
- );
-
- var = my_var(aTHX_ 0, cur->param.padoff);
-
- nest = op_append_list(
- OP_LINESEQ, nest,
- newASSIGNOP(OPf_STACKED, var, 0, op_guard_relinquish(&cur->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;
-
- 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 = newCVREF(
- OPf_WANT_SCALAR,
- newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
- );
- xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
-
- 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, *cond;
-
- var = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
- var = newUNOP(OP_DELETE, 0, var);
-
- cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
- cond = newUNOP(OP_EXISTS, 0, cond);
-
- cond = newCONDOP(0, cond, var, op_guard_relinquish(&cur->init));
-
- var = my_var(
- aTHX_
- OPf_MOD | (OPpLVAL_INTRO << 8),
- cur->param.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)));
- }
-
- 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);
- {
- OP *first, *mid, *last;
-
- last = keys;
-
- mid = mkconstpvs(", ");
- mid->op_sibling = last;
-
- first = newOP(OP_PUSHMARK, 0);
-
- keys = newLISTOP(OP_JOIN, 0, first, mid);
- keys->op_targ = pad_alloc(OP_JOIN, SVs_PADTMP);
- ((LISTOP *)keys)->op_last = last;
- }
-
- msg = mkconstsv(aTHX_ newSVpvf("In %"SVf": no such named parameter: ", SVfARG(declarator)));
- msg = newBINOP(OP_CONCAT, 0, msg, keys);
-
- xcroak = newCVREF(
- OPf_WANT_SCALAR,
- newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
- );
- xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
-
- cond = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
- xcroak = newCONDOP(0, cond, xcroak, NULL);
+ 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 function body, 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 */
+ param_spec = NULL;
+
+ c = lex_peek_unichar(0);
+ if (c == '(') {
+ OpGuard *init_sentinel;
+
+ Newx(init_sentinel, 1, OpGuard);
+ op_guard_init(init_sentinel);
+ sentinel_register(sen, init_sentinel, free_op_guard_void);
+
+ Newx(param_spec, 1, ParamSpec);
+ ps_init(param_spec);
+ sentinel_register(sen, param_spec, ps_free_void);
+
+ lex_read_unichar(0);
+ lex_read_space(0);
+
+ 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": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(param_spec->slurpy.name), SVfARG(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->invocant.name) {
+ croak("In %"SVf": invalid double invocants %"SVf", %"SVf"", SVfARG(declarator), SVfARG(param_spec->invocant.name), SVfARG(name));
+ }
+ if (count_positional_params(param_spec) || count_named_params(param_spec)) {
+ croak("In %"SVf": invocant %"SVf" must be first in parameter list", SVfARG(declarator), SVfARG(name));
+ }
+ if (!(spec->flags & FLAG_INVOCANT)) {
+ croak("In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
+ }
+ param_spec->invocant.name = name;
+ param_spec->invocant.padoff = padoff;
+ param_spec->invocant.type = type;
+ continue;
+ }
+
+ 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 {
+ Param *p;
+
+ 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));
+ }
+
+ p = pv_extend(¶m_spec->named_required);
+ p->name = name;
+ p->padoff = padoff;
+ p->type = type;
+ param_spec->named_required.used++;
+ }
+ } 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 {
+ Param *p = pv_extend(¶m_spec->positional_required);
+ assert(param_spec->positional_optional.used == 0);
+ p->name = name;
+ p->padoff = padoff;
+ p->type = type;
+ param_spec->positional_required.used++;
+ }
+ }
+
+ }
+ lex_read_unichar(0);
+ lex_read_space(0);
+
+ if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
+ if (ps_contains(aTHX_ param_spec, spec->shift)) {
+ croak("In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(spec->shift));
+ }
+
+ param_spec->invocant.name = spec->shift;
+ param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
+ }
+ }
+
+ /* prototype */
+ proto = NULL;
+ c = lex_peek_unichar(0);
+ if (c == ':') {
+ lex_read_unichar(0);
+ lex_read_space(0);
+
+ c = lex_peek_unichar(0);
+ if (c != '(') {
+ lex_stuff_pvs(":", 0);
+ c = ':';
+ } else {
+ lex_read_unichar(0);
+ if (!(proto = my_scan_parens_tail(aTHX_ sen, FALSE))) {
+ croak("In %"SVf": prototype not terminated", SVfARG(declarator));
+ }
+ my_check_prototype(aTHX_ sen, declarator, proto);
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (!(c == ':' || c == '{')) {
+ lex_stuff_pvs(":", 0);
+ c = ':';
+ }
+ }
+ }
+
+ /* attributes */
+ Newx(attrs_sentinel, 1, OpGuard);
+ op_guard_init(attrs_sentinel);
+ sentinel_register(sen, attrs_sentinel, free_op_guard_void);
+
+ 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->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);
+
+ 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(aTHX_ param_spec, spec);
+ if (amin > 0) {
+ OP *chk, *cond, *err, *xcroak;
+
+ 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(")")
+ );
+
+ xcroak = newCVREF(OPf_WANT_SCALAR,
+ newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
+ err = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ op_append_elem(OP_LIST, err, xcroak));
+
+ 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, *xcroak;
+
+ 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(")")
+ );
+
+ xcroak = newCVREF(
+ OPf_WANT_SCALAR,
+ newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
+ );
+ err = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ op_append_elem(OP_LIST, err, xcroak));
+
+ 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 (param_spec && (count_named_params(param_spec) || (param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%'))) {
+ OP *chk, *cond, *err, *xcroak;
+ const UV fixed = count_positional_params(param_spec) + !!param_spec->invocant.name;
+
+ err = mkconstsv(aTHX_ newSVpvf("Odd number of paired arguments for %"SVf"", SVfARG(declarator)));
+
+ xcroak = newCVREF(
+ OPf_WANT_SCALAR,
+ newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
+ );
+ err = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ op_append_elem(OP_LIST, err, xcroak));
+
+ 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)));
+ }
+ }
+
+ if (!param_spec) {
+ /* my $invocant = shift; */
+ if (SvTRUE(spec->shift)) {
+ OP *var;
+
+ var = my_var(
+ aTHX_
+ OPf_MOD | (OPpLVAL_INTRO << 8),
+ pad_add_name_sv(spec->shift, 0, NULL, NULL)
+ );
+ 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 {
+ if (param_spec->invocant.name) {
+ if (param_spec->invocant.padoff == NOT_IN_PAD) {
+ /* 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->invocant.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)));
+
+ if (param_spec->invocant.type && (spec->flags & FLAG_CHECK_TARGS)) {
+ op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckp(aTHX_ declarator, 0, ¶m_spec->invocant))));
+ }
+ }
+ }
+
+ /* my (...) = @_; */
+ {
+ OP *lhs;
+ size_t i, lim;
+
+ lhs = NULL;
+
+ for (i = 0, 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 *rhs;
+ lhs->op_flags |= OPf_PARENS;
+ rhs = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
+
+ 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;
+ 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 = newCVREF(
+ OPf_WANT_SCALAR,
+ newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
+ );
+ xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
+
+ 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);
+ {
+ OP *first, *mid, *last;
+
+ last = keys;
+
+ mid = mkconstpvs(", ");
+ mid->op_sibling = last;
- op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, xcroak)));
- } else {
- OP *clear;
+ first = newOP(OP_PUSHMARK, 0);
- 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 *var, *clear;
-
- assert(SvPV_nolen(param_spec->slurpy.name)[0] == '@');
-
- 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) {
- 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->positional_optional.used; i < lim; i++) {
- Param *cur = ¶m_spec->positional_optional.data[i].param;
-
- if (cur->type) {
- 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) {
- 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) {
- 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;
-
- 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. */
- {
- int runtime = spec->flags & FLAG_RUNTIME;
- CV *cv;
- OP *const attrs = op_guard_relinquish(attrs_sentinel);
-
- SvREFCNT_inc_simple_void(PL_compcv);
-
- /* close outer block: '}' */
- S_block_end(aTHX_ save_ix, body);
-
- cv = newATTRSUB(
- floor_ix,
- saw_name && !runtime ? 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) {
- register_info(aTHX_ PTR2UV(CvROOT(cv)), declarator, spec, param_spec);
- }
-
- if (saw_name) {
- if (!runtime) {
- *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(0, newGVOP(OP_GV, 0, gv_fetchpvs(MY_PKG "::_defun", 0, SVt_PVCV)))
- )
- );
- }
- return KEYWORD_PLUGIN_STMT;
- }
-
- *pop = newUNOP(
- OP_REFGEN, 0,
- newSVOP(
- OP_ANONCODE, 0,
- (SV *)cv
- )
- );
- return KEYWORD_PLUGIN_EXPR;
- }
+ keys = newLISTOP(OP_JOIN, 0, first, mid);
+ keys->op_targ = pad_alloc(OP_JOIN, SVs_PADTMP);
+ ((LISTOP *)keys)->op_last = last;
+#if HAVE_PERL_VERSION(5, 21, 2)
+ mid->op_lastsib = 0;
+ last->op_lastsib = 1;
+#endif
+ }
+
+ msg = mkconstsv(aTHX_ newSVpvf("In %"SVf": no such named parameter: ", SVfARG(declarator)));
+ msg = newBINOP(OP_CONCAT, 0, msg, keys);
+
+ xcroak = newCVREF(
+ OPf_WANT_SCALAR,
+ newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
+ );
+ xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
+
+ 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) {
+ 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->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. */
+ {
+ int runtime = spec->flags & FLAG_RUNTIME;
+ CV *cv;
+ OP *const attrs = op_guard_relinquish(attrs_sentinel);
+
+ SvREFCNT_inc_simple_void(PL_compcv);
+
+ /* close outer block: '}' */
+ block_end(save_ix, body);
+
+ cv = newATTRSUB(
+ floor_ix,
+ saw_name && !runtime ? 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) {
+ register_info(aTHX_ PTR2UV(CvROOT(cv)), declarator, spec, param_spec);
+ }
+
+ if (saw_name) {
+ if (!runtime) {
+ *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(0, newGVOP(OP_GV, 0, gv_fetchpvs(MY_PKG "::_defun", 0, SVt_PVCV)))
+ )
+ );
+ }
+ 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 sen, const char *kw_ptr, STRLEN kw_len, KWSpec *spec) {
- HV *hints;
- SV *sv, **psv;
- const char *p, *kw_active;
- STRLEN kw_active_len;
- bool kw_is_utf8;
-
- if (!(hints = GvHV(PL_hintgv))) {
- return FALSE;
- }
- if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
- return FALSE;
- }
- sv = *psv;
- kw_active = SvPV(sv, kw_active_len);
- if (kw_active_len <= kw_len) {
- return FALSE;
- }
-
- kw_is_utf8 = lex_bufutf8();
-
- for (
- p = kw_active;
- (p = strchr(p, *kw_ptr)) &&
- p < kw_active + kw_active_len - kw_len;
- p++
- ) {
- if (
- (p == kw_active || p[-1] == ' ') &&
- p[kw_len] == ' ' &&
- memcmp(kw_ptr, p, kw_len) == 0
- ) {
- ENTER;
- SAVETMPS;
-
- SAVEDESTRUCTOR_X(sentinel_clear_void, sen);
-
- spec->flags = 0;
- spec->reify_type = 0;
- spec->shift = sentinel_mortalize(sen, newSVpvs(""));
- spec->attrs = sentinel_mortalize(sen, newSVpvs(""));
+static int kw_flags_enter(pTHX_ Resource ***psen, const char *kw_ptr, STRLEN kw_len, KWSpec *spec) {
+ HV *hints;
+ SV *sv, **psv;
+ const char *p, *kw_active;
+ STRLEN kw_active_len;
+ bool kw_is_utf8;
+
+ if (!(hints = GvHV(PL_hintgv))) {
+ return FALSE;
+ }
+ if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
+ return FALSE;
+ }
+ sv = *psv;
+ kw_active = SvPV(sv, kw_active_len);
+ if (kw_active_len <= kw_len) {
+ return FALSE;
+ }
+
+ kw_is_utf8 = lex_bufutf8();
+
+ for (
+ p = kw_active;
+ (p = strchr(p, *kw_ptr)) &&
+ p < kw_active + kw_active_len - kw_len;
+ p++
+ ) {
+ if (
+ (p == kw_active || p[-1] == ' ') &&
+ p[kw_len] == ' ' &&
+ memcmp(kw_ptr, p, kw_len) == 0
+ ) {
+ ENTER;
+ SAVETMPS;
+
+ Newx(*psen, 1, Resource *);
+ **psen = NULL;
+ SAVEDESTRUCTOR_X(sentinel_clear_void, *psen);
+
+ spec->flags = 0;
+ spec->reify_type = 0;
+ spec->shift = sentinel_mortalize(*psen, newSVpvs(""));
+ spec->attrs = sentinel_mortalize(*psen, newSVpvs(""));
#define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \
- const char *fk_ptr_; \
- STRLEN fk_len_; \
- I32 fk_xlen_; \
- SV *fk_sv_; \
- fk_sv_ = sentinel_mortalize(sen, newSVpvs(HINTK_ ## NAME)); \
- sv_catpvn(fk_sv_, PTR, LEN); \
- fk_ptr_ = SvPV(fk_sv_, fk_len_); \
- fk_xlen_ = fk_len_; \
- if (kw_is_utf8) { \
- fk_xlen_ = -fk_xlen_; \
- } \
- if (!((X) = hv_fetch(hints, fk_ptr_, fk_xlen_, 0))) { \
- croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \
- } \
+ const char *fk_ptr_; \
+ STRLEN fk_len_; \
+ I32 fk_xlen_; \
+ SV *fk_sv_; \
+ fk_sv_ = sentinel_mortalize(*psen, newSVpvs(HINTK_ ## NAME)); \
+ sv_catpvn(fk_sv_, PTR, LEN); \
+ fk_ptr_ = SvPV(fk_sv_, fk_len_); \
+ fk_xlen_ = fk_len_; \
+ if (kw_is_utf8) { \
+ fk_xlen_ = -fk_xlen_; \
+ } \
+ if (!((X) = hv_fetch(hints, fk_ptr_, fk_xlen_, 0))) { \
+ croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \
+ } \
} STMT_END
- FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv);
- spec->flags = SvIV(*psv);
+ FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv);
+ spec->flags = SvIV(*psv);
- FETCH_HINTK_INTO(REIFY_, kw_ptr, kw_len, psv);
- spec->reify_type = SvIV(*psv);
+ FETCH_HINTK_INTO(REIFY_, kw_ptr, kw_len, psv);
+ spec->reify_type = SvIV(*psv);
- FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
- SvSetSV(spec->shift, *psv);
+ FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
+ SvSetSV(spec->shift, *psv);
- FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
- SvSetSV(spec->attrs, *psv);
+ FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
+ SvSetSV(spec->attrs, *psv);
#undef FETCH_HINTK_INTO
- return TRUE;
- }
- }
- return FALSE;
+ return TRUE;
+ }
+ }
+ return FALSE;
}
static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
- Sentinel sen = { NULL };
- KWSpec spec;
- int ret;
-
- if (kw_flags_enter(aTHX_ sen, keyword_ptr, keyword_len, &spec)) {
- /* scope was entered, 'sen' and 'spec' are initialized */
- ret = parse_fun(aTHX_ sen, op_ptr, keyword_ptr, keyword_len, &spec);
- FREETMPS;
- LEAVE;
- } else {
- /* not one of our keywords, no allocation done */
- ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
- }
-
- return ret;
+ Resource **sen;
+ KWSpec spec;
+ int ret;
+
+ if (kw_flags_enter(aTHX_ &sen, keyword_ptr, keyword_len, &spec)) {
+ /* scope was entered, 'sen' and 'spec' are initialized */
+ ret = parse_fun(aTHX_ sen, op_ptr, keyword_ptr, keyword_len, &spec);
+ FREETMPS;
+ LEAVE;
+ } else {
+ /* not one of our keywords, no allocation done */
+ ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
+ }
+
+ return ret;
}
-#ifndef SvREFCNT_dec_NN
-#define SvREFCNT_dec_NN(SV) SvREFCNT_dec(SV)
-#endif
-
#ifndef assert_
#ifdef DEBUGGING
#define assert_(X) assert(X),
@@ -2081,10 +2178,10 @@ static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **o
#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)) \
+ assert_(isGV_with_GP(GV)) \
+ GvREFCNT(GV) > 1 \
+ ? (void)PL_sub_generation++ \
+ : mro_method_changed_in(GvSTASH(GV)) \
)
#endif
@@ -2095,62 +2192,62 @@ 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
+ 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);
+ 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:
WARNINGS_ENABLE {
- 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_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
- newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
- newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
- newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
- newCONSTSUB(stash, "HINTK_REIFY_", newSVpvs(HINTK_REIFY_));
- /**/
- next_keyword_plugin = PL_keyword_plugin;
- PL_keyword_plugin = my_keyword_plugin;
+ 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_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
+ newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
+ newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
+ newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
+ newCONSTSUB(stash, "HINTK_REIFY_", newSVpvs(HINTK_REIFY_));
+ /**/
+ next_keyword_plugin = PL_keyword_plugin;
+ PL_keyword_plugin = my_keyword_plugin;
} WARNINGS_RESET
@@ -36,7 +36,7 @@ You can also look for information at:
COPYRIGHT AND LICENCE
-Copyright (C) 2009-2013 Lukas Mai
+Copyright (C) 2009-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
@@ -0,0 +1,8 @@
+/* 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
@@ -0,0 +1,8 @@
+/* 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
@@ -0,0 +1,45 @@
+/* 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
@@ -0,0 +1,25 @@
+/* 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
@@ -0,0 +1,49 @@
+/* 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
@@ -0,0 +1,22 @@
+/* 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
@@ -0,0 +1,7 @@
+/* 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
@@ -0,0 +1,79 @@
+/* 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
@@ -0,0 +1,56 @@
+/* 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
@@ -0,0 +1,25 @@
+/* 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
@@ -0,0 +1,11 @@
+/* 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
@@ -0,0 +1,56 @@
+/* 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
@@ -0,0 +1,669 @@
+/* vi: set ft=c inde=: */
+
+#ifndef scalarseq
+
+#define scalarseq(A) S_scalarseq(aTHX_ A)
+
+/* Check for in place reverse and sort assignments like "@a = reverse @a"
+ and modify the optree to make them work inplace */
+
+static void S_inplace_aassign(pTHX_ OP *o) {
+ OP *modop, *modop_pushmark;
+ OP *oright;
+ OP *oleft, *oleft_pushmark;
+
+ /* PERL_ARGS_ASSERT_INPLACE_AASSIGN; */
+
+ assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
+
+ assert(cUNOPo->op_first->op_type == OP_NULL);
+ modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
+ assert(modop_pushmark->op_type == OP_PUSHMARK);
+ modop = modop_pushmark->op_sibling;
+
+ if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
+ return;
+
+ /* no other operation except sort/reverse */
+ if (modop->op_sibling)
+ return;
+
+ assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
+ if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
+
+ if (modop->op_flags & OPf_STACKED) {
+ /* skip sort subroutine/block */
+ assert(oright->op_type == OP_NULL);
+ oright = oright->op_sibling;
+ }
+
+ assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
+ oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
+ assert(oleft_pushmark->op_type == OP_PUSHMARK);
+ oleft = oleft_pushmark->op_sibling;
+
+ /* Check the lhs is an array */
+ if (!oleft ||
+ (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
+ || oleft->op_sibling
+ || (oleft->op_private & OPpLVAL_INTRO)
+ )
+ return;
+
+ /* Only one thing on the rhs */
+ if (oright->op_sibling)
+ return;
+
+ /* check the array is the same on both sides */
+ if (oleft->op_type == OP_RV2AV) {
+ if (oright->op_type != OP_RV2AV
+ || !cUNOPx(oright)->op_first
+ || cUNOPx(oright)->op_first->op_type != OP_GV
+ || cUNOPx(oleft )->op_first->op_type != OP_GV
+ || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+ cGVOPx_gv(cUNOPx(oright)->op_first)
+ )
+ return;
+ }
+ else if (oright->op_type != OP_PADAV
+ || oright->op_targ != oleft->op_targ
+ )
+ return;
+
+ /* This actually is an inplace assignment */
+
+ modop->op_private |= OPpSORT_INPLACE;
+
+ /* transfer MODishness etc from LHS arg to RHS arg */
+ oright->op_flags = oleft->op_flags;
+
+ /* remove the aassign op and the lhs */
+ op_null(o);
+ op_null(oleft_pushmark);
+ if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
+ op_null(cUNOPx(oleft)->op_first);
+ op_null(oleft);
+}
+
+#if HAVE_PERL_VERSION(5, 19, 4)
+
+/* varname(): return the name of a variable, optionally with a subscript.
+ * If gv is non-zero, use the name of that global, along with gvtype (one
+ * of "$", "@", "%"); otherwise use the name of the lexical at pad offset
+ * targ. Depending on the value of the subscript_type flag, return:
+ */
+
+#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */
+#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */
+#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */
+#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */
+
+static SV *S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, const SV *const keyname, I32 aindex, int subscript_type) {
+ SV * const name = sv_newmortal();
+ if (gv && isGV(gv)) {
+ char buffer[2];
+ buffer[0] = gvtype;
+ buffer[1] = 0;
+
+ /* as gv_fullname4(), but add literal '^' for $^FOO names */
+
+ gv_fullname4(name, gv, buffer, 0);
+
+ if ((unsigned int)SvPVX(name)[1] <= 26) {
+ buffer[0] = '^';
+ buffer[1] = SvPVX(name)[1] + 'A' - 1;
+
+ /* Swap the 1 unprintable control character for the 2 byte pretty
+ version - ie substr($name, 1, 1) = $buffer; */
+ sv_insert(name, 1, 1, buffer, 2);
+ }
+ }
+ else {
+ CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL);
+ SV *sv;
+ AV *av;
+
+ assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
+
+ if (!cv || !CvPADLIST(cv))
+ return NULL;
+ av = *PadlistARRAY(CvPADLIST(cv));
+ sv = *av_fetch(av, targ, FALSE);
+ sv_setsv_flags(name, sv, 0);
+ }
+
+ if (subscript_type == FUV_SUBSCRIPT_HASH) {
+ SV * const sv = newSV(0);
+ *SvPVX(name) = '$';
+ Perl_sv_catpvf(aTHX_ name, "{%s}",
+ pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
+ SvREFCNT_dec_NN(sv);
+ }
+ else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
+ *SvPVX(name) = '$';
+ Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
+ }
+ else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
+ /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
+ Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0);
+ }
+
+ return name;
+}
+
+static SV *S_op_varname(pTHX_ const OP *o) {
+ assert(o);
+ assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
+ o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
+ {
+ const char funny = o->op_type == OP_PADAV
+ || o->op_type == OP_RV2AV ? '@' : '%';
+ if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
+ GV *gv;
+ if (cUNOPo->op_first->op_type != OP_GV
+ || !(gv = cGVOPx_gv(cUNOPo->op_first)))
+ return NULL;
+ return S_varname(aTHX_ gv, funny, 0, NULL, 0, 1);
+ }
+ return
+ S_varname(aTHX_ MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
+ }
+}
+
+static void
+S_op_pretty(pTHX_ const OP *o, SV **retsv, const char **retpv) {
+ /* or not so pretty :-) */
+ if (o->op_type == OP_CONST) {
+ *retsv = cSVOPo_sv;
+ if (SvPOK(*retsv)) {
+ SV *sv = *retsv;
+ *retsv = sv_newmortal();
+ pv_pretty(*retsv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
+ }
+ else if (!SvOK(*retsv))
+ *retpv = "undef";
+ }
+ else *retpv = "...";
+}
+
+#endif
+
+static OP *S_scalarvoid(pTHX_ OP *);
+
+static OP *S_scalar(pTHX_ OP *o) {
+ dVAR;
+ OP *kid;
+
+ /* assumes no premature commitment */
+ if (!o || (PL_parser && PL_parser->error_count)
+ || (o->op_flags & OPf_WANT)
+ || o->op_type == OP_RETURN)
+ {
+ return o;
+ }
+
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
+
+ switch (o->op_type) {
+ case OP_REPEAT:
+ S_scalar(aTHX_ cBINOPo->op_first);
+ break;
+ case OP_OR:
+ case OP_AND:
+ case OP_COND_EXPR:
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ S_scalar(aTHX_ kid);
+ break;
+ /* FALL THROUGH */
+ case OP_SPLIT:
+ case OP_MATCH:
+ case OP_QR:
+ case OP_SUBST:
+ case OP_NULL:
+ default:
+ if (o->op_flags & OPf_KIDS) {
+ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
+ S_scalar(aTHX_ kid);
+ }
+ break;
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ kid = cLISTOPo->op_first;
+ S_scalar(aTHX_ kid);
+ kid = kid->op_sibling;
+do_kids:
+ while (kid) {
+ OP *sib = kid->op_sibling;
+ if (sib && kid->op_type != OP_LEAVEWHEN)
+ S_scalarvoid(aTHX_ kid);
+ else
+ S_scalar(aTHX_ kid);
+ kid = sib;
+ }
+ PL_curcop = &PL_compiling;
+ break;
+ case OP_SCOPE:
+ case OP_LINESEQ:
+ case OP_LIST:
+ kid = cLISTOPo->op_first;
+ goto do_kids;
+ case OP_SORT:
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
+ break;
+#if HAVE_PERL_VERSION(5, 19, 4)
+ case OP_KVHSLICE:
+ case OP_KVASLICE:
+ {
+ /* Warn about scalar context */
+ const char lbrack = o->op_type == OP_KVHSLICE ? '{' : '[';
+ const char rbrack = o->op_type == OP_KVHSLICE ? '}' : ']';
+ SV *name;
+ SV *keysv = NULL;
+ const char *key = NULL;
+
+ /* This warning can be nonsensical when there is a syntax error. */
+ if (PL_parser && PL_parser->error_count)
+ break;
+
+ if (!ckWARN(WARN_SYNTAX)) break;
+
+ kid = cLISTOPo->op_first;
+ kid = kid->op_sibling; /* get past pushmark */
+ assert(kid->op_sibling);
+ name = S_op_varname(aTHX_ kid->op_sibling);
+ if (!name) /* XS module fiddling with the op tree */
+ break;
+ S_op_pretty(aTHX_ kid, &keysv, &key);
+ assert(SvPOK(name));
+ sv_chop(name,SvPVX(name)+1);
+ if (key)
+ /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%%%"SVf"%c%s%c in scalar context better written "
+ "as $%"SVf"%c%s%c",
+ SVfARG(name), lbrack, key, rbrack, SVfARG(name),
+ lbrack, key, rbrack);
+ else
+ /* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "%%%"SVf"%c%"SVf"%c in scalar context better "
+ "written as $%"SVf"%c%"SVf"%c",
+ SVfARG(name), lbrack, keysv, rbrack,
+ SVfARG(name), lbrack, keysv, rbrack);
+ }
+#endif
+ }
+ return o;
+}
+
+static OP *S_scalarkids(pTHX_ OP *o) {
+ if (o && o->op_flags & OPf_KIDS) {
+ OP *kid;
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ S_scalar(aTHX_ kid);
+ }
+ return o;
+}
+
+static OP *S_scalarvoid(pTHX_ OP *o) {
+ dVAR;
+ OP *kid;
+ SV *useless_sv = NULL;
+ const char *useless = NULL;
+ SV *sv;
+ U8 want;
+
+ PERL_ARGS_ASSERT_SCALARVOID;
+
+ if (o->op_type == OP_NEXTSTATE
+ || o->op_type == OP_DBSTATE
+ || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE
+ || o->op_targ == OP_DBSTATE)))
+ PL_curcop = (COP*)o; /* for warning below */
+
+ /* assumes no premature commitment */
+ want = o->op_flags & OPf_WANT;
+ if ((want && want != OPf_WANT_SCALAR)
+ || (PL_parser && PL_parser->error_count)
+ || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
+ {
+ return o;
+ }
+
+ if ((o->op_private & OPpTARGET_MY)
+ && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
+ {
+ return S_scalar(aTHX_ o); /* As if inside SASSIGN */
+ }
+
+ o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
+
+ switch (o->op_type) {
+ default:
+ if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
+ break;
+ /* FALL THROUGH */
+ case OP_REPEAT:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ goto func_ops;
+ case OP_SUBSTR:
+ if (o->op_private == 4)
+ break;
+ /* FALL THROUGH */
+ case OP_GVSV:
+ case OP_WANTARRAY:
+ case OP_GV:
+ case OP_SMARTMATCH:
+ case OP_PADSV:
+ case OP_PADAV:
+ case OP_PADHV:
+ case OP_PADANY:
+ case OP_AV2ARYLEN:
+ case OP_REF:
+ case OP_REFGEN:
+ case OP_SREFGEN:
+ case OP_DEFINED:
+ case OP_HEX:
+ case OP_OCT:
+ case OP_LENGTH:
+ case OP_VEC:
+ case OP_INDEX:
+ case OP_RINDEX:
+ case OP_SPRINTF:
+ case OP_AELEM:
+ case OP_AELEMFAST:
+ IF_HAVE_PERL_5_16(case OP_AELEMFAST_LEX:, )
+ case OP_ASLICE:
+ IF_HAVE_PERL_5_19_4(case OP_KVASLICE:, )
+ case OP_HELEM:
+ case OP_HSLICE:
+ IF_HAVE_PERL_5_19_4(case OP_KVHSLICE:, )
+ case OP_UNPACK:
+ case OP_PACK:
+ case OP_JOIN:
+ case OP_LSLICE:
+ case OP_ANONLIST:
+ case OP_ANONHASH:
+ case OP_SORT:
+ case OP_REVERSE:
+ case OP_RANGE:
+ case OP_FLIP:
+ case OP_FLOP:
+ case OP_CALLER:
+ case OP_FILENO:
+ case OP_EOF:
+ case OP_TELL:
+ case OP_GETSOCKNAME:
+ case OP_GETPEERNAME:
+ case OP_READLINK:
+ case OP_TELLDIR:
+ case OP_GETPPID:
+ case OP_GETPGRP:
+ case OP_GETPRIORITY:
+ case OP_TIME:
+ case OP_TMS:
+ case OP_LOCALTIME:
+ case OP_GMTIME:
+ case OP_GHBYNAME:
+ case OP_GHBYADDR:
+ case OP_GHOSTENT:
+ case OP_GNBYNAME:
+ case OP_GNBYADDR:
+ case OP_GNETENT:
+ case OP_GPBYNAME:
+ case OP_GPBYNUMBER:
+ case OP_GPROTOENT:
+ case OP_GSBYNAME:
+ case OP_GSBYPORT:
+ case OP_GSERVENT:
+ case OP_GPWNAM:
+ case OP_GPWUID:
+ case OP_GGRNAM:
+ case OP_GGRGID:
+ case OP_GETLOGIN:
+ case OP_PROTOTYPE:
+ IF_HAVE_PERL_5_16(case OP_RUNCV:, )
+func_ops:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
+ /* Otherwise it's "Useless use of grep iterator" */
+ useless = OP_DESC(o);
+ break;
+
+ case OP_SPLIT:
+ kid = cLISTOPo->op_first;
+ if (kid && kid->op_type == OP_PUSHRE
+#ifdef USE_ITHREADS
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff
+#else
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv
+#endif
+ )
+ useless = OP_DESC(o);
+ break;
+
+ case OP_NOT:
+ kid = cUNOPo->op_first;
+ if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
+ kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
+ goto func_ops;
+ }
+ useless = "negative pattern binding (!~)";
+ break;
+
+ case OP_SUBST:
+ if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
+ useless = "non-destructive substitution (s///r)";
+ break;
+
+ case OP_TRANSR:
+ useless = "non-destructive transliteration (tr///r)";
+ break;
+
+ case OP_RV2GV:
+ case OP_RV2SV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
+ (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
+ useless = "a variable";
+ break;
+
+ case OP_CONST:
+ sv = cSVOPo_sv;
+ if (cSVOPo->op_private & OPpCONST_STRICT) {
+ /* no_bareword_allowed(o); */
+ croak("%s: internal error: what even are birds", MY_PKG);
+ } else {
+ if (ckWARN(WARN_VOID)) {
+ /* don't warn on optimised away booleans, eg
+ * use constant Foo, 5; Foo || print; */
+ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
+ useless = NULL;
+ /* the constants 0 and 1 are permitted as they are
+ conventionally used as dummies in constructs like
+ 1 while some_condition_with_side_effects; */
+ else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
+ useless = NULL;
+ else if (SvPOK(sv)) {
+ SV * const dsv = newSVpvs("");
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, SvPVX_const(sv),
+ SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP
+ | PERL_PV_ESCAPE_NOCLEAR
+ | PERL_PV_ESCAPE_UNI_DETECT));
+ SvREFCNT_dec_NN(dsv);
+ }
+ else if (SvOK(sv)) {
+ useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
+ }
+ else
+ useless = "a constant (undef)";
+ }
+ }
+ op_null(o); /* don't execute or even remember it */
+ break;
+
+ case OP_POSTINC:
+ o->op_type = OP_PREINC; /* pre-increment is faster */
+ o->op_ppaddr = PL_ppaddr[OP_PREINC];
+ break;
+
+ case OP_POSTDEC:
+ o->op_type = OP_PREDEC; /* pre-decrement is faster */
+ o->op_ppaddr = PL_ppaddr[OP_PREDEC];
+ break;
+
+ case OP_I_POSTINC:
+ o->op_type = OP_I_PREINC; /* pre-increment is faster */
+ o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
+ break;
+
+ case OP_I_POSTDEC:
+ o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
+ o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
+ break;
+
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
+
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
+
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
+
+ refgen = (UNOP *)((BINOP *)o)->op_first;
+
+ if (!refgen || refgen->op_type != OP_REFGEN)
+ break;
+
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_first->op_type != OP_PUSHMARK)
+ break;
+
+ rv2cv = (UNOP*)exlist->op_last;
+
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
+
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+
+ break;
+ }
+
+ case OP_AASSIGN: {
+ S_inplace_aassign(aTHX_ o);
+ break;
+ }
+
+ case OP_OR:
+ case OP_AND:
+ kid = cLOGOPo->op_first;
+ if (kid->op_type == OP_NOT
+ && (kid->op_flags & OPf_KIDS)) {
+ if (o->op_type == OP_AND) {
+ o->op_type = OP_OR;
+ o->op_ppaddr = PL_ppaddr[OP_OR];
+ } else {
+ o->op_type = OP_AND;
+ o->op_ppaddr = PL_ppaddr[OP_AND];
+ }
+ op_null(kid);
+ }
+
+ case OP_DOR:
+ case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
+ for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ S_scalarvoid(aTHX_ kid);
+ break;
+
+ case OP_NULL:
+ if (o->op_flags & OPf_STACKED)
+ break;
+ /* FALL THROUGH */
+ case OP_NEXTSTATE:
+ case OP_DBSTATE:
+ case OP_ENTERTRY:
+ case OP_ENTER:
+ if (!(o->op_flags & OPf_KIDS))
+ break;
+ /* FALL THROUGH */
+ case OP_SCOPE:
+ case OP_LEAVE:
+ case OP_LEAVETRY:
+ case OP_LEAVELOOP:
+ case OP_LINESEQ:
+ case OP_LIST:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
+ for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
+ S_scalarvoid(aTHX_ kid);
+ break;
+ case OP_ENTEREVAL:
+ S_scalarkids(aTHX_ o);
+ break;
+ case OP_SCALAR:
+ return S_scalar(aTHX_ o);
+ }
+
+ if (useless_sv) {
+ /* mortalise it, in case warnings are fatal. */
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %"SVf" in void context",
+ sv_2mortal(useless_sv));
+ }
+ else if (useless) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+ "Useless use of %s in void context",
+ useless);
+ }
+ return o;
+}
+
+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) {
+ S_scalarvoid(aTHX_ kid);
+ }
+ }
+ 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
@@ -3,65 +3,65 @@ package Function::Parameters::Info;
use v5.14.0;
use warnings;
-our $VERSION = '1.0301';
+our $VERSION = '1.0601';
# If Moo isn't loaded yet but Moose is, avoid pulling in Moo and fall back to Moose
my ($Moo, $meta_make_immutable);
BEGIN {
- if ($INC{'Moose.pm'} && !$INC{'Moo.pm'}) {
- $Moo = 'Moose';
- $meta_make_immutable = sub { $_[0]->meta->make_immutable };
- } else {
- require Moo;
- $Moo = 'Moo';
- $meta_make_immutable = sub {};
- }
- $Moo->import;
+ if ($INC{'Moose.pm'} && !$INC{'Moo.pm'}) {
+ $Moo = 'Moose';
+ $meta_make_immutable = sub { $_[0]->meta->make_immutable };
+ } else {
+ require Moo;
+ $Moo = 'Moo';
+ $meta_make_immutable = sub {};
+ }
+ $Moo->import;
}
{
- package Function::Parameters::Param;
+ package Function::Parameters::Param;
- BEGIN { $Moo->import; }
- use overload
- fallback => 1,
- '""' => sub { $_[0]->name },
- ;
+ BEGIN { $Moo->import; }
+ use overload
+ fallback => 1,
+ '""' => sub { $_[0]->name },
+ ;
- has $_ => (is => 'ro') for qw(name type);
+ has $_ => (is => 'ro') for qw(name type);
- __PACKAGE__->$meta_make_immutable;
+ __PACKAGE__->$meta_make_immutable;
}
my @pn_ro = glob '{positional,named}_{required,optional}';
for my $attr (qw[keyword invocant slurpy], map "_$_", @pn_ro) {
- has $attr => (
- is => 'ro',
- );
+ has $attr => (
+ is => 'ro',
+ );
}
for my $gen (join "\n", map "sub $_ { \@{\$_[0]->_$_} }", @pn_ro) {
- eval "$gen\n1" or die $@;
+ eval "$gen\n1" or die $@;
}
sub args_min {
- my $self = shift;
- my $r = 0;
- $r++ if defined $self->invocant;
- $r += $self->positional_required;
- $r += $self->named_required * 2;
- $r
+ my $self = shift;
+ my $r = 0;
+ $r++ if defined $self->invocant;
+ $r += $self->positional_required;
+ $r += $self->named_required * 2;
+ $r
}
sub args_max {
- my $self = shift;
- return 0 + 'Inf' if defined $self->slurpy || $self->named_required || $self->named_optional;
- my $r = 0;
- $r++ if defined $self->invocant;
- $r += $self->positional_required;
- $r += $self->positional_optional;
- $r
+ my $self = shift;
+ return 0 + 'Inf' if defined $self->slurpy || $self->named_required || $self->named_optional;
+ my $r = 0;
+ $r++ if defined $self->invocant;
+ $r += $self->positional_required;
+ $r += $self->positional_optional;
+ $r
}
__PACKAGE__->$meta_make_immutable;
@@ -7,271 +7,274 @@ use Carp qw(confess);
use XSLoader;
BEGIN {
- our $VERSION = '1.0401';
- XSLoader::load;
+ our $VERSION = '1.0601';
+ XSLoader::load;
}
sub _assert_valid_identifier {
- my ($name, $with_dollar) = @_;
- my $bonus = $with_dollar ? '\$' : '';
- $name =~ /^${bonus}[^\W\d]\w*\z/
- or confess qq{"$name" doesn't look like a valid identifier};
+ my ($name, $with_dollar) = @_;
+ my $bonus = $with_dollar ? '\$' : '';
+ $name =~ /^${bonus}[^\W\d]\w*\z/
+ or confess qq{"$name" doesn't look like a valid identifier};
}
sub _assert_valid_attributes {
- my ($attrs) = @_;
- $attrs =~ m{
- ^ \s*+
- : \s*+
- (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+
- (?:
- (?: : \s*+ )?
- (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+
- )*+
- \z
-
- (?(DEFINE)
- (?<ident>
- [^\W\d]
- \w*+
- )
- (?<param>
- \(
- [^()\\]*+
- (?:
- (?:
- \\ .
- |
- (?¶m)
- )
- [^()\\]*+
- )*+
- \)
- )
- )
- }sx or confess qq{"$attrs" doesn't look like valid attributes};
+ my ($attrs) = @_;
+ $attrs =~ m{
+ ^ \s*+
+ : \s*+
+ (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+
+ (?:
+ (?: : \s*+ )?
+ (?&ident) (?! [^\s:(] ) (?¶m)?+ \s*+
+ )*+
+ \z
+
+ (?(DEFINE)
+ (?<ident>
+ [^\W\d]
+ \w*+
+ )
+ (?<param>
+ \(
+ [^()\\]*+
+ (?:
+ (?:
+ \\ .
+ |
+ (?¶m)
+ )
+ [^()\\]*+
+ )*+
+ \)
+ )
+ )
+ }sx or confess qq{"$attrs" doesn't look like valid attributes};
}
sub _reify_type_default {
- require Moose::Util::TypeConstraints;
- Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_[0])
+ require Moose::Util::TypeConstraints;
+ Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_[0])
}
sub _delete_default {
- my ($href, $key, $default) = @_;
- exists $href->{$key} ? delete $href->{$key} : $default
+ my ($href, $key, $default) = @_;
+ exists $href->{$key} ? delete $href->{$key} : $default
}
my @bare_arms = qw(function method);
my %type_map = (
- function => {}, # all default settings
- function_strict => {
- defaults => 'function',
- strict => 1,
- },
- method => {
- defaults => 'function',
- attributes => ':method',
- shift => '$self',
- invocant => 1,
- },
- method_strict => {
- defaults => 'method',
- strict => 1,
- },
- classmethod => {
- defaults => 'method',
- shift => '$class',
- },
- classmethod_strict => {
- defaults => 'classmethod',
- strict => 1,
- },
+ function => {}, # all default settings
+ function_strict => {
+ defaults => 'function',
+ strict => 1,
+ },
+ method => {
+ defaults => 'function',
+ attributes => ':method',
+ shift => '$self',
+ invocant => 1,
+ },
+ method_strict => {
+ defaults => 'method',
+ strict => 1,
+ },
+ classmethod => {
+ defaults => 'method',
+ shift => '$class',
+ },
+ classmethod_strict => {
+ defaults => 'classmethod',
+ strict => 1,
+ },
);
our @type_reifiers = \&_reify_type_default;
sub import {
- my $class = shift;
-
- if (!@_) {
- @_ = {
- fun => 'function',
- method => 'method',
- };
- }
- if (@_ == 1 && $_[0] eq ':strict') {
- @_ = {
- fun => 'function_strict',
- method => 'method_strict',
- };
- }
- if (@_ == 1 && ref($_[0]) eq 'HASH') {
- @_ = map [$_, $_[0]{$_}], keys %{$_[0]};
- }
-
- my %spec;
-
- my $bare = 0;
- for my $proto (@_) {
- my $item = ref $proto
- ? $proto
- : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})]
- ;
- my ($name, $proto_type) = @$item;
- _assert_valid_identifier $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);
- }
-
- my %clean;
-
- $clean{name} = delete $type{name} // 'optional';
- $clean{name} =~ /^(?:optional|required|prohibited)\z/
- or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
-
- $clean{shift} = delete $type{shift} // '';
- _assert_valid_identifier $clean{shift}, 1 if $clean{shift};
-
- $clean{attrs} = join ' ', map delete $type{$_} // (), qw(attributes attrs);
- _assert_valid_attributes $clean{attrs} if $clean{attrs};
-
- $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', 0;
- $clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 1;
- $clean{check_argument_count} = $clean{check_argument_types} = 1 if delete $type{strict};
-
- if (my $rt = delete $type{reify_type}) {
- ref $rt eq 'CODE' or confess qq{"$rt" doesn't look like a type reifier};
-
- my $index;
- for my $i (0 .. $#type_reifiers) {
- if ($type_reifiers[$i] == $rt) {
- $index = $i;
- last;
- }
- }
- unless (defined $index) {
- $index = @type_reifiers;
- push @type_reifiers, $rt;
- }
-
- $clean{reify_type} = $index;
- }
-
- %type and confess "Invalid keyword property: @{[keys %type]}";
-
- $spec{$name} = \%clean;
- }
-
- 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};
- $^H{HINTK_FLAGS_ . $kw} = $flags;
- $^H{HINTK_SHIFT_ . $kw} = $type->{shift};
- $^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
- $^H{HINTK_REIFY_ . $kw} = $type->{reify_type} // 0;
- $^H{+HINTK_KEYWORDS} .= "$kw ";
- }
+ my $class = shift;
+
+ if (!@_) {
+ @_ = {
+ fun => 'function',
+ method => 'method',
+ };
+ }
+ if (@_ == 1 && $_[0] eq ':strict') {
+ @_ = {
+ fun => 'function_strict',
+ method => 'method_strict',
+ };
+ }
+ if (@_ == 1 && ref($_[0]) eq 'HASH') {
+ @_ = map [$_, $_[0]{$_}], keys %{$_[0]};
+ }
+
+ my %spec;
+
+ my $bare = 0;
+ for my $proto (@_) {
+ my $item = ref $proto
+ ? $proto
+ : [$proto, $bare_arms[$bare++] || confess(qq{Don't know what to do with "$proto"})]
+ ;
+ my ($name, $proto_type) = @$item;
+ _assert_valid_identifier $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);
+ }
+
+ my %clean;
+
+ $clean{name} = delete $type{name} // 'optional';
+ $clean{name} =~ /^(?:optional|required|prohibited)\z/
+ or confess qq["$clean{name}" doesn't look like a valid name attribute (one of optional, required, prohibited)];
+
+ $clean{shift} = delete $type{shift} // '';
+ if ($clean{shift}) {
+ _assert_valid_identifier $clean{shift}, 1;
+ $clean{shift} eq '$_' and confess q[Using "$_" as a parameter is not supported];
+ }
+
+ $clean{attrs} = join ' ', map delete $type{$_} // (), qw(attributes attrs);
+ _assert_valid_attributes $clean{attrs} if $clean{attrs};
+
+ $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', 0;
+ $clean{check_argument_types} = _delete_default \%type, 'check_argument_types', 1;
+ $clean{check_argument_count} = $clean{check_argument_types} = 1 if delete $type{strict};
+
+ if (my $rt = delete $type{reify_type}) {
+ ref $rt eq 'CODE' or confess qq{"$rt" doesn't look like a type reifier};
+
+ my $index;
+ for my $i (0 .. $#type_reifiers) {
+ if ($type_reifiers[$i] == $rt) {
+ $index = $i;
+ last;
+ }
+ }
+ unless (defined $index) {
+ $index = @type_reifiers;
+ push @type_reifiers, $rt;
+ }
+
+ $clean{reify_type} = $index;
+ }
+
+ %type and confess "Invalid keyword property: @{[keys %type]}";
+
+ $spec{$name} = \%clean;
+ }
+
+ 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};
+ $^H{HINTK_FLAGS_ . $kw} = $flags;
+ $^H{HINTK_SHIFT_ . $kw} = $type->{shift};
+ $^H{HINTK_ATTRS_ . $kw} = $type->{attrs};
+ $^H{HINTK_REIFY_ . $kw} = $type->{reify_type} // 0;
+ $^H{+HINTK_KEYWORDS} .= "$kw ";
+ }
}
sub unimport {
- my $class = shift;
+ my $class = shift;
- if (!@_) {
- delete $^H{+HINTK_KEYWORDS};
- return;
- }
+ if (!@_) {
+ delete $^H{+HINTK_KEYWORDS};
+ return;
+ }
- for my $kw (@_) {
- $^H{+HINTK_KEYWORDS} =~ s/(?<![^ ])\Q$kw\E //g;
- }
+ for my $kw (@_) {
+ $^H{+HINTK_KEYWORDS} =~ s/(?<![^ ])\Q$kw\E //g;
+ }
}
our %metadata;
sub _register_info {
- my (
- $key,
- $declarator,
- $invocant,
- $invocant_type,
- $positional_required,
- $positional_optional,
- $named_required,
- $named_optional,
- $slurpy,
- $slurpy_type,
- ) = @_;
-
- my $info = {
- declarator => $declarator,
- invocant => defined $invocant ? [$invocant, $invocant_type] : undef,
- slurpy => defined $slurpy ? [$slurpy , $slurpy_type ] : undef,
- positional_required => $positional_required,
- positional_optional => $positional_optional,
- named_required => $named_required,
- named_optional => $named_optional,
- };
-
- $metadata{$key} = $info;
+ my (
+ $key,
+ $declarator,
+ $invocant,
+ $invocant_type,
+ $positional_required,
+ $positional_optional,
+ $named_required,
+ $named_optional,
+ $slurpy,
+ $slurpy_type,
+ ) = @_;
+
+ my $info = {
+ declarator => $declarator,
+ invocant => defined $invocant ? [$invocant, $invocant_type] : undef,
+ slurpy => defined $slurpy ? [$slurpy , $slurpy_type ] : undef,
+ positional_required => $positional_required,
+ positional_optional => $positional_optional,
+ named_required => $named_required,
+ named_optional => $named_optional,
+ };
+
+ $metadata{$key} = $info;
}
sub _mkparam1 {
- my ($pair) = @_;
- my ($v, $t) = @{$pair || []} or return undef;
- Function::Parameters::Param->new(
- name => $v,
- type => $t,
- )
+ 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
+ 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},
- invocant => _mkparam1($info->{invocant}),
- slurpy => _mkparam1($info->{slurpy}),
- (map +("_$_" => _mkparams @{$info->{$_}}), glob '{positional,named}_{required,optional}')
- )
+ 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},
+ invocant => _mkparam1($info->{invocant}),
+ slurpy => _mkparam1($info->{slurpy}),
+ (map +("_$_" => _mkparams @{$info->{$_}}), glob '{positional,named}_{required,optional}')
+ )
}
'ok'
@@ -417,11 +420,23 @@ L<parameter list|/"Parameter list">. To specify a prototype, put it as the
first attribute (e.g. C<fun foo :(&$$)>). This is syntactically unambiguous
because normal L<attributes|/Attributes> need a name after the colon.
+You can also use an attribute named C<prototype> (e.g.
+C<fun foo :prototype(&$$)>). In that case it does not have to be the first
+attribute. This syntax is also compatible with C<sub> in perl 5.20 and newer.
+
=head3 Parameter list
The parameter list is a list of variables enclosed in parentheses, except it's
-actually a bit more complicated than that. A parameter list can include the
-following 6 parts, all of which are optional:
+actually a bit more complicated than that.
+
+Instead of a full variable name (such as C<$foo> or C<@bar>) you can write just
+the sigil (C<$>, C<@>, or C<%>). This has the effect of creating an unnamed
+parameter, which is useful in functions that are called with a certain number
+of arguments but want to ignore one or more of them. This trick works for
+invocants, slurpies, and positional parameters (see below). You can't have
+unnamed named parameters for what I hope are obvious reasons.
+
+A parameter list can include the following 6 parts, all of which are optional:
=over
@@ -455,9 +470,9 @@ passed in:
=item 3. Optional positional parameters
Parameters can be marked as optional by putting an equals sign (C<=>) and an
-expression (the "default argument") after them. If no corresponding argument is
-passed in by the caller, the default argument will be used to initialize the
-parameter:
+(optional) expression (the "default argument") after them. If no corresponding
+argument is passed in by the caller, the default argument will be used to
+initialize the parameter:
fun scale($base, $factor = 2) {
return $base * $factor;
@@ -466,6 +481,10 @@ parameter:
say scale(3, 5); # "15"
say scale(3); # "6"
+Using just a C<=> with no expression after is equivalent to specifying
+C<= undef>, i.e. the corresponding parameter is optional and has a default
+value of C<undef>.
+
The default argument is I<not> cached. Every time a function is called with
some optional arguments missing, the corresponding default arguments are
evaluated from left to right. This makes no difference for a value like C<2>
@@ -525,7 +544,8 @@ parameters come first:
=item 5. Optional named parameters
As with positional parameters, you can make named parameters optional by
-specifying a default argument after an equals sign (C<=>):
+specifying a default argument (or nothing, which is equivalent to C<undef>)
+after an equals sign (C<=>):
fun rectangle(:$width, :$height, :$color = "chartreuse") {
...
@@ -883,7 +903,7 @@ Lukas Mai, C<< <l.mai at web.de> >>
=head1 COPYRIGHT & LICENSE
-Copyright 2010-2013 Lukas Mai.
+Copyright 2010-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
@@ -1,1109 +0,0 @@
-/*
- * This code was copied from perl/pad.c and perl/op.c and subsequently
- * butchered by Lukas Mai (2012).
- */
-/* vi: set ft=c inde=: */
-
-#define COP_SEQ_RANGE_LOW_set(SV, VAL) \
- STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END
-#define COP_SEQ_RANGE_HIGH_set(SV, VAL) \
- STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END
-
-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;
-}
-
-static int S_block_start(pTHX_ int full) {
- dVAR;
- const int retval = PL_savestack_ix;
-
- S_pad_block_start(aTHX_ 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;
-}
-
-/* Check for in place reverse and sort assignments like "@a = reverse @a"
- and modify the optree to make them work inplace */
-
-static void S_inplace_aassign(pTHX_ OP *o) {
- OP *modop, *modop_pushmark;
- OP *oright;
- OP *oleft, *oleft_pushmark;
-
- assert((o->op_flags & OPf_WANT) == OPf_WANT_VOID);
-
- assert(cUNOPo->op_first->op_type == OP_NULL);
- modop_pushmark = cUNOPx(cUNOPo->op_first)->op_first;
- assert(modop_pushmark->op_type == OP_PUSHMARK);
- modop = modop_pushmark->op_sibling;
-
- if (modop->op_type != OP_SORT && modop->op_type != OP_REVERSE)
- return;
-
- /* no other operation except sort/reverse */
- if (modop->op_sibling)
- return;
-
- assert(cUNOPx(modop)->op_first->op_type == OP_PUSHMARK);
- if (!(oright = cUNOPx(modop)->op_first->op_sibling)) return;
-
- if (modop->op_flags & OPf_STACKED) {
- /* skip sort subroutine/block */
- assert(oright->op_type == OP_NULL);
- oright = oright->op_sibling;
- }
-
- assert(cUNOPo->op_first->op_sibling->op_type == OP_NULL);
- oleft_pushmark = cUNOPx(cUNOPo->op_first->op_sibling)->op_first;
- assert(oleft_pushmark->op_type == OP_PUSHMARK);
- oleft = oleft_pushmark->op_sibling;
-
- /* Check the lhs is an array */
- if (!oleft ||
- (oleft->op_type != OP_RV2AV && oleft->op_type != OP_PADAV)
- || oleft->op_sibling
- || (oleft->op_private & OPpLVAL_INTRO)
- )
- return;
-
- /* Only one thing on the rhs */
- if (oright->op_sibling)
- return;
-
- /* check the array is the same on both sides */
- if (oleft->op_type == OP_RV2AV) {
- if (oright->op_type != OP_RV2AV
- || !cUNOPx(oright)->op_first
- || cUNOPx(oright)->op_first->op_type != OP_GV
- || cUNOPx(oleft )->op_first->op_type != OP_GV
- || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
- cGVOPx_gv(cUNOPx(oright)->op_first)
- )
- return;
- }
- else if (oright->op_type != OP_PADAV
- || oright->op_targ != oleft->op_targ
- )
- return;
-
- /* This actually is an inplace assignment */
-
- modop->op_private |= OPpSORT_INPLACE;
-
- /* transfer MODishness etc from LHS arg to RHS arg */
- oright->op_flags = oleft->op_flags;
-
- /* remove the aassign op and the lhs */
- op_null(o);
- op_null(oleft_pushmark);
- if (oleft->op_type == OP_RV2AV && cUNOPx(oleft)->op_first)
- op_null(cUNOPx(oleft)->op_first);
- op_null(oleft);
-}
-
-static OP *S_scalarvoid(pTHX_ OP *);
-
-static OP *S_scalar(pTHX_ OP *o) {
- dVAR;
- OP *kid;
-
- /* assumes no premature commitment */
- if (!o || (PL_parser && PL_parser->error_count)
- || (o->op_flags & OPf_WANT)
- || o->op_type == OP_RETURN)
- {
- return o;
- }
-
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
-
- switch (o->op_type) {
- case OP_REPEAT:
- S_scalar(aTHX_ cBINOPo->op_first);
- break;
- case OP_OR:
- case OP_AND:
- case OP_COND_EXPR:
- for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
- S_scalar(aTHX_ kid);
- break;
- /* FALL THROUGH */
- case OP_SPLIT:
- case OP_MATCH:
- case OP_QR:
- case OP_SUBST:
- case OP_NULL:
- default:
- if (o->op_flags & OPf_KIDS) {
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling)
- S_scalar(aTHX_ kid);
- }
- break;
- case OP_LEAVE:
- case OP_LEAVETRY:
- kid = cLISTOPo->op_first;
- S_scalar(aTHX_ kid);
- kid = kid->op_sibling;
-do_kids:
- while (kid) {
- OP *sib = kid->op_sibling;
- if (sib && kid->op_type != OP_LEAVEWHEN)
- S_scalarvoid(aTHX_ kid);
- else
- S_scalar(aTHX_ kid);
- kid = sib;
- }
- PL_curcop = &PL_compiling;
- break;
- case OP_SCOPE:
- case OP_LINESEQ:
- case OP_LIST:
- kid = cLISTOPo->op_first;
- goto do_kids;
- case OP_SORT:
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
- break;
- }
- return o;
-}
-
-static OP *S_scalarkids(pTHX_ OP *o) {
- if (o && o->op_flags & OPf_KIDS) {
- OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- S_scalar(aTHX_ kid);
- }
- return o;
-}
-
-static OP *S_scalarvoid(pTHX_ OP *o) {
- dVAR;
- OP *kid;
- const char *useless = NULL;
- U32 useless_is_utf8 = 0;
- SV *sv;
- U8 want;
-
- PERL_ARGS_ASSERT_SCALARVOID;
-
- if (
- o->op_type == OP_NEXTSTATE ||
- o->op_type == OP_DBSTATE || (
- o->op_type == OP_NULL && (
- o->op_targ == OP_NEXTSTATE ||
- o->op_targ == OP_DBSTATE
- )
- )
- ) {
- PL_curcop = (COP*)o; /* for warning below */
- }
-
- /* assumes no premature commitment */
- want = o->op_flags & OPf_WANT;
- if (
- (want && want != OPf_WANT_SCALAR) ||
- (PL_parser && PL_parser->error_count) ||
- o->op_type == OP_RETURN ||
- o->op_type == OP_REQUIRE ||
- o->op_type == OP_LEAVEWHEN
- ) {
- return o;
- }
-
- if (
- (o->op_private & OPpTARGET_MY) &&
- (PL_opargs[o->op_type] & OA_TARGLEX)
- /* OPp share the meaning */
- ) {
- return S_scalar(aTHX_ o); /* As if inside SASSIGN */
- }
-
- o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
-
- switch (o->op_type) {
- default:
- if (!(PL_opargs[o->op_type] & OA_FOLDCONST))
- break;
- /* FALL THROUGH */
- case OP_REPEAT:
- if (o->op_flags & OPf_STACKED)
- break;
- goto func_ops;
- case OP_SUBSTR:
- if (o->op_private == 4)
- break;
- /* FALL THROUGH */
- case OP_GVSV:
- case OP_WANTARRAY:
- case OP_GV:
- case OP_SMARTMATCH:
- case OP_PADSV:
- case OP_PADAV:
- case OP_PADHV:
- case OP_PADANY:
- case OP_AV2ARYLEN:
- case OP_REF:
- case OP_REFGEN:
- case OP_SREFGEN:
- case OP_DEFINED:
- case OP_HEX:
- case OP_OCT:
- case OP_LENGTH:
- case OP_VEC:
- case OP_INDEX:
- case OP_RINDEX:
- case OP_SPRINTF:
- case OP_AELEM:
- case OP_AELEMFAST:
- IF_HAVE_PERL_5_16(case OP_AELEMFAST_LEX:, )
- case OP_ASLICE:
- case OP_HELEM:
- case OP_HSLICE:
- case OP_UNPACK:
- case OP_PACK:
- case OP_JOIN:
- case OP_LSLICE:
- case OP_ANONLIST:
- case OP_ANONHASH:
- case OP_SORT:
- case OP_REVERSE:
- case OP_RANGE:
- case OP_FLIP:
- case OP_FLOP:
- case OP_CALLER:
- case OP_FILENO:
- case OP_EOF:
- case OP_TELL:
- case OP_GETSOCKNAME:
- case OP_GETPEERNAME:
- case OP_READLINK:
- case OP_TELLDIR:
- case OP_GETPPID:
- case OP_GETPGRP:
- case OP_GETPRIORITY:
- case OP_TIME:
- case OP_TMS:
- case OP_LOCALTIME:
- case OP_GMTIME:
- case OP_GHBYNAME:
- case OP_GHBYADDR:
- case OP_GHOSTENT:
- case OP_GNBYNAME:
- case OP_GNBYADDR:
- case OP_GNETENT:
- case OP_GPBYNAME:
- case OP_GPBYNUMBER:
- case OP_GPROTOENT:
- case OP_GSBYNAME:
- case OP_GSBYPORT:
- case OP_GSERVENT:
- case OP_GPWNAM:
- case OP_GPWUID:
- case OP_GGRNAM:
- case OP_GGRGID:
- case OP_GETLOGIN:
- case OP_PROTOTYPE:
- IF_HAVE_PERL_5_16(case OP_RUNCV:, )
-func_ops:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
- /* Otherwise it's "Useless use of grep iterator" */
- useless = OP_DESC(o);
- break;
-
- case OP_SPLIT:
- kid = cLISTOPo->op_first;
- if (kid && kid->op_type == OP_PUSHRE
-#ifdef USE_ITHREADS
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
-#else
- && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
-#endif
- useless = OP_DESC(o);
- break;
-
- case OP_NOT:
- kid = cUNOPo->op_first;
- if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
- kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
- goto func_ops;
- }
- useless = "negative pattern binding (!~)";
- break;
-
- case OP_SUBST:
- if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
- useless = "non-destructive substitution (s///r)";
- break;
-
- case OP_TRANSR:
- useless = "non-destructive transliteration (tr///r)";
- break;
-
- case OP_RV2GV:
- case OP_RV2SV:
- case OP_RV2AV:
- case OP_RV2HV:
- if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) &&
- (!o->op_sibling || o->op_sibling->op_type != OP_READLINE))
- useless = "a variable";
- break;
-
- case OP_CONST:
- sv = cSVOPo_sv;
- if (cSVOPo->op_private & OPpCONST_STRICT) {
- //no_bareword_allowed(o);
- *((int *)NULL) += 1;
- } else {
- if (ckWARN(WARN_VOID)) {
- /* don't warn on optimised away booleans, eg
- * use constant Foo, 5; Foo || print; */
- if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
- useless = NULL;
- /* the constants 0 and 1 are permitted as they are
- conventionally used as dummies in constructs like
- 1 while some_condition_with_side_effects; */
- else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
- useless = NULL;
- else if (SvPOK(sv)) {
- /* perl4's way of mixing documentation and code
- (before the invention of POD) was based on a
- trick to mix nroff and perl code. The trick was
- built upon these three nroff macros being used in
- void context. The pink camel has the details in
- the script wrapman near page 319. */
- const char * const maybe_macro = SvPVX_const(sv);
- if (strnEQ(maybe_macro, "di", 2) ||
- strnEQ(maybe_macro, "ds", 2) ||
- strnEQ(maybe_macro, "ig", 2))
- useless = NULL;
- else {
- SV * const dsv = newSVpvs("");
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%s)",
- pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
- PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
- SvREFCNT_dec(dsv);
- useless = SvPV_nolen(msv);
- useless_is_utf8 = SvUTF8(msv);
- }
- }
- else if (SvOK(sv)) {
- SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
- "a constant (%"SVf")", sv));
- useless = SvPV_nolen(msv);
- }
- else
- useless = "a constant (undef)";
- }
- }
- op_null(o); /* don't execute or even remember it */
- break;
-
- case OP_POSTINC:
- o->op_type = OP_PREINC; /* pre-increment is faster */
- o->op_ppaddr = PL_ppaddr[OP_PREINC];
- break;
-
- case OP_POSTDEC:
- o->op_type = OP_PREDEC; /* pre-decrement is faster */
- o->op_ppaddr = PL_ppaddr[OP_PREDEC];
- break;
-
- case OP_I_POSTINC:
- o->op_type = OP_I_PREINC; /* pre-increment is faster */
- o->op_ppaddr = PL_ppaddr[OP_I_PREINC];
- break;
-
- case OP_I_POSTDEC:
- o->op_type = OP_I_PREDEC; /* pre-decrement is faster */
- o->op_ppaddr = PL_ppaddr[OP_I_PREDEC];
- break;
-
- case OP_SASSIGN: {
- OP *rv2gv;
- UNOP *refgen, *rv2cv;
- LISTOP *exlist;
-
- if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
- break;
-
- rv2gv = ((BINOP *)o)->op_last;
- if (!rv2gv || rv2gv->op_type != OP_RV2GV)
- break;
-
- refgen = (UNOP *)((BINOP *)o)->op_first;
-
- if (!refgen || refgen->op_type != OP_REFGEN)
- break;
-
- exlist = (LISTOP *)refgen->op_first;
- if (!exlist || exlist->op_type != OP_NULL
- || exlist->op_targ != OP_LIST)
- break;
-
- if (exlist->op_first->op_type != OP_PUSHMARK)
- break;
-
- rv2cv = (UNOP*)exlist->op_last;
-
- if (rv2cv->op_type != OP_RV2CV)
- break;
-
- assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
- assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
- assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
-
- o->op_private |= OPpASSIGN_CV_TO_GV;
- rv2gv->op_private |= OPpDONT_INIT_GV;
- rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
-
- break;
- }
-
- case OP_AASSIGN: {
- S_inplace_aassign(aTHX_ o);
- break;
- }
-
- case OP_OR:
- case OP_AND:
- kid = cLOGOPo->op_first;
- if (kid->op_type == OP_NOT
- && (kid->op_flags & OPf_KIDS)
- && !PL_madskills) {
- if (o->op_type == OP_AND) {
- o->op_type = OP_OR;
- o->op_ppaddr = PL_ppaddr[OP_OR];
- } else {
- o->op_type = OP_AND;
- o->op_ppaddr = PL_ppaddr[OP_AND];
- }
- op_null(kid);
- }
-
- case OP_DOR:
- case OP_COND_EXPR:
- case OP_ENTERGIVEN:
- case OP_ENTERWHEN:
- for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
- S_scalarvoid(aTHX_ kid);
- break;
-
- case OP_NULL:
- if (o->op_flags & OPf_STACKED)
- break;
- /* FALL THROUGH */
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- case OP_ENTERTRY:
- case OP_ENTER:
- if (!(o->op_flags & OPf_KIDS))
- break;
- /* FALL THROUGH */
- case OP_SCOPE:
- case OP_LEAVE:
- case OP_LEAVETRY:
- case OP_LEAVELOOP:
- case OP_LINESEQ:
- case OP_LIST:
- case OP_LEAVEGIVEN:
- case OP_LEAVEWHEN:
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- S_scalarvoid(aTHX_ kid);
- break;
- case OP_ENTEREVAL:
- S_scalarkids(aTHX_ o);
- break;
- case OP_SCALAR:
- return S_scalar(aTHX_ o);
- }
- if (useless)
- Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
- newSVpvn_flags(useless, strlen(useless),
- SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
- return o;
-}
-
-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) {
- S_scalarvoid(aTHX_ kid);
- }
- }
- 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;
-}
-
-static void S_pad_leavemy(pTHX) {
- dVAR;
- I32 off;
- 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 && 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--) {
- const SV * const sv = svp[off];
- if (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))
- );
- }
- }
- 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));
-}
-
-static OP *S_block_end(pTHX_ I32 floor, OP *seq) {
- dVAR;
- const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
- OP *retval = S_scalarseq(aTHX_ seq);
-
- CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
-
- LEAVE_SCOPE(floor);
- CopHINTS_set(&PL_compiling, PL_hints);
- if (needblockscope)
- PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
- S_pad_leavemy(aTHX);
-
- CALL_BLOCK_HOOKS(bhk_post_end, &retval);
-
- return retval;
-}
-
-
-#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
-
-
-#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
-
-#ifndef pad_add_name_sv
-
-#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);
-
- 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
-
-#ifndef pad_findmy_sv
-
-#define pad_findmy_sv(SV, FLAGS) \
- S_pad_findmy(aTHX_ SvPV_nolen(SV), FLAGS)
-
-#define PARENT_PAD_INDEX_set(SV, VAL) \
- STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xlow = (VAL); } STMT_END
-#define PARENT_FAKELEX_FLAGS_set(SV, VAL) \
- STMT_START { ((XPVNV*)SvANY(SV))->xnv_u.xpad_cop_seq.xhigh = (VAL); } STMT_END
-
-static PADOFFSET S_pad_findlex(pTHX_ const char *name, const CV *cv, U32 seq, int warn, SV **out_capture, SV **out_name_sv, int *out_flags) {
-#define CvCOMPILED(CV) CvROOT(CV)
-#define CvLATE(CV) (CvANON(CV) || SvTYPE(CV) == SVt_PVFM)
- dVAR;
- I32 offset, new_offset;
- SV *new_capture;
- SV **new_capturep;
- const AV *const padlist = CvPADLIST(cv);
-
- *out_flags = 0;
-
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" searching \"%s\" seq=%d%s\n",
- PTR2UV(cv), name, (int)seq, out_capture ? " capturing" : "" ));
-
- /* first, search this pad */
-
- if (padlist) { /* not an undef CV */
- I32 fake_offset = 0;
- const AV * const nameav = MUTABLE_AV(AvARRAY(padlist)[0]);
- SV * const * const name_svp = AvARRAY(nameav);
-
- for (offset = AvFILLp(nameav); offset > 0; offset--) {
- const SV * const namesv = name_svp[offset];
- if (namesv && namesv != &PL_sv_undef
- && strEQ(SvPVX_const(namesv), name))
- {
- if (SvFAKE(namesv)) {
- fake_offset = offset; /* in case we don't find a real one */
- continue;
- }
- /* is seq within the range _LOW to _HIGH ?
- * This is complicated by the fact that PL_cop_seqmax
- * may have wrapped around at some point */
- if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
- continue; /* not yet introduced */
-
- if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
- /* in compiling scope */
- if (
- (seq > COP_SEQ_RANGE_LOW(namesv))
- ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
- : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
- )
- break;
- }
- else if (
- (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
- ?
- ( seq > COP_SEQ_RANGE_LOW(namesv)
- || seq <= COP_SEQ_RANGE_HIGH(namesv))
-
- : ( seq > COP_SEQ_RANGE_LOW(namesv)
- && seq <= COP_SEQ_RANGE_HIGH(namesv))
- )
- break;
- }
- }
-
- if (offset > 0 || fake_offset > 0 ) { /* a match! */
- if (offset > 0) { /* not fake */
- fake_offset = 0;
- *out_name_sv = name_svp[offset]; /* return the namesv */
-
- /* set PAD_FAKELEX_MULTI if this lex can have multiple
- * instances. For now, we just test !CvUNIQUE(cv), but
- * ideally, we should detect my's declared within loops
- * etc - this would allow a wider range of 'not stayed
- * shared' warnings. We also treated already-compiled
- * lexes as not multi as viewed from evals. */
-
- *out_flags = CvANON(cv) ?
- PAD_FAKELEX_ANON :
- (!CvUNIQUE(cv) && ! CvCOMPILED(cv))
- ? PAD_FAKELEX_MULTI : 0;
-
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%lu,%lu)\n",
- PTR2UV(cv), (long)offset,
- (unsigned long)COP_SEQ_RANGE_LOW(*out_name_sv),
- (unsigned long)COP_SEQ_RANGE_HIGH(*out_name_sv)));
- }
- else { /* fake match */
- offset = fake_offset;
- *out_name_sv = name_svp[offset]; /* return the namesv */
- *out_flags = PARENT_FAKELEX_FLAGS(*out_name_sv);
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
- PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
- (unsigned long) PARENT_PAD_INDEX(*out_name_sv)
- ));
- }
-
- /* return the lex? */
-
- if (out_capture) {
-
- /* our ? */
- if (SvPAD_OUR(*out_name_sv)) {
- *out_capture = NULL;
- return offset;
- }
-
- /* trying to capture from an anon prototype? */
- if (CvCOMPILED(cv)
- ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv)
- : *out_flags & PAD_FAKELEX_ANON)
- {
- if (warn)
- Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", name);
- *out_capture = NULL;
- }
-
- /* real value */
- else {
- int newwarn = warn;
- if (!CvCOMPILED(cv) && (*out_flags & PAD_FAKELEX_MULTI)
- && !SvPAD_STATE(name_svp[offset])
- && warn && ckWARN(WARN_CLOSURE)) {
- newwarn = 0;
- Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" will not stay shared", name);
- }
-
- if (fake_offset && CvANON(cv)
- && CvCLONE(cv) &&!CvCLONED(cv))
- {
- SV *n;
- /* not yet caught - look further up */
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" chasing lex in outer pad\n",
- PTR2UV(cv)));
- n = *out_name_sv;
- (void)S_pad_findlex(aTHX_ name, CvOUTSIDE(cv),
- CvOUTSIDE_SEQ(cv),
- newwarn, out_capture, out_name_sv, out_flags);
- *out_name_sv = n;
- return offset;
- }
-
- *out_capture = AvARRAY(MUTABLE_AV(AvARRAY(padlist)[
- CvDEPTH(cv) ? CvDEPTH(cv) : 1]))[offset];
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
- PTR2UV(cv), PTR2UV(*out_capture)));
-
- if (SvPADSTALE(*out_capture)
- && !SvPAD_STATE(name_svp[offset]))
- {
- Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE),
- "Variable \"%s\" is not available", name);
- *out_capture = NULL;
- }
- }
- if (!*out_capture) {
- if (*name == '@')
- *out_capture = sv_2mortal(MUTABLE_SV(newAV()));
- else if (*name == '%')
- *out_capture = sv_2mortal(MUTABLE_SV(newHV()));
- else
- *out_capture = sv_newmortal();
- }
- }
-
- return offset;
- }
- }
-
- /* it's not in this pad - try above */
-
- if (!CvOUTSIDE(cv))
- return NOT_IN_PAD;
-
- /* out_capture non-null means caller wants us to capture lex; in
- * addition we capture ourselves unless it's an ANON/format */
- new_capturep = out_capture ? out_capture :
- CvLATE(cv) ? NULL : &new_capture;
-
- offset = S_pad_findlex(aTHX_ name, CvOUTSIDE(cv), CvOUTSIDE_SEQ(cv), 1,
- new_capturep, out_name_sv, out_flags);
- if ((PADOFFSET)offset == NOT_IN_PAD)
- return NOT_IN_PAD;
-
- /* found in an outer CV. Add appropriate fake entry to this pad */
-
- /* don't add new fake entries (via eval) to CVs that we have already
- * finished compiling, or to undef CVs */
- if (CvCOMPILED(cv) || !padlist)
- return 0; /* this dummy (and invalid) value isnt used by the caller */
-
- {
- /* This relies on sv_setsv_flags() upgrading the destination to the same
- type as the source, independent of the flags set, and on it being
- "good" and only copying flag bits and pointers that it understands.
- */
- SV *new_namesv = newSVsv(*out_name_sv);
- AV * const ocomppad_name = PL_comppad_name;
- PAD * const ocomppad = PL_comppad;
- PL_comppad_name = MUTABLE_AV(AvARRAY(padlist)[0]);
- PL_comppad = MUTABLE_AV(AvARRAY(padlist)[1]);
- PL_curpad = AvARRAY(PL_comppad);
-
- new_offset
- = pad_add_name_sv(new_namesv,
- 0,
- SvPAD_TYPED(*out_name_sv)
- ? SvSTASH(*out_name_sv) : NULL,
- SvOURSTASH(*out_name_sv)
- );
-
- SvFAKE_on(new_namesv);
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad addname: %ld \"%.*s\" FAKE\n",
- (long)new_offset,
- (int) SvCUR(new_namesv), SvPVX(new_namesv)));
- PARENT_FAKELEX_FLAGS_set(new_namesv, *out_flags);
-
- PARENT_PAD_INDEX_set(new_namesv, 0);
- if (SvPAD_OUR(new_namesv)) {
- NOOP; /* do nothing */
- }
- else if (CvLATE(cv)) {
- /* delayed creation - just note the offset within parent pad */
- PARENT_PAD_INDEX_set(new_namesv, offset);
- CvCLONE_on(cv);
- }
- else {
- /* immediate creation - capture outer value right now */
- av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
- DEBUG_Xv(PerlIO_printf(Perl_debug_log,
- "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
- PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
- }
- *out_name_sv = new_namesv;
- *out_flags = PARENT_FAKELEX_FLAGS(new_namesv);
-
- PL_comppad_name = ocomppad_name;
- PL_comppad = ocomppad;
- PL_curpad = ocomppad ? AvARRAY(ocomppad) : NULL;
- }
- return new_offset;
-#undef CvLATE
-#undef CvCOMPILED
-}
-
-static PADOFFSET S_pad_findmy(pTHX_ const char *name, U32 flags) {
- dVAR;
- SV *out_sv;
- int out_flags;
- I32 offset;
- const AV *nameav;
- SV **name_svp;
-
- offset = S_pad_findlex(aTHX_ name, PL_compcv, PL_cop_seqmax, 1,
- NULL, &out_sv, &out_flags);
- if ((PADOFFSET)offset != NOT_IN_PAD)
- return offset;
-
- /* look for an our that's being introduced; this allows
- * our $foo = 0 unless defined $foo;
- * to not give a warning. (Yes, this is a hack) */
-
- nameav = MUTABLE_AV(AvARRAY(CvPADLIST(PL_compcv))[0]);
- name_svp = AvARRAY(nameav);
- for (offset = AvFILLp(nameav); offset > 0; offset--) {
- const SV * const namesv = name_svp[offset];
- if (namesv && namesv != &PL_sv_undef
- && !SvFAKE(namesv)
- && (SvPAD_OUR(namesv))
- && strEQ(SvPVX_const(namesv), name)
- && COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO
- )
- return offset;
- }
- return NOT_IN_PAD;
-}
-
-#endif
-
-#ifndef pad_findmy_pvs
- #define pad_findmy_pvs(S, FLAGS) S_pad_findmy(aTHX_ "" S "", FLAGS)
-#endif
-
-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;
- }
-}
-
-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 && 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;
-}
@@ -30,7 +30,7 @@ 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, $z = 'D2') { [$x, $y, $z] }
+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] }
@@ -55,66 +55,66 @@ 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 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/Not enough arguments.*foo_1/, fun { foo_1 };
+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 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/Not enough arguments.*foo_2/, fun { foo_2 };
-error_like qr/Not enough arguments.*foo_2/, fun { foo_2 'a' };
+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 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/Not enough arguments.*foo_3/, fun { foo_3 };
-error_like qr/Not enough arguments.*foo_3/, fun { foo_3 'a' };
-error_like qr/Not enough arguments.*foo_3/, fun { foo_3 'a', 'b' };
+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' };
+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' };
+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' };
+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 many arguments.*foo_0_3/, fun { foo_0_3 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_1_2/, fun { foo_1_2 };
+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 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/Not enough arguments.*foo_1_3/, fun { foo_1_3 };
+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 many arguments.*foo_1_3/, fun { foo_1_3 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_2_3/, fun { foo_2_3 };
-error_like qr/Not enough arguments.*foo_2_3/, fun { foo_2_3 'a' };
+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 many arguments.*foo_2_3/, fun { foo_2_3 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_1_/, fun { foo_1_ };
+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'];
@@ -34,96 +34,96 @@ 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, $z = 'D2') { [$x, $y, $z] }
+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/Not enough arguments.*foo_any/, sub { foo_any };
+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/Not enough arguments.*foo_any_a/, sub { foo_any_a };
+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/Not enough arguments.*foo_any_b/, sub { foo_any_b };
+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/Not enough arguments.*foo_0/, sub { foo_0 };
+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 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/Not enough arguments.*foo_1/, sub { foo_1 };
-error_like qr/Not enough arguments.*foo_1/, sub { foo_1 'a' };
+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 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/Not enough arguments.*foo_2/, sub { foo_2 };
-error_like qr/Not enough arguments.*foo_2/, sub { foo_2 'a' };
-error_like qr/Not enough arguments.*foo_2/, sub { foo_2 'a', 'b' };
+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 many arguments.*foo_2/, sub { foo_2 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_3/, sub { foo_3 };
-error_like qr/Not enough arguments.*foo_3/, sub { foo_3 'a' };
-error_like qr/Not enough arguments.*foo_3/, sub { foo_3 'a', 'b' };
-error_like qr/Not enough arguments.*foo_3/, sub { foo_3 'a', 'b', 'c' };
+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 many arguments.*foo_3/, sub { foo_3 'a', 'b', 'c', 'd', 'e' };
-error_like qr/Not enough arguments.*foo_0_1/, sub { foo_0_1 };
+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 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/Not enough arguments.*foo_0_2/, sub { foo_0_2 };
+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 many arguments.*foo_0_2/, sub { foo_0_2 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_0_3/, sub { foo_0_3 };
+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 many arguments.*foo_0_3/, sub { foo_0_3 'a', 'b', 'c', 'd', 'e' };
-error_like qr/Not enough arguments.*foo_1_2/, sub { foo_1_2 };
-error_like qr/Not enough arguments.*foo_1_2/, sub { foo_1_2 'a' };
+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 many arguments.*foo_1_2/, sub { foo_1_2 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_1_3/, sub { foo_1_3 };
-error_like qr/Not enough arguments.*foo_1_3/, sub { foo_1_3 'a' };
+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 many arguments.*foo_1_3/, sub { foo_1_3 'a', 'b', 'c', 'd', 'e' };
-error_like qr/Not enough arguments.*foo_2_3/, sub { foo_2_3 };
-error_like qr/Not enough arguments.*foo_2_3/, sub { foo_2_3 'a' };
-error_like qr/Not enough arguments.*foo_2_3/, sub { foo_2_3 'a', 'b' };
+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 many arguments.*foo_2_3/, sub { foo_2_3 'a', 'b', 'c', 'd', 'e' };
-error_like qr/Not enough arguments.*foo_1_/, sub { foo_1_ };
-error_like qr/Not enough arguments.*foo_1_/, sub { foo_1_ 'a' };
+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'];
@@ -22,7 +22,7 @@ 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, $z = 'D2') { [$x, $y, $z] }
+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] }
@@ -47,66 +47,66 @@ 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 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/Not enough arguments.*foo_1/, fun { foo_1 };
+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 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/Not enough arguments.*foo_2/, fun { foo_2 };
-error_like qr/Not enough arguments.*foo_2/, fun { foo_2 'a' };
+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 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/Not enough arguments.*foo_3/, fun { foo_3 };
-error_like qr/Not enough arguments.*foo_3/, fun { foo_3 'a' };
-error_like qr/Not enough arguments.*foo_3/, fun { foo_3 'a', 'b' };
+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' };
+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' };
+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' };
+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 many arguments.*foo_0_3/, fun { foo_0_3 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_1_2/, fun { foo_1_2 };
+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 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/Not enough arguments.*foo_1_3/, fun { foo_1_3 };
+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 many arguments.*foo_1_3/, fun { foo_1_3 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_2_3/, fun { foo_2_3 };
-error_like qr/Not enough arguments.*foo_2_3/, fun { foo_2_3 'a' };
+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 many arguments.*foo_2_3/, fun { foo_2_3 'a', 'b', 'c', 'd' };
-error_like qr/Not enough arguments.*foo_1_/, fun { foo_1_ };
+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'];
@@ -0,0 +1,28 @@
+#!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' ];
@@ -15,7 +15,6 @@ for my $thing (map [__DIR__ . "/eating_strict_error$_->[0].fail", @$_[1 .. $#$_]
my $err = $!;
is $done, undef, "faulty code doesn't load";
- my $msg = qq{Global symbol "\$records" requires explicit package name at $file line $line.\n};
- like $exc, qr{^\Q$msg};
+ like $exc, qr{^Global symbol "\$records" requires explicit package name.* at \Q$file\E line \Q$line.\E\n};
$exc or die "$file: $err";
}
@@ -27,9 +27,9 @@ use Test::More 'no_plan';
return($self, @_);
}
- method echo(@_) {
- return($self, @_);
- }
+# method echo(@_) {
+# return($self, @_);
+# }
method caller($height = 0) {
return (CORE::caller($height))[0..2];
@@ -65,7 +65,7 @@ for my $method (qw(empty_proto)) {
like $@, qr{\QToo many arguments};
}
-is_deeply [$obj->echo(1,2,3)], [$obj,1,2,3], "echo";
+#is_deeply [$obj->echo(1,2,3)], [$obj,1,2,3], "echo";
is_deeply [$obj->caller], [__PACKAGE__, $0, __LINE__], 'caller works';
@@ -29,7 +29,7 @@ use Test::More;
}
is( Foo->foo( arg => 42 ), 42 );
- like exception { foo() }, qr/Not enough arguments/;
+ like exception { foo() }, qr/Too few arguments/;
# Compile time errors need internal refactoring before I can get file, line and method
@@ -14,4 +14,4 @@ package Foo {
}
}
-like exception { Foo->foo(name => 42, value =>) }, qr/Not enough arguments.+ line 17/;
+like exception { Foo->foo(name => 42, value =>) }, qr/Too few arguments.+ line 17/;
@@ -19,7 +19,7 @@ use Test::More;
is( Stuff->whatever(23), 23 );
- like exception { Stuff->whatever() }, qr/Not enough arguments/;
+ like exception { Stuff->whatever() }, qr/Too few arguments/;
method some_optional($that, $this = 22) {
return $that + $this
@@ -27,7 +27,7 @@ use Test::More;
is( Stuff->some_optional(18), 18 + 22 );
- like exception { Stuff->some_optional() }, qr/Not enough arguments/;
+ like exception { Stuff->some_optional() }, qr/Too few arguments/;
}
@@ -15,7 +15,7 @@ ok($@, "Got an error");
# if Eval::Closure->VERSION > 0.06;
like($@,
- qr/^Global symbol "\$op" requires explicit package name at .*?\bInvalidCase01.pm line 8\b/,
+ qr/^Global symbol "\$op" requires explicit package name .*?\bInvalidCase01.pm line 8\b/,
"Sane error message for syntax error");
#}
@@ -23,8 +23,8 @@ my $o = bless {} => 'Foo';
for my $meth_name (keys %meths) {
my $meth = $meths{$meth_name};
- like(exception { $o->$meth() }, qr/Not enough arguments/, "$meth_name dies without args");
- like(exception { $o->$meth('foo') }, qr/Not enough arguments/, "$meth_name dies with one arg");
+ 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");
@@ -0,0 +1,1335 @@
+#!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;
+
@@ -43,10 +43,10 @@ is $o->get_y, "B";
is $o->get_z, "C";
is eval { $o->get_z(42) }, undef;
-like $@, qr/many arguments/;
+like $@, qr/Too many arguments/;
is eval { $o->set_z }, undef;
-like $@, qr/enough arguments/;
+like $@, qr/Too few arguments/;
is eval q{fun ($self:) {}}, undef;
like $@, qr/invocant/;
@@ -22,9 +22,9 @@ compile_fail 'method (:$ni:) {}', qr/\binvocant\b.+\$ni\b.+\bnamed\b/;
fun name_1(:$n1) { [$n1, @_] }
-like exception { name_1 }, qr/Not enough arguments/;
-like exception { name_1 'n1' }, qr/Not enough arguments/;
-like exception { name_1 'asdf' }, qr/Not enough arguments/;
+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'];
@@ -45,10 +45,10 @@ 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/Not enough arguments/;
-like exception { pos_1_name_1 42 }, qr/Not enough arguments/;
-like exception { pos_1_name_1 42, 'n1' }, qr/Not enough arguments/;
-like exception { pos_1_name_1 42, 'asdf' }, qr/Not enough arguments/;
+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'];
@@ -61,7 +61,7 @@ compile_fail 'fun pos_0_1_name_1($p1 = "e", :$n1) { [$p1, $n1, @_] }', qr/\bopti
fun pos_1_name_0_1($p1, :$n1 = 'd') { [$p1, $n1, @_] }
-like exception { pos_1_name_0_1 }, qr/Not enough arguments/;
+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/;
@@ -87,9 +87,9 @@ is_deeply pos_0_1_name_0_1(42, n1 => 'a', n1 => undef), [42, undef, 42, n1 => 'a
fun name_1_slurp(:$n1, @rest) { [$n1, \@rest, @_] }
-like exception { name_1_slurp }, qr/Not enough arguments/;
-like exception { name_1_slurp 'n1' }, qr/Not enough arguments/;
-like exception { name_1_slurp 'asdf' }, qr/Not enough arguments/;
+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/;
@@ -111,16 +111,16 @@ is_deeply name_0_1_slurp(foo => 'bar', n1 => 'a', foo => 'quux'), ['a', [foo =>
fun name_2(:$n1, :$n2) { [$n1, $n2, @_] }
-like exception { name_2 }, qr/Not enough arguments/;
-like exception { name_2 'n1' }, qr/Not enough arguments/;
-like exception { name_2 'asdf' }, qr/Not enough arguments/;
-like exception { name_2 huh => 1 }, qr/Not enough arguments/;
-like exception { name_2 n1 => 'a' }, qr/Not enough arguments/;
+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/Not enough arguments/;
+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/Not enough arguments/;
-like exception { name_2 n1 => 'a', 'asdf' }, qr/Not enough arguments/;
+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'];
@@ -134,9 +134,9 @@ is_deeply name_2(n1 => 'a', n2 => 42, n1 => undef), [undef, 42, n1 => 'a', n2 =>
fun name_1_2(:$n1, :$n2 = 'f') { [$n1, $n2, @_] }
-like exception { name_1_2 }, qr/Not enough arguments/;
-like exception { name_1_2 'n1' }, qr/Not enough arguments/;
-like exception { name_1_2 'asdf' }, qr/Not enough arguments/;
+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'];
@@ -180,7 +180,7 @@ is_deeply name_0_2(n1 => 'a', n2 => 42, n1 => undef), [undef, 42, n1 => 'a', n2
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/Not enough/;
+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/;
@@ -1,5 +1,5 @@
#!perl
-use Test::More tests => 24;
+use Test::More tests => 52;
use warnings FATAL => 'all';
use strict;
@@ -31,14 +31,57 @@ is eval 'fun :(\[_$]) {}', undef;
like $@, qr/Illegal character after '\\' in prototype/;
{
- no warnings qw(illegalproto);
-
- ok eval 'fun :([) {}';
- ok eval 'fun :(][[[[[[) {}';
- ok eval 'fun :(\;) {}';
- ok eval 'fun :(\[_;@]) {}';
- ok eval 'fun :(\+) {}';
- ok eval 'fun :(\\\\) {}';
- ok eval 'fun :([$]) {}';
- ok eval 'fun :(\[_$]) {}';
+ no warnings qw(illegalproto);
+
+ ok eval 'fun :([) {}';
+ ok eval 'fun :(][[[[[[) {}';
+ ok eval 'fun :(\;) {}';
+ ok eval 'fun :(\[_;@]) {}';
+ ok eval 'fun :(\+) {}';
+ ok eval 'fun :(\\\\) {}';
+ ok eval 'fun :([$]) {}';
+ ok eval 'fun :(\[_$]) {}';
}
+
+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/;
+
+{
+ 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(\[_$]) {}';
+}
+
+is eval 'fun :($) prototype(@) {}', undef;
+like $@, qr/Can't redefine prototype/;
+
+is eval 'fun :prototype($) prototype(@) {}', undef;
+like $@, qr/Can't redefine prototype/;
@@ -0,0 +1,12 @@
+#!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;