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 { $| = 1; } 11BEGIN { 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} 24print "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); 40print((!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" 47sub goto_const { goto &Fcntl::constant; } 48 49$ret = goto_const($VALID); 50print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n"); 51 52# test "goto &$function_package_and_name" 53$FNAME1 = 'Fcntl::constant'; 54sub goto_name1 { goto &$FNAME1; } 55 56$ret = goto_name1($VALID); 57print(($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); 61print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); 62$ret = goto_name1($VALID); 63print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n"); 64 65# test "goto &$function_name" from local package 66package Fcntl; 67$FNAME2 = 'constant'; 68sub goto_name2 { goto &$FNAME2; } 69package main; 70 71$ret = Fcntl::goto_name2($VALID); 72print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n"); 73 74# test "goto &$function_ref" 75$FREF = \&Fcntl::constant; 76sub goto_ref { goto &$FREF; } 77 78$ret = goto_ref($VALID); 79print(($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 84sub call_goto_const { &goto_const; } 85 86$ret = call_goto_const($VALID); 87print(($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 90sub call_goto_name1 { &goto_name1; } 91 92$ret = call_goto_name1($VALID); 93print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n"); 94 95# test "goto &$function_ref" from a sub called without arglist 96sub call_goto_ref { &goto_ref; } 97 98$ret = call_goto_ref($VALID); 99print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); 100 101 102# [perl #35878] croak in XS after goto segfaulted 103 104use XS::APItest qw(mycroak); 105 106sub 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 117