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