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 10BEGIN { 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} 19use strict; 20use warnings; 21my $VALID; 22 23plan(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 35my $value = Fcntl::S_IMODE($VALID); 36isnt($value, undef, 'Sanity check broke, remaining tests will fail'); 37 38### OK, we're ready to do real tests. 39 40sub goto_const { goto &Fcntl::S_IMODE; } 41 42my $ret = goto_const($VALID); 43is($ret, $value, 'goto &function_constant'); 44 45my $FNAME1 = 'Fcntl::S_IMODE'; 46sub goto_name1 { goto &$FNAME1; } 47 48$ret = goto_name1($VALID); 49is($ret, $value, 'goto &$function_package_and_name'); 50 51$ret = goto_name1($VALID); 52is($ret, $value, 'goto &$function_package_and_name; again, with dirtier stack'); 53$ret = goto_name1($VALID); 54is($ret, $value, 'goto &$function_package_and_name; again, with dirtier stack'); 55 56# test 57package Fcntl; 58my $FNAME2 = 'S_IMODE'; 59sub goto_name2 { goto &$FNAME2; } 60package main; 61 62$ret = Fcntl::goto_name2($VALID); 63is($ret, $value, 'goto &$function_name; from local package'); 64 65my $FREF = \&Fcntl::S_IMODE; 66sub goto_ref { goto &$FREF; } 67 68$ret = goto_ref($VALID); 69is($ret, $value, 'goto &$function_ref'); 70 71### tests where the args are not on stack but in GvAV(defgv) (ie, @_) 72 73sub call_goto_const { &goto_const; } 74 75$ret = call_goto_const($VALID); 76is($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 79sub call_goto_name1 { &goto_name1; } 80 81$ret = call_goto_name1($VALID); 82is($ret, $value, 83 'goto &$function_package_and_name; from a sub called without arglist'); 84 85sub call_goto_ref { &goto_ref; } 86 87$ret = call_goto_ref($VALID); 88is($ret, $value, 'goto &$function_ref; from a sub called without arglist'); 89 90 91BEGIN { 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 102sub 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 114