Jakub Wilk is now a Perl author.
[perl.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 {
11     chdir 't' if -d 't';
12     require './test.pl';
13 # turn warnings into fatal errors
14     $SIG{__WARN__} = sub { die "WARNING: @_" } ;
15     set_up_inc('../lib');
16     skip_all_if_miniperl("no dynamic loading on miniperl, no Fcntl");
17     require Fcntl;
18 }
19 use strict;
20 use warnings;
21 my $VALID;
22
23 plan(tests => 11);
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::S_IMODE(0)
28 # should always return a value.
29 # If this ceases to be the case, we're in trouble. =)
30 $VALID = 0;
31
32 ### First, we check whether Fcntl::S_IMODE returns sane answers.
33 # Fcntl::S_IMODE(0) should always succeed.
34
35 my $value = Fcntl::S_IMODE($VALID);
36 isnt($value, undef, 'Sanity check broke, remaining tests will fail');
37
38 ### OK, we're ready to do real tests.
39
40 sub goto_const { goto &Fcntl::S_IMODE; }
41
42 my $ret = goto_const($VALID);
43 is($ret, $value, 'goto &function_constant');
44
45 my $FNAME1 = 'Fcntl::S_IMODE';
46 sub goto_name1 { goto &$FNAME1; }
47
48 $ret = goto_name1($VALID);
49 is($ret, $value, 'goto &$function_package_and_name');
50
51 $ret = goto_name1($VALID);
52 is($ret, $value, 'goto &$function_package_and_name; again, with dirtier stack');
53 $ret = goto_name1($VALID);
54 is($ret, $value, 'goto &$function_package_and_name; again, with dirtier stack');
55
56 # test 
57 package Fcntl;
58 my $FNAME2 = 'S_IMODE';
59 sub goto_name2 { goto &$FNAME2; }
60 package main;
61
62 $ret = Fcntl::goto_name2($VALID);
63 is($ret, $value, 'goto &$function_name; from local package');
64
65 my $FREF = \&Fcntl::S_IMODE;
66 sub goto_ref { goto &$FREF; }
67
68 $ret = goto_ref($VALID);
69 is($ret, $value, 'goto &$function_ref');
70
71 ### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
72
73 sub call_goto_const { &goto_const; }
74
75 $ret = call_goto_const($VALID);
76 is($ret, $value, 'goto &function_constant; from a sub called without arglist');
77
78 # test "goto &$function_package_and_name" from a sub called without arglist
79 sub call_goto_name1 { &goto_name1; }
80
81 $ret = call_goto_name1($VALID);
82 is($ret, $value,
83    'goto &$function_package_and_name; from a sub called without arglist');
84
85 sub call_goto_ref { &goto_ref; }
86
87 $ret = call_goto_ref($VALID);
88 is($ret, $value, 'goto &$function_ref; from a sub called without arglist');
89
90
91 BEGIN {
92     use Config;
93     if ($Config{extensions} =~ m{XS/APItest}) {
94         eval q[use XS::APItest qw(mycroak); 1]
95             or die "use XS::APItest: $@\n";
96     }
97     else {
98         *mycroak = sub { die @_ };
99     }
100 }
101
102 sub goto_croak { goto &mycroak }
103
104 {
105     my $e;
106     for (1..4) {
107         eval { goto_croak("boo$_\n") };
108         $e .= $@;
109     }
110     is($e, "boo1\nboo2\nboo3\nboo4\n",
111        '[perl #35878] croak in XS after goto segfaulted')
112 }
113