2 # tests for "goto &sub"-ing into XSUBs
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.
13 # turn warnings into fatal errors
14 $SIG{__WARN__} = sub { die "WARNING: @_" } ;
16 skip_all_if_miniperl("no dynamic loading on miniperl, no Fcntl");
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. =)
32 ### First, we check whether Fcntl::S_IMODE returns sane answers.
33 # Fcntl::S_IMODE(0) should always succeed.
35 my $value = Fcntl::S_IMODE($VALID);
36 isnt($value, undef, 'Sanity check broke, remaining tests will fail');
38 ### OK, we're ready to do real tests.
40 sub goto_const { goto &Fcntl::S_IMODE; }
42 my $ret = goto_const($VALID);
43 is($ret, $value, 'goto &function_constant');
45 my $FNAME1 = 'Fcntl::S_IMODE';
46 sub goto_name1 { goto &$FNAME1; }
48 $ret = goto_name1($VALID);
49 is($ret, $value, 'goto &$function_package_and_name');
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');
58 my $FNAME2 = 'S_IMODE';
59 sub goto_name2 { goto &$FNAME2; }
62 $ret = Fcntl::goto_name2($VALID);
63 is($ret, $value, 'goto &$function_name; from local package');
65 my $FREF = \&Fcntl::S_IMODE;
66 sub goto_ref { goto &$FREF; }
68 $ret = goto_ref($VALID);
69 is($ret, $value, 'goto &$function_ref');
71 ### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
73 sub call_goto_const { &goto_const; }
75 $ret = call_goto_const($VALID);
76 is($ret, $value, 'goto &function_constant; from a sub called without arglist');
78 # test "goto &$function_package_and_name" from a sub called without arglist
79 sub call_goto_name1 { &goto_name1; }
81 $ret = call_goto_name1($VALID);
83 'goto &$function_package_and_name; from a sub called without arglist');
85 sub call_goto_ref { &goto_ref; }
87 $ret = call_goto_ref($VALID);
88 is($ret, $value, 'goto &$function_ref; from a sub called without arglist');
93 if ($Config{extensions} =~ m{XS/APItest}) {
94 eval q[use XS::APItest qw(mycroak); 1]
95 or die "use XS::APItest: $@\n";
98 *mycroak = sub { die @_ };
102 sub goto_croak { goto &mycroak }
107 eval { goto_croak("boo$_\n") };
110 is($e, "boo1\nboo2\nboo3\nboo4\n",
111 '[perl #35878] croak in XS after goto segfaulted')