Commit | Line | Data |
1fa4e549 |
1 | #!./perl |
2 | # tests for "goto &sub"-ing into XSUBs |
3 | |
1fa4e549 |
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. |
9 | |
4210e2f6 |
10 | BEGIN { $| = 1; } |
11 | BEGIN { |
12 | chdir 't' if -d 't'; |
13 | @INC = '../lib'; |
14 | $ENV{PERL5LIB} = "../lib"; |
1fa4e549 |
15 | |
16 | # turn warnings into fatal errors |
4210e2f6 |
17 | $SIG{__WARN__} = sub { die "WARNING: @_" } ; |
1fa4e549 |
18 | |
4210e2f6 |
19 | foreach (qw(Fcntl XS::APItest)) { |
20 | eval "require $_" |
21 | or do { print "1..0\n# $_ unavailable, can't test XS goto.\n"; exit 0 } |
22 | } |
23 | } |
5eff7df7 |
24 | print "1..11\n"; |
1fa4e549 |
25 | |
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. =) |
34 | $VALID = 'LOCK_SH'; |
35 | |
36 | ### First, we check whether Fcntl::constant returns sane answers. |
37 | # Fcntl::constant("LOCK_SH",0) should always succeed. |
38 | |
59d526a3 |
39 | $value = Fcntl::constant($VALID); |
1fa4e549 |
40 | print((!defined $value) |
41 | ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n" |
42 | : "ok 1\n"); |
43 | |
44 | ### OK, we're ready to do real tests. |
45 | |
46 | # test "goto &function_constant" |
47 | sub goto_const { goto &Fcntl::constant; } |
48 | |
59d526a3 |
49 | $ret = goto_const($VALID); |
1fa4e549 |
50 | print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n"); |
51 | |
52 | # test "goto &$function_package_and_name" |
53 | $FNAME1 = 'Fcntl::constant'; |
54 | sub goto_name1 { goto &$FNAME1; } |
55 | |
59d526a3 |
56 | $ret = goto_name1($VALID); |
1fa4e549 |
57 | print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n"); |
58 | |
59 | # test "goto &$function_package_and_name" again, with dirtier stack |
59d526a3 |
60 | $ret = goto_name1($VALID); |
1fa4e549 |
61 | print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); |
59d526a3 |
62 | $ret = goto_name1($VALID); |
1fa4e549 |
63 | print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n"); |
64 | |
65 | # test "goto &$function_name" from local package |
66 | package Fcntl; |
67 | $FNAME2 = 'constant'; |
68 | sub goto_name2 { goto &$FNAME2; } |
69 | package main; |
70 | |
59d526a3 |
71 | $ret = Fcntl::goto_name2($VALID); |
1fa4e549 |
72 | print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n"); |
73 | |
74 | # test "goto &$function_ref" |
75 | $FREF = \&Fcntl::constant; |
76 | sub goto_ref { goto &$FREF; } |
77 | |
59d526a3 |
78 | $ret = goto_ref($VALID); |
1fa4e549 |
79 | print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); |
80 | |
81 | ### tests where the args are not on stack but in GvAV(defgv) (ie, @_) |
82 | |
83 | # test "goto &function_constant" from a sub called without arglist |
84 | sub call_goto_const { &goto_const; } |
85 | |
59d526a3 |
86 | $ret = call_goto_const($VALID); |
1fa4e549 |
87 | print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n"); |
88 | |
89 | # test "goto &$function_package_and_name" from a sub called without arglist |
90 | sub call_goto_name1 { &goto_name1; } |
91 | |
59d526a3 |
92 | $ret = call_goto_name1($VALID); |
1fa4e549 |
93 | print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n"); |
94 | |
95 | # test "goto &$function_ref" from a sub called without arglist |
96 | sub call_goto_ref { &goto_ref; } |
97 | |
59d526a3 |
98 | $ret = call_goto_ref($VALID); |
1fa4e549 |
99 | print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); |
5eff7df7 |
100 | |
101 | |
102 | # [perl #35878] croak in XS after goto segfaulted |
103 | |
104 | use XS::APItest qw(mycroak); |
105 | |
106 | sub goto_croak { goto &mycroak } |
107 | |
108 | { |
109 | my $e; |
110 | for (1..4) { |
111 | eval { goto_croak("boo$_\n") }; |
112 | $e .= $@; |
113 | } |
114 | print $e eq "boo1\nboo2\nboo3\nboo4\n" ? "ok 11\n" : "not ok 11\n"; |
115 | } |
116 | |