Commit | Line | Data |
---|---|---|
1fa4e549 AD |
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 | ||
12 | chdir 't' if -d 't'; | |
20822f61 | 13 | @INC = '../lib'; |
1fa4e549 AD |
14 | $ENV{PERL5LIB} = "../lib"; |
15 | ||
16 | # turn warnings into fatal errors | |
17 | $SIG{__WARN__} = sub { die "WARNING: @_" } ; | |
18 | ||
19 | BEGIN { $| = 1; } | |
20 | eval 'require Fcntl' | |
21 | or do { print "1..0\n# Fcntl unavailable, can't test XS goto.\n"; exit 0 }; | |
22 | ||
23 | print "1..10\n"; | |
24 | ||
25 | # We don't know what symbols are defined in platform X's system headers. | |
26 | # We don't even want to guess, because some platform out there will | |
27 | # likely do the unthinkable. However, Fcntl::constant("LOCK_SH",0) | |
28 | # should always return a value, even on platforms which don't define the | |
29 | # cpp symbol; Fcntl.xs says: | |
30 | # /* We support flock() on systems which don't have it, so | |
31 | # always supply the constants. */ | |
32 | # If this ceases to be the case, we're in trouble. =) | |
33 | $VALID = 'LOCK_SH'; | |
34 | ||
35 | ### First, we check whether Fcntl::constant returns sane answers. | |
36 | # Fcntl::constant("LOCK_SH",0) should always succeed. | |
37 | ||
7ea3cd40 | 38 | $value = Fcntl::constant($VALID); |
1fa4e549 AD |
39 | print((!defined $value) |
40 | ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n" | |
41 | : "ok 1\n"); | |
42 | ||
43 | ### OK, we're ready to do real tests. | |
44 | ||
45 | # test "goto &function_constant" | |
46 | sub goto_const { goto &Fcntl::constant; } | |
47 | ||
7ea3cd40 | 48 | $ret = goto_const($VALID); |
1fa4e549 AD |
49 | print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n"); |
50 | ||
51 | # test "goto &$function_package_and_name" | |
52 | $FNAME1 = 'Fcntl::constant'; | |
53 | sub goto_name1 { goto &$FNAME1; } | |
54 | ||
7ea3cd40 | 55 | $ret = goto_name1($VALID); |
1fa4e549 AD |
56 | print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n"); |
57 | ||
58 | # test "goto &$function_package_and_name" again, with dirtier stack | |
7ea3cd40 | 59 | $ret = goto_name1($VALID); |
1fa4e549 | 60 | print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); |
7ea3cd40 | 61 | $ret = goto_name1($VALID); |
1fa4e549 AD |
62 | print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n"); |
63 | ||
64 | # test "goto &$function_name" from local package | |
65 | package Fcntl; | |
66 | $FNAME2 = 'constant'; | |
67 | sub goto_name2 { goto &$FNAME2; } | |
68 | package main; | |
69 | ||
7ea3cd40 | 70 | $ret = Fcntl::goto_name2($VALID); |
1fa4e549 AD |
71 | print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n"); |
72 | ||
73 | # test "goto &$function_ref" | |
74 | $FREF = \&Fcntl::constant; | |
75 | sub goto_ref { goto &$FREF; } | |
76 | ||
7ea3cd40 | 77 | $ret = goto_ref($VALID); |
1fa4e549 AD |
78 | print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); |
79 | ||
80 | ### tests where the args are not on stack but in GvAV(defgv) (ie, @_) | |
81 | ||
82 | # test "goto &function_constant" from a sub called without arglist | |
83 | sub call_goto_const { &goto_const; } | |
84 | ||
7ea3cd40 | 85 | $ret = call_goto_const($VALID); |
1fa4e549 AD |
86 | print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n"); |
87 | ||
88 | # test "goto &$function_package_and_name" from a sub called without arglist | |
89 | sub call_goto_name1 { &goto_name1; } | |
90 | ||
7ea3cd40 | 91 | $ret = call_goto_name1($VALID); |
1fa4e549 AD |
92 | print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n"); |
93 | ||
94 | # test "goto &$function_ref" from a sub called without arglist | |
95 | sub call_goto_ref { &goto_ref; } | |
96 | ||
7ea3cd40 | 97 | $ret = call_goto_ref($VALID); |
1fa4e549 | 98 | print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); |