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 BEGIN { $| = 1; }
  13 BEGIN {
  14     chdir 't' if -d 't';
  15     @INC = '../lib';
  16     $ENV{PERL5LIB} = "../lib";
  17
  18 # turn warnings into fatal errors
  19     $SIG{__WARN__} = sub { die "WARNING: @_" } ;
  20
  21     foreach (qw(Fcntl XS::APItest)) {
  22         eval "require $_"
  23         or do { print "1..0\n# $_ unavailable, can't test XS goto.\n"; exit 0 }
  24     }
  25 }
  26 print "1..11\n";
  27
  28 # We don't know what symbols are defined in platform X's system headers.
  29 # We don't even want to guess, because some platform out there will
  30 # likely do the unthinkable.  However, Fcntl::constant("LOCK_SH",0)
  31 # should always return a value, even on platforms which don't define the
  32 # cpp symbol; Fcntl.xs says:
  33 #           /* We support flock() on systems which don't have it, so
  34 #              always supply the constants. */
  35 # If this ceases to be the case, we're in trouble. =)
  36 $VALID = 'LOCK_SH';
  37
  38 ### First, we check whether Fcntl::constant returns sane answers.
  39 # Fcntl::constant("LOCK_SH",0) should always succeed.
  40
  41 $value = Fcntl::constant($VALID);
  42 print((!defined $value)
  43       ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n"
  44       : "ok 1\n");
  45
  46 ### OK, we're ready to do real tests.
  47
  48 # test "goto &function_constant"
  49 sub goto_const { goto &Fcntl::constant; }
  50
  51 $ret = goto_const($VALID);
  52 print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n");
  53
  54 # test "goto &$function_package_and_name"
  55 $FNAME1 = 'Fcntl::constant';
  56 sub goto_name1 { goto &$FNAME1; }
  57
  58 $ret = goto_name1($VALID);
  59 print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n");
  60
  61 # test "goto &$function_package_and_name" again, with dirtier stack
  62 $ret = goto_name1($VALID);
  63 print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
  64 $ret = goto_name1($VALID);
  65 print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n");
  66
  67 # test "goto &$function_name" from local package
  68 package Fcntl;
  69 $FNAME2 = 'constant';
  70 sub goto_name2 { goto &$FNAME2; }
  71 package main;
  72
  73 $ret = Fcntl::goto_name2($VALID);
  74 print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n");
  75
  76 # test "goto &$function_ref"
  77 $FREF = \&Fcntl::constant;
  78 sub goto_ref { goto &$FREF; }
  79
  80 $ret = goto_ref($VALID);
  81 print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n");
  82
  83 ### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
  84
  85 # test "goto &function_constant" from a sub called without arglist
  86 sub call_goto_const { &goto_const; }
  87
  88 $ret = call_goto_const($VALID);
  89 print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n");
  90
  91 # test "goto &$function_package_and_name" from a sub called without arglist
  92 sub call_goto_name1 { &goto_name1; }
  93
  94 $ret = call_goto_name1($VALID);
  95 print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n");
  96
  97 # test "goto &$function_ref" from a sub called without arglist
  98 sub call_goto_ref { &goto_ref; }
  99
 100 $ret = call_goto_ref($VALID);
 101 print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
 102
 103
 104 # [perl #35878] croak in XS after goto segfaulted
 105
 106 use XS::APItest qw(mycroak);
 107
 108 sub goto_croak { goto &mycroak }
 109
 110 {
 111     my $e;
 112     for (1..4) {
 113         eval { goto_croak("boo$_\n") };
 114         $e .= $@;
 115     }
 116     print $e eq "boo1\nboo2\nboo3\nboo4\n" ? "ok 11\n" : "not ok 11\n";
 117 }
 118