#!./perl
# tests for "goto &sub"-ing into XSUBs
-# $RCSfile$$Revision$$Date$
-
# Note: This only tests things that should *work*. At some point, it may
# be worth while to write some failure tests for things that should
# *break* (such as calls with wrong number of args). For now, I'm
# guessing that if all of these work correctly, the bad ones will
# break correctly as well.
-chdir 't' if -d 't';
-@INC = '../lib';
-$ENV{PERL5LIB} = "../lib";
-
+BEGIN {
+ chdir 't' if -d 't';
+ require './test.pl';
# turn warnings into fatal errors
-$SIG{__WARN__} = sub { die "WARNING: @_" } ;
+ $SIG{__WARN__} = sub { die "WARNING: @_" } ;
-BEGIN { $| = 1; }
-eval 'require Fcntl'
- or do { print "1..0\n# Fcntl unavailable, can't test XS goto.\n"; exit 0 };
+ skip_all_if_miniperl("no dynamic loading on miniperl, no Fcntl");
+ require Fcntl;
+}
+use strict;
+use warnings;
+use vars '$VALID';
-print "1..10\n";
+plan(tests => 11);
# We don't know what symbols are defined in platform X's system headers.
# We don't even want to guess, because some platform out there will
-# likely do the unthinkable. However, Fcntl::constant("LOCK_SH",0)
-# should always return a value, even on platforms which don't define the
-# cpp symbol; Fcntl.xs says:
-# /* We support flock() on systems which don't have it, so
-# always supply the constants. */
+# likely do the unthinkable. However, Fcntl::S_IMODE(0)
+# should always return a value.
# If this ceases to be the case, we're in trouble. =)
-$VALID = 'LOCK_SH';
+$VALID = 0;
-### First, we check whether Fcntl::constant returns sane answers.
-# Fcntl::constant("LOCK_SH",0) should always succeed.
+### First, we check whether Fcntl::S_IMODE returns sane answers.
+# Fcntl::S_IMODE(0) should always succeed.
-$value = Fcntl::constant($VALID,0);
-print((!defined $value)
- ? "not ok 1\n# Sanity check broke, remaining tests will fail.\n"
- : "ok 1\n");
+my $value = Fcntl::S_IMODE($VALID);
+isnt($value, undef, 'Sanity check broke, remaining tests will fail');
### OK, we're ready to do real tests.
-# test "goto &function_constant"
-sub goto_const { goto &Fcntl::constant; }
+sub goto_const { goto &Fcntl::S_IMODE; }
-$ret = goto_const($VALID,0);
-print(($ret == $value) ? "ok 2\n" : "not ok 2\n# ($ret != $value)\n");
+my $ret = goto_const($VALID);
+is($ret, $value, 'goto &function_constant');
-# test "goto &$function_package_and_name"
-$FNAME1 = 'Fcntl::constant';
+my $FNAME1 = 'Fcntl::S_IMODE';
sub goto_name1 { goto &$FNAME1; }
-$ret = goto_name1($VALID,0);
-print(($ret == $value) ? "ok 3\n" : "not ok 3\n# ($ret != $value)\n");
+$ret = goto_name1($VALID);
+is($ret, $value, 'goto &$function_package_and_name');
-# test "goto &$function_package_and_name" again, with dirtier stack
-$ret = goto_name1($VALID,0);
-print(($ret == $value) ? "ok 4\n" : "not ok 4\n# ($ret != $value)\n");
-$ret = goto_name1($VALID,0);
-print(($ret == $value) ? "ok 5\n" : "not ok 5\n# ($ret != $value)\n");
+$ret = goto_name1($VALID);
+is($ret, $value, 'goto &$function_package_and_name; again, with dirtier stack');
+$ret = goto_name1($VALID);
+is($ret, $value, 'goto &$function_package_and_name; again, with dirtier stack');
-# test "goto &$function_name" from local package
+# test
package Fcntl;
-$FNAME2 = 'constant';
+my $FNAME2 = 'S_IMODE';
sub goto_name2 { goto &$FNAME2; }
package main;
-$ret = Fcntl::goto_name2($VALID,0);
-print(($ret == $value) ? "ok 6\n" : "not ok 6\n# ($ret != $value)\n");
+$ret = Fcntl::goto_name2($VALID);
+is($ret, $value, 'goto &$function_name; from local package');
-# test "goto &$function_ref"
-$FREF = \&Fcntl::constant;
+my $FREF = \&Fcntl::S_IMODE;
sub goto_ref { goto &$FREF; }
-$ret = goto_ref($VALID,0);
-print(($ret == $value) ? "ok 7\n" : "not ok 7\n# ($ret != $value)\n");
+$ret = goto_ref($VALID);
+is($ret, $value, 'goto &$function_ref');
### tests where the args are not on stack but in GvAV(defgv) (ie, @_)
-# test "goto &function_constant" from a sub called without arglist
sub call_goto_const { &goto_const; }
-$ret = call_goto_const($VALID,0);
-print(($ret == $value) ? "ok 8\n" : "not ok 8\n# ($ret != $value)\n");
+$ret = call_goto_const($VALID);
+is($ret, $value, 'goto &function_constant; from a sub called without arglist');
# test "goto &$function_package_and_name" from a sub called without arglist
sub call_goto_name1 { &goto_name1; }
-$ret = call_goto_name1($VALID,0);
-print(($ret == $value) ? "ok 9\n" : "not ok 9\n# ($ret != $value)\n");
+$ret = call_goto_name1($VALID);
+is($ret, $value,
+ 'goto &$function_package_and_name; from a sub called without arglist');
-# test "goto &$function_ref" from a sub called without arglist
sub call_goto_ref { &goto_ref; }
-$ret = call_goto_ref($VALID,0);
-print(($ret == $value) ? "ok 10\n" : "not ok 10\n# ($ret != $value)\n");
+$ret = call_goto_ref($VALID);
+is($ret, $value, 'goto &$function_ref; from a sub called without arglist');
+
+
+BEGIN {
+ use Config;
+ if ($Config{extensions} =~ m{XS/APItest}) {
+ eval q[use XS::APItest qw(mycroak); 1]
+ or die "use XS::APItest: $@\n";
+ }
+ else {
+ *mycroak = sub { die @_ };
+ }
+}
+
+sub goto_croak { goto &mycroak }
+
+{
+ my $e;
+ for (1..4) {
+ eval { goto_croak("boo$_\n") };
+ $e .= $@;
+ }
+ is($e, "boo1\nboo2\nboo3\nboo4\n",
+ '[perl #35878] croak in XS after goto segfaulted')
+}
+
https://perl5.git.perl.org / perl5.git / blobdiff