From 1e4b6aa1907f271ce023ffe6f03439e2ce7f65dc Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Thu, 18 Aug 2011 22:09:17 -0700
Subject: [PATCH] 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.
---
 embed.fnc |  3 +++
 embed.h   |  1 +
 gv.c      | 47 +++++++----------------------------------------
 op.c      | 38 ++++++++++++++++++++++++++++++++++++++
 proto.h   |  5 +++++
 5 files changed, 54 insertions(+), 40 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index efbca48..f367bdf 100644
--- 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
--- 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
--- 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
--- 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
--- 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__
-- 
2.7.4