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.

diff --git a/embed.h b/embed.h
index 7fc3b21..26d1bdb 100644 (file)
--- 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 40f327b..b9f41f2 100644 (file)
--- 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 0ce4140..de1a42d 100644 (file)
--- 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 814b710..73f52c8 100644 (file)
--- 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 c9c6984..d6720c3 100644 (file)
--- 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 a587a31..2c54c0c 100644 (file)
--- 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