t/op/goto_xs.t

   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
  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 BEGIN { $| = 1; }
  20 eval 'require Fcntl'
  21   or do { print "1..0\n# Fcntl unavailable, can't test XS goto.\n"; exit 0 };
  22
  23 print "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,0);
  39 print((!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"
  46 sub goto_const { goto &Fcntl::constant; }
  47
  48 $ret = goto_const($VALID,0);
  49 print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n");
  50
  51 # test "goto &$function_package_and_name"
  52 $FNAME1 = 'Fcntl::constant';
  53 sub goto_name1 { goto &$FNAME1; }
  54
  55 $ret = goto_name1($VALID,0);
  56 print(($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,0);
  60 print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
  61 $ret = goto_name1($VALID,0);
  62 print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n");
  63
  64 # test "goto &$function_name" from local package
  65 package Fcntl;
  66 $FNAME2 = 'constant';
  67 sub goto_name2 { goto &$FNAME2; }
  68 package main;
  69
  70 $ret = Fcntl::goto_name2($VALID,0);
  71 print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n");
  72
  73 # test "goto &$function_ref"
  74 $FREF = \&Fcntl::constant;
  75 sub goto_ref { goto &$FREF; }
  76
  77 $ret = goto_ref($VALID,0);
  78 print(($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
  83 sub call_goto_const { &goto_const; }
  84
  85 $ret = call_goto_const($VALID,0);
  86 print(($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
  89 sub call_goto_name1 { &goto_name1; }
  90
  91 $ret = call_goto_name1($VALID,0);
  92 print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n");
  93
  94 # test "goto &$function_ref" from a sub called without arglist
  95 sub call_goto_ref { &goto_ref; }
  96
  97 $ret = call_goto_ref($VALID,0);
  98 print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");