2 # tests for "goto &sub"-ing into XSUBs
4 # $RCSfile$$Revision$$Date$
6 # Note: This only tests things that should *work*. At some point, it may
7 # be worth while to write some failure tests for things that should
8 # *break* (such as calls with wrong number of args). For now, I'm
9 # guessing that if all of these work correctly, the bad ones will
10 # break correctly as well.
16 $ENV{PERL5LIB} = "../lib";
18 # turn warnings into fatal errors
19 $SIG{__WARN__} = sub { die "WARNING: @_" } ;
21 foreach (qw(Fcntl XS::APItest)) {
23 or do { print "1..0\n# $_ unavailable, can't test XS goto.\n"; exit 0 }
28 # We don't know what symbols are defined in platform X's system headers.
29 # We don't even want to guess, because some platform out there will
30 # likely do the unthinkable. However, Fcntl::constant("LOCK_SH",0)
31 # should always return a value, even on platforms which don't define the
32 # cpp symbol; Fcntl.xs says:
33 # /* We support flock() on systems which don't have it, so
34 # always supply the constants. */
35 # If this ceases to be the case, we're in trouble. =)
38 ### First, we check whether Fcntl::constant returns sane answers.
39 # Fcntl::constant("LOCK_SH",0) should always succeed.
41 $value = Fcntl::constant($VALID);
42 print((!defined $value)
43 ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n"
46 ### OK, we're ready to do real tests.
48 # test "goto &function_constant"
49 sub goto_const { goto &Fcntl::constant; }
51 $ret = goto_const($VALID);
52 print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n");
54 # test "goto &$function_package_and_name"
55 $FNAME1 = 'Fcntl::constant';
56 sub goto_name1 { goto &$FNAME1; }
58 $ret = goto_name1($VALID);
59 print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n");
61 # test "goto &$function_package_and_name" again, with dirtier stack
62 $ret = goto_name1($VALID);
63 print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
64 $ret = goto_name1($VALID);
65 print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n");
67 # test "goto &$function_name" from local package
70 sub goto_name2 { goto &$FNAME2; }
73 $ret = Fcntl::goto_name2($VALID);
74 print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n");
76 # test "goto &$function_ref"
77 $FREF = \&Fcntl::constant;
78 sub goto_ref { goto &$FREF; }
80 $ret = goto_ref($VALID);
81 print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n");
83 ### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
85 # test "goto &function_constant" from a sub called without arglist
86 sub call_goto_const { &goto_const; }
88 $ret = call_goto_const($VALID);
89 print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n");
91 # test "goto &$function_package_and_name" from a sub called without arglist
92 sub call_goto_name1 { &goto_name1; }
94 $ret = call_goto_name1($VALID);
95 print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n");
97 # test "goto &$function_ref" from a sub called without arglist
98 sub call_goto_ref { &goto_ref; }
100 $ret = call_goto_ref($VALID);
101 print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
104 # [perl #35878] croak in XS after goto segfaulted
106 use XS::APItest qw(mycroak);
108 sub goto_croak { goto &mycroak }
113 eval { goto_croak("boo$_\n") };
116 print $e eq "boo1\nboo2\nboo3\nboo4\n" ? "ok 11\n" : "not ok 11\n";