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 | |
12 | chdir 't' if -d 't'; |
93430cb4 |
13 | unshift @INC, "../lib"; |
1fa4e549 |
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 | |
38 | $value = Fcntl::constant($VALID,0); |
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 | |
48 | $ret = goto_const($VALID,0); |
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 | |
55 | $ret = goto_name1($VALID,0); |
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 |
59 | $ret = goto_name1($VALID,0); |
60 | print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); |
61 | $ret = goto_name1($VALID,0); |
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 | |
70 | $ret = Fcntl::goto_name2($VALID,0); |
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 | |
77 | $ret = goto_ref($VALID,0); |
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 | |
85 | $ret = call_goto_const($VALID,0); |
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 | |
91 | $ret = call_goto_name1($VALID,0); |
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 | |
97 | $ret = call_goto_ref($VALID,0); |
98 | print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); |