home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / goto_xs.t < prev    next >
Text File  |  1999-07-20  |  3KB  |  99 lines
  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. unshift @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");
  99.