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 (file)
--- 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 (file)
--- 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 (executable)
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");