1#!./perl 2# tests for "goto &sub"-ing into XSUBs 3 4# $RCSfile$$Revision$$Date$ 5 6# Note: This only tests things that should *work*. At some point, it may 7# be worth while to write some failure tests for things that should 8# *break* (such as calls with wrong number of args). For now, I'm 9# guessing that if all of these work correctly, the bad ones will 10# break correctly as well. 11 12chdir '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 19BEGIN { $| = 1; } 20eval 'require Fcntl' 21 or do { print "1..0\n# Fcntl unavailable, can't test XS goto.\n"; exit 0 }; 22 23print "1..10\n"; 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::constant("LOCK_SH",0) 28# should always return a value, even on platforms which don't define the 29# cpp symbol; Fcntl.xs says: 30# /* We support flock() on systems which don't have it, so 31# always supply the constants. */ 32# If this ceases to be the case, we're in trouble. =) 33$VALID = 'LOCK_SH'; 34 35### First, we check whether Fcntl::constant returns sane answers. 36# Fcntl::constant("LOCK_SH",0) should always succeed. 37 38$value = Fcntl::constant($VALID); 39print((!defined $value) 40 ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n" 41 : "ok 1\n"); 42 43### OK, we're ready to do real tests. 44 45# test "goto &function_constant" 46sub goto_const { goto &Fcntl::constant; } 47 48$ret = goto_const($VALID); 49print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n"); 50 51# test "goto &$function_package_and_name" 52$FNAME1 = 'Fcntl::constant'; 53sub goto_name1 { goto &$FNAME1; } 54 55$ret = goto_name1($VALID); 56print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n"); 57 58# test "goto &$function_package_and_name" again, with dirtier stack 59$ret = goto_name1($VALID); 60print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n"); 61$ret = goto_name1($VALID); 62print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n"); 63 64# test "goto &$function_name" from local package 65package Fcntl; 66$FNAME2 = 'constant'; 67sub goto_name2 { goto &$FNAME2; } 68package main; 69 70$ret = Fcntl::goto_name2($VALID); 71print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n"); 72 73# test "goto &$function_ref" 74$FREF = \&Fcntl::constant; 75sub goto_ref { goto &$FREF; } 76 77$ret = goto_ref($VALID); 78print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n"); 79 80### tests where the args are not on stack but in GvAV(defgv) (ie, @_) 81 82# test "goto &function_constant" from a sub called without arglist 83sub call_goto_const { &goto_const; } 84 85$ret = call_goto_const($VALID); 86print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n"); 87 88# test "goto &$function_package_and_name" from a sub called without arglist 89sub call_goto_name1 { &goto_name1; } 90 91$ret = call_goto_name1($VALID); 92print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n"); 93 94# test "goto &$function_ref" from a sub called without arglist 95sub call_goto_ref { &goto_ref; } 96 97$ret = call_goto_ref($VALID); 98print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n"); 99