Commit | Line | Data |
---|---|---|
1fa4e549 AD |
1 | #!./perl |
2 | # tests for "goto &sub"-ing into XSUBs | |
3 | ||
1fa4e549 AD |
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 NC |
10 | BEGIN { $| = 1; } |
11 | BEGIN { | |
12 | chdir 't' if -d 't'; | |
13 | @INC = '../lib'; | |
14 | $ENV{PERL5LIB} = "../lib"; | |
1fa4e549 AD |
15 | |
16 | # turn warnings into fatal errors | |
4210e2f6 | 17 | $SIG{__WARN__} = sub { die "WARNING: @_" } ; |
1fa4e549 | 18 | |
4210e2f6 NC |
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 AD |
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 AD |
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 AD |
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 AD |
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 AD |
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 AD |
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 AD |
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 AD |
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 AD |
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 DM |
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 |