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