From: Albert Dvornik <bert@genscan.com>
Date: Wed, 24 Jun 1998 19:33:09 +0000 (-0400)
Subject: applied patch, tweak for threads awareness
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1fa4e549f8e9f3cede7f12d9227a009e3b2383d9;p=p5sagit%2Fp5-mst-13.2.git

applied patch, tweak for threads awareness
	Subject: [PATCH]5.004_04-m4 (CORE) fix for broken "goto &xsub"
	Message-Id: <tq4sxawf2h.fsf@puma.genscan.com>

p4raw-id: //depot/perl@1257
---

diff --git a/MANIFEST b/MANIFEST
index 03d198d..f4108de 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -866,6 +866,7 @@ t/op/flip.t		See if range operator works
 t/op/fork.t		See if fork works
 t/op/glob.t		See if <*> works
 t/op/goto.t		See if goto works
+t/op/goto_xs.t		See if "goto &sub" works on XSUBs
 t/op/groups.t		See if $( works
 t/op/gv.t		See if typeglobs work
 t/op/hashwarn.t		See if warnings for bad hash assignments work
diff --git a/pp_ctl.c b/pp_ctl.c
index f35546c..82ee92a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1777,6 +1777,20 @@ PP(pp_goto)
 		AvREAL_off(av);
 		av_clear(av);
 	    }
+	    else if (CvXSUB(cv)) {	/* put GvAV(defgv) back onto stack */
+		AV* av;
+		int i;
+#ifdef USE_THREADS
+		av = (AV*)curpad[0];
+#else
+		av = GvAV(defgv);
+#endif
+		items = AvFILLp(av) + 1;
+		stack_sp++;
+		EXTEND(stack_sp, items); /* @_ could have been extended. */
+		Copy(AvARRAY(av), stack_sp, items, SV*);
+		stack_sp += items;
+	    }
 	    if (cx->cx_type == CXt_SUB &&
 		!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
 		SvREFCNT_dec(cx->blk_sub.cv);
@@ -1799,8 +1813,16 @@ PP(pp_goto)
 		    SP = stack_base + items;
 		}
 		else {
+		    SV **newsp;
+		    I32 gimme;
+
 		    stack_sp--;		/* There is no cv arg. */
+		    /* Push a mark for the start of arglist */
+		    PUSHMARK(mark); 
 		    (void)(*CvXSUB(cv))(cv _PERL_OBJECT_THIS);
+		    /* Pop the current context like a decent sub should */
+		    POPBLOCK(cx, curpm);
+		    /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
 		}
 		LEAVE;
 		return pop_return();
diff --git a/t/op/goto_xs.t b/t/op/goto_xs.t
new file mode 100755
index 0000000..a35575e
--- /dev/null
+++ b/t/op/goto_xs.t
@@ -0,0 +1,98 @@
+#!./perl
+# tests for "goto &sub"-ing into XSUBs
+
+# $RCSfile$$Revision$$Date$
+
+# Note: This only tests things that should *work*.  At some point, it may
+#       be worth while to write some failure tests for things that should
+#       *break* (such as calls with wrong number of args).  For now, I'm
+#       guessing that if all of these work correctly, the bad ones will
+#       break correctly as well.
+
+chdir 't' if -d 't';
+@INC = "../lib";
+$ENV{PERL5LIB} = "../lib";
+
+# turn warnings into fatal errors
+$SIG{__WARN__} = sub { die "WARNING: @_" } ;
+
+BEGIN { $| = 1; }
+eval 'require Fcntl'
+  or do { print "1..0\n# Fcntl unavailable, can't test XS goto.\n"; exit 0 };
+
+print "1..10\n";
+
+# We don't know what symbols are defined in platform X's system headers.
+# We don't even want to guess, because some platform out there will
+# likely do the unthinkable.  However, Fcntl::constant("LOCK_SH",0)
+# should always return a value, even on platforms which don't define the
+# cpp symbol; Fcntl.xs says:
+#           /* We support flock() on systems which don't have it, so
+#              always supply the constants. */
+# If this ceases to be the case, we're in trouble. =)
+$VALID = 'LOCK_SH';
+
+### First, we check whether Fcntl::constant returns sane answers.
+# Fcntl::constant("LOCK_SH",0) should always succeed.
+
+$value = Fcntl::constant($VALID,0);
+print((!defined $value)
+      ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n"
+      : "ok 1\n");
+
+### OK, we're ready to do real tests.
+
+# test "goto &function_constant"
+sub goto_const { goto &Fcntl::constant; }
+
+$ret = goto_const($VALID,0);
+print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n");
+
+# test "goto &$function_package_and_name"
+$FNAME1 = 'Fcntl::constant';
+sub goto_name1 { goto &$FNAME1; }
+
+$ret = goto_name1($VALID,0);
+print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n");
+
+# test "goto &$function_package_and_name" again, with dirtier stack
+$ret = goto_name1($VALID,0);
+print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
+$ret = goto_name1($VALID,0);
+print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n");
+
+# test "goto &$function_name" from local package
+package Fcntl;
+$FNAME2 = 'constant';
+sub goto_name2 { goto &$FNAME2; }
+package main;
+
+$ret = Fcntl::goto_name2($VALID,0);
+print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n");
+
+# test "goto &$function_ref"
+$FREF = \&Fcntl::constant;
+sub goto_ref { goto &$FREF; }
+
+$ret = goto_ref($VALID,0);
+print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n");
+
+### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
+
+# test "goto &function_constant" from a sub called without arglist
+sub call_goto_const { &goto_const; }
+
+$ret = call_goto_const($VALID,0);
+print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n");
+
+# test "goto &$function_package_and_name" from a sub called without arglist
+sub call_goto_name1 { &goto_name1; }
+
+$ret = call_goto_name1($VALID,0);
+print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n");
+
+# test "goto &$function_ref" from a sub called without arglist
+sub call_goto_ref { &goto_ref; }
+
+$ret = call_goto_ref($VALID,0);
+print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");