Move coresub op-creation from gv.c to op.c

For functions that take handles as arguments, this code will need to
call static functions in op.c, like is_handle_constructor.

While we could make is_handle_constructor into a non-static function
and call it from gv.c, that seems backwards, as it would result in a
lot of op-manipulation code in the middle of gv.c.

So this commit creates a new function in op.c, called coresub_op,
which is only called from gv.c, from the &CORE::sub code.

diff --git a/embed.fnc b/embed.fnc
index efbca48..f367bdf 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -266,6 +266,9 @@ Afnp        |int    |printf_nocontext|NN const char *format|...
 : Used in pp.c
 p      |SV *   |core_prototype |NULLOK SV *sv|NN const char *name \
                                |const int code|NULLOK int * const opnum
+: Used in gv.c
+p      |OP *   |coresub_op     |NN SV *coreargssv|const int code \
+                               |const int opnum
 : Used in sv.c
 p      |void   |cv_ckproto_len |NN const CV* cv|NULLOK const GV* gv\
                                |NULLOK const char* p|const STRLEN len

diff --git a/embed.h b/embed.h
index a4602af..c765931 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1008,6 +1008,7 @@
 #define ck_trunc(a)            Perl_ck_trunc(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 coresub_op(a,b,c)      Perl_coresub_op(aTHX_ a,b,c)
 #define create_eval_scope(a)   Perl_create_eval_scope(aTHX_ a)
 #define cv_ckproto_len(a,b,c,d)        Perl_cv_ckproto_len(aTHX_ a,b,c,d)
 #define cvgv_set(a,b)          Perl_cvgv_set(aTHX_ a,b)

diff --git a/gv.c b/gv.c
index a4cfbb0..311017e 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1337,7 +1337,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
            int opnum = 0;
            SV *opnumsv;
            bool ampable = FALSE; /* &{}-able */
-           OP *o;
            COP *oldcurcop;
            yy_parser *oldparser;
            I32 oldsavestack_ix;
@@ -1402,50 +1401,18 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                   new ATTRSUB. */
            (void)core_prototype((SV *)cv, name, code, &opnum);
            if (ampable) {
-               OP * const argop =
-                 newSVOP(OP_COREARGS,0,
-                         opnum ? newSVuv((UV)opnum) : newSVpvn(name,len));
-               switch(opnum) {
-               case 0:
-                   {
-                       IV index = 0;
-                       switch(-code) {
-                       case KEY___FILE__   : index = 1; break;
-                       case KEY___LINE__   : index = 2; break;
-                       }
-                       o = op_append_elem(OP_LINESEQ,
-                               argop,
-                               newSLICEOP(0,
-                                          newSVOP(OP_CONST, 0,
-                                                  newSViv(index)
-                                                 ),
-                                          newOP(OP_CALLER,0)
-                               )
-                           );
-                       break;
-                   }
-               default:
-                   switch (PL_opargs[opnum] & OA_CLASS_MASK) {
-                   case OA_BASEOP:
-                       o = op_append_elem(
-                                      OP_LINESEQ, argop,
-                                      newOP(opnum,
-                                            opnum == OP_WANTARRAY
-                                              ? OPpOFFBYONE << 8
-                                              : 0
-                                           )
-                                     );
-                       break;
-                   default:
-                       o = newUNOP(opnum,0,argop);
-                   }
-               }
                newATTRSUB(oldsavestack_ix,
                           newSVOP(
                                 OP_CONST, 0,
                                 newSVpvn_share(nambeg,full_len,0)
                           ),
-                          NULL,NULL,o
+                          NULL,NULL,
+                          coresub_op(
+                            opnum
+                              ? newSVuv((UV)opnum)
+                              : newSVpvn(name,len),
+                            code, opnum
+                          )
                );
                assert(GvCV(gv) == cv);
                LEAVE;

diff --git a/op.c b/op.c
index d68389f..74d27dd 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10326,6 +10326,44 @@ Perl_core_prototype(pTHX_ SV *sv, const char *name, const int code,
     return sv;
 }
 
+OP *
+Perl_coresub_op(pTHX_ SV * const coreargssv, const int code,
+                      const int opnum)
+{
+    OP * const argop = newSVOP(OP_COREARGS,0,coreargssv);
+
+    PERL_ARGS_ASSERT_CORESUB_OP;
+
+    switch(opnum) {
+    case 0:
+       {
+           IV index = 0;
+           switch(-code) {
+           case KEY___FILE__   : index = 1; break;
+           case KEY___LINE__   : index = 2; break;
+           }
+           return op_append_elem(OP_LINESEQ,
+                      argop,
+                      newSLICEOP(0,
+                                 newSVOP(OP_CONST, 0, newSViv(index)),
+                                 newOP(OP_CALLER,0)
+                      )
+                  );
+       }
+    default:
+       switch (PL_opargs[opnum] & OA_CLASS_MASK) {
+       case OA_BASEOP:
+           return op_append_elem(
+                       OP_LINESEQ, argop,
+                       newOP(opnum,
+                             opnum == OP_WANTARRAY ? OPpOFFBYONE << 8 : 0)
+                  );
+       default:
+           return newUNOP(opnum,0,argop);
+       }
+    }
+}
+
 #include "XSUB.h"
 
 /* Efficient sub that returns a constant scalar value. */

diff --git a/proto.h b/proto.h
index ea83f25..53f2931 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -577,6 +577,11 @@ PERL_CALLCONV SV * Perl_core_prototype(pTHX_ SV *sv, const char *name, const int
 #define PERL_ARGS_ASSERT_CORE_PROTOTYPE        \
        assert(name)
 
+PERL_CALLCONV OP *     Perl_coresub_op(pTHX_ SV *coreargssv, const int code, const int opnum)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_CORESUB_OP    \
+       assert(coreargssv)
+
 PERL_CALLCONV PERL_CONTEXT*    Perl_create_eval_scope(pTHX_ U32 flags);
 PERL_CALLCONV void     Perl_croak(pTHX_ const char* pat, ...)
                        __attribute__noreturn__