t/op/goto_xs.t

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