This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Pulling ancient RCS comments
[perl5.git] / t / op / goto_xs.t
1 #!./perl
2 # tests for "goto &sub"-ing into XSUBs
3
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
10 BEGIN { $| = 1; }
11 BEGIN {
12     chdir 't' if -d 't';
13     @INC = '../lib';
14     $ENV{PERL5LIB} = "../lib";
15
16 # turn warnings into fatal errors
17     $SIG{__WARN__} = sub { die "WARNING: @_" } ;
18
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 }
24 print "1..11\n";
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
39 $value = Fcntl::constant($VALID);
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
49 $ret = goto_const($VALID);
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
56 $ret = goto_name1($VALID);
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
60 $ret = goto_name1($VALID);
61 print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
62 $ret = goto_name1($VALID);
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
71 $ret = Fcntl::goto_name2($VALID);
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
78 $ret = goto_ref($VALID);
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
86 $ret = call_goto_const($VALID);
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
92 $ret = call_goto_name1($VALID);
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
98 $ret = call_goto_ref($VALID);
99 print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
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