This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
2c95139b14bd2c22eb09c246c0225d8244bf64ca
[perl5.git] / t / op / goto_xs.t
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 BEGIN { $| = 1; }
13 BEGIN {
14     chdir 't' if -d 't';
15     @INC = '../lib';
16     $ENV{PERL5LIB} = "../lib";
17
18 # turn warnings into fatal errors
19     $SIG{__WARN__} = sub { die "WARNING: @_" } ;
20
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 }
26 print "1..11\n";
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
41 $value = Fcntl::constant($VALID);
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
51 $ret = goto_const($VALID);
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
58 $ret = goto_name1($VALID);
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
62 $ret = goto_name1($VALID);
63 print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
64 $ret = goto_name1($VALID);
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
73 $ret = Fcntl::goto_name2($VALID);
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
80 $ret = goto_ref($VALID);
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
88 $ret = call_goto_const($VALID);
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
94 $ret = call_goto_name1($VALID);
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
100 $ret = call_goto_ref($VALID);
101 print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
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