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 {
  11     chdir 't' if -d 't';
  12     require './test.pl';
  13 # turn warnings into fatal errors
  14     $SIG{__WARN__} = sub { die "WARNING: @_" } ;
  15
  16     skip_all_if_miniperl("no dynamic loading on miniperl, no Fcntl");
  17     require Fcntl;
  18 }
  19 use strict;
  20 use warnings;
  21 use vars '$VALID';
  22
  23 plan(tests => 11);
  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::S_IMODE(0)
  28 # should always return a value.
  29 # If this ceases to be the case, we're in trouble. =)
  30 $VALID = 0;
  31
  32 ### First, we check whether Fcntl::S_IMODE returns sane answers.
  33 # Fcntl::S_IMODE(0) should always succeed.
  34
  35 my $value = Fcntl::S_IMODE($VALID);
  36 isnt($value, undef, 'Sanity check broke, remaining tests will fail');
  37
  38 ### OK, we're ready to do real tests.
  39
  40 sub goto_const { goto &Fcntl::S_IMODE; }
  41
  42 my $ret = goto_const($VALID);
  43 is($ret, $value, 'goto &function_constant');
  44
  45 my $FNAME1 = 'Fcntl::S_IMODE';
  46 sub goto_name1 { goto &$FNAME1; }
  47
  48 $ret = goto_name1($VALID);
  49 is($ret, $value, 'goto &$function_package_and_name');
  50
  51 $ret = goto_name1($VALID);
  52 is($ret, $value, 'goto &$function_package_and_name; again, with dirtier stack');
  53 $ret = goto_name1($VALID);
  54 is($ret, $value, 'goto &$function_package_and_name; again, with dirtier stack');
  55
  56 # test
  57 package Fcntl;
  58 my $FNAME2 = 'S_IMODE';
  59 sub goto_name2 { goto &$FNAME2; }
  60 package main;
  61
  62 $ret = Fcntl::goto_name2($VALID);
  63 is($ret, $value, 'goto &$function_name; from local package');
  64
  65 my $FREF = \&Fcntl::S_IMODE;
  66 sub goto_ref { goto &$FREF; }
  67
  68 $ret = goto_ref($VALID);
  69 is($ret, $value, 'goto &$function_ref');
  70
  71 ### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
  72
  73 sub call_goto_const { &goto_const; }
  74
  75 $ret = call_goto_const($VALID);
  76 is($ret, $value, 'goto &function_constant; from a sub called without arglist');
  77
  78 # test "goto &$function_package_and_name" from a sub called without arglist
  79 sub call_goto_name1 { &goto_name1; }
  80
  81 $ret = call_goto_name1($VALID);
  82 is($ret, $value,
  83    'goto &$function_package_and_name; from a sub called without arglist');
  84
  85 sub call_goto_ref { &goto_ref; }
  86
  87 $ret = call_goto_ref($VALID);
  88 is($ret, $value, 'goto &$function_ref; from a sub called without arglist');
  89
  90
  91 BEGIN {
  92     use Config;
  93     if ($Config{extensions} =~ m{XS/APItest}) {
  94         eval q[use XS::APItest qw(mycroak); 1]
  95             or die "use XS::APItest: $@\n";
  96     }
  97     else {
  98         *mycroak = sub { die @_ };
  99     }
 100 }
 101
 102 sub goto_croak { goto &mycroak }
 103
 104 {
 105     my $e;
 106     for (1..4) {
 107         eval { goto_croak("boo$_\n") };
 108         $e .= $@;
 109     }
 110     is($e, "boo1\nboo2\nboo3\nboo4\n",
 111        '[perl #35878] croak in XS after goto segfaulted')
 112 }
 113