Refactor unpack’s newDEFSVOP logic; correct prototype

unpack is the only op that takes an implicit $_ for its second argu-
ment.  (For others it’s the first.)

Instead of special-casing unpack with its own ck_ routine, we can sim-
ply modify the logic in ck_fun to apply OA_DEFGV to the first optional
argument, not just the first argument.

Currently OA_DEFGV is not set in PL_opargs[OP_UNPACK], which means the
automatically-generated prototype is ($;$), instead of ($_).

This commit sets the flag on the op, changes it to use ck_fun
directly, and updates ck_fun and the prototype-generation code accord-
ingly.  I couldn’t put this in multiple commits, as the changes are
interdependent.

6 files changed, 17 insertions, 32 deletions

diff --git a/embed.h b/embed.h
index 7fc3b211b8..26d1bdb5b7 100644
--- a/embed.h
+++ b/embed.h
@@ -1006,7 +1006,6 @@
 #define ck_substr(a)		Perl_ck_substr(aTHX_ a)
 #define ck_svconst(a)		Perl_ck_svconst(aTHX_ a)
 #define ck_trunc(a)		Perl_ck_trunc(aTHX_ a)
-#define ck_unpack(a)		Perl_ck_unpack(aTHX_ a)
 #define convert(a,b,c)		Perl_convert(aTHX_ a,b,c)
 #define core_prototype(a,b,c,d)	Perl_core_prototype(aTHX_ a,b,c,d)
 #define create_eval_scope(a)	Perl_create_eval_scope(aTHX_ a)
diff --git a/op.c b/op.c
index 40f327bf51..b9f41f244e 100644
--- a/op.c
+++ b/op.c
@@ -7672,6 +7672,7 @@ Perl_ck_fun(pTHX_ OP *o)
         register OP *kid = cLISTOPo->op_first;
         OP *sibl;
         I32 numargs = 0;
+	bool seen_optional = FALSE;
 
 	if (kid->op_type == OP_PUSHMARK ||
 	    (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK))
@@ -7679,10 +7680,15 @@ Perl_ck_fun(pTHX_ OP *o)
 	    tokid = &kid->op_sibling;
 	    kid = kid->op_sibling;
 	}
-	if (!kid && PL_opargs[type] & OA_DEFGV)
-	    *tokid = kid = newDEFSVOP();
 
-	while (oa && kid) {
+	while (oa) {
+	    if (oa & OA_OPTIONAL) {
+		if (!kid && !seen_optional && PL_opargs[type] & OA_DEFGV)
+		    *tokid = kid = newDEFSVOP();
+		seen_optional = TRUE;
+	    }
+	    if (!kid) break;
+
 	    numargs++;
 	    sibl = kid->op_sibling;
 #ifdef PERL_MAD
@@ -9509,21 +9515,6 @@ Perl_ck_trunc(pTHX_ OP *o)
 }
 
 OP *
-Perl_ck_unpack(pTHX_ OP *o)
-{
-    OP *kid = cLISTOPo->op_first;
-
-    PERL_ARGS_ASSERT_CK_UNPACK;
-
-    if (kid->op_sibling) {
-	kid = kid->op_sibling;
-	if (!kid->op_sibling)
-	    kid->op_sibling = newDEFSVOP();
-    }
-    return ck_fun(o);
-}
-
-OP *
 Perl_ck_substr(pTHX_ OP *o)
 {
     PERL_ARGS_ASSERT_CK_SUBSTR;
@@ -10363,7 +10354,7 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
     oa = PL_opargs[i] >> OASHIFT;
     while (oa) {
 	if (oa & OA_OPTIONAL && !seen_question && (
-	      !defgv || n || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
+	      !defgv || (oa & (OA_OPTIONAL - 1)) == OA_FILEREF
 	)) {
 	    seen_question = 1;
 	    str[n++] = ';';
@@ -10386,10 +10377,11 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
 	    str[n++] = ']';
 	}
 	else str[n++] = ("?$@@%&*$")[oa & (OA_OPTIONAL - 1)];
+	if (oa & OA_OPTIONAL && defgv && str[n-1] == '$') {
+	    str[n-1] = '_'; defgv = 0;
+	}
 	oa = oa >> 4;
     }
-    if (defgv && str[0] == '$')
-	str[0] = '_';
     if (code == -KEY_not || code == -KEY_getprotobynumber) str[n++] = ';';
     str[n++] = '\0';
     sv_setpvn(sv, str, n - 1);
diff --git a/opcode.h b/opcode.h
index 0ce4140d60..de1a42d8c8 100644
--- a/opcode.h
+++ b/opcode.h
@@ -1452,7 +1452,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 	Perl_ck_null,		/* helem */
 	Perl_ck_null,		/* hslice */
 	Perl_ck_fun,		/* boolkeys */
-	Perl_ck_unpack,		/* unpack */
+	Perl_ck_fun,		/* unpack */
 	Perl_ck_fun,		/* pack */
 	Perl_ck_split,		/* split */
 	Perl_ck_join,		/* join */
@@ -1836,7 +1836,7 @@ EXTCONST U32 PL_opargs[] = {
 	0x00014204,	/* helem */
 	0x00024401,	/* hslice */
 	0x00004b00,	/* boolkeys */
-	0x00091400,	/* unpack */
+	0x00091480,	/* unpack */
 	0x0002140d,	/* pack */
 	0x00111408,	/* split */
 	0x0002140d,	/* join */
diff --git a/proto.h b/proto.h
index 814b710f1b..73f52c8680 100644
--- a/proto.h
+++ b/proto.h
@@ -544,12 +544,6 @@ PERL_CALLCONV OP *	Perl_ck_trunc(pTHX_ OP *o)
 #define PERL_ARGS_ASSERT_CK_TRUNC	\
 	assert(o)
 
-PERL_CALLCONV OP *	Perl_ck_unpack(pTHX_ OP *o)
-			__attribute__warn_unused_result__
-			__attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_CK_UNPACK	\
-	assert(o)
-
 PERL_CALLCONV void	Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
 			__attribute__format__(__printf__,pTHX_2,pTHX_3)
 			__attribute__nonnull__(pTHX_2);
diff --git a/regen/opcodes b/regen/opcodes
index c9c6984fbc..d6720c3cb3 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -235,7 +235,7 @@ boolkeys	boolkeys		ck_fun		%	H
 
 # Explosives and implosives.
 
-unpack		unpack			ck_unpack	@	S S?
+unpack		unpack			ck_fun		u@	S S?
 pack		pack			ck_fun		mst@	S L
 split		split			ck_split	t@	S S S
 join		join or string		ck_join		mst@	S L
diff --git a/t/op/cproto.t b/t/op/cproto.t
index a587a316a8..2c54c0c655 100644
--- a/t/op/cproto.t
+++ b/t/op/cproto.t
@@ -253,7 +253,7 @@ umask (;$)
 undef undef
 unless undef
 unlink (@)
-unpack ($;$)
+unpack ($_)
 unshift (+@)
 untie (\[$@%*])
 until undef