home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / pragma / constant.t next >
Text File  |  2000-03-13  |  6KB  |  231 lines
  1. #!./perl
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib' if -d '../lib';
  6. }
  7.  
  8. use warnings;
  9. use vars qw{ @warnings };
  10. BEGIN {                # ...and save 'em for later
  11.     $SIG{'__WARN__'} = sub { push @warnings, @_ }
  12. }
  13. END { print @warnings }
  14.  
  15. ######################### We start with some black magic to print on failure.
  16.  
  17. BEGIN { $| = 1; print "1..73\n"; }
  18. END {print "not ok 1\n" unless $loaded;}
  19. use constant 1.01;
  20. $loaded = 1;
  21. #print "# Version: $constant::VERSION\n";
  22. print "ok 1\n";
  23.  
  24. ######################### End of black magic.
  25.  
  26. use strict;
  27.  
  28. sub test ($$;$) {
  29.     my($num, $bool, $diag) = @_;
  30.     if ($bool) {
  31.     print "ok $num\n";
  32.     return;
  33.     }
  34.     print "not ok $num\n";
  35.     return unless defined $diag;
  36.     $diag =~ s/\Z\n?/\n/;            # unchomp
  37.     print map "# $num : $_", split m/^/m, $diag;
  38. }
  39.  
  40. use constant PI        => 4 * atan2 1, 1;
  41.  
  42. test 2, substr(PI, 0, 7) eq '3.14159';
  43. test 3, defined PI;
  44.  
  45. sub deg2rad { PI * $_[0] / 180 }
  46.  
  47. my $ninety = deg2rad 90;
  48.  
  49. test 4, $ninety > 1.5707;
  50. test 5, $ninety < 1.5708;
  51.  
  52. use constant UNDEF1    => undef;    # the right way
  53. use constant UNDEF2    =>    ;    # the weird way
  54. use constant 'UNDEF3'        ;    # the 'short' way
  55. use constant EMPTY    => ( )  ;    # the right way for lists
  56.  
  57. test 6, not defined UNDEF1;
  58. test 7, not defined UNDEF2;
  59. test 8, not defined UNDEF3;
  60. my @undef = UNDEF1;
  61. test 9, @undef == 1;
  62. test 10, not defined $undef[0];
  63. @undef = UNDEF2;
  64. test 11, @undef == 0;
  65. @undef = UNDEF3;
  66. test 12, @undef == 0;
  67. @undef = EMPTY;
  68. test 13, @undef == 0;
  69.  
  70. use constant COUNTDOWN    => scalar reverse 1, 2, 3, 4, 5;
  71. use constant COUNTLIST    => reverse 1, 2, 3, 4, 5;
  72. use constant COUNTLAST    => (COUNTLIST)[-1];
  73.  
  74. test 14, COUNTDOWN eq '54321';
  75. my @cl = COUNTLIST;
  76. test 15, @cl == 5;
  77. test 16, COUNTDOWN eq join '', @cl;
  78. test 17, COUNTLAST == 1;
  79. test 18, (COUNTLIST)[1] == 4;
  80.  
  81. use constant ABC    => 'ABC';
  82. test 19, "abc${\( ABC )}abc" eq "abcABCabc";
  83.  
  84. use constant DEF    => 'D', 'E', chr ord 'F';
  85. test 20, "d e f @{[ DEF ]} d e f" eq "d e f D E F d e f";
  86.  
  87. use constant SINGLE    => "'";
  88. use constant DOUBLE    => '"';
  89. use constant BACK    => '\\';
  90. my $tt = BACK . SINGLE . DOUBLE ;
  91. test 21, $tt eq q(\\'");
  92.  
  93. use constant MESS    => q('"'\\"'"\\);
  94. test 22, MESS eq q('"'\\"'"\\);
  95. test 23, length(MESS) == 8;
  96.  
  97. use constant TRAILING    => '12 cats';
  98. {
  99.     no warnings 'numeric';
  100.     test 24, TRAILING == 12;
  101. }
  102. test 25, TRAILING eq '12 cats';
  103.  
  104. use constant LEADING    => " \t1234";
  105. test 26, LEADING == 1234;
  106. test 27, LEADING eq " \t1234";
  107.  
  108. use constant ZERO1    => 0;
  109. use constant ZERO2    => 0.0;
  110. use constant ZERO3    => '0.0';
  111. test 28, ZERO1 eq '0';
  112. test 29, ZERO2 eq '0';
  113. test 30, ZERO3 eq '0.0';
  114.  
  115. {
  116.     package Other;
  117.     use constant PI    => 3.141;
  118. }
  119.  
  120. test 31, (PI > 3.1415 and PI < 3.1416);
  121. test 32, Other::PI == 3.141;
  122.  
  123. use constant E2BIG => $! = 7;
  124. test 33, E2BIG == 7;
  125. # This is something like "Arg list too long", but the actual message
  126. # text may vary, so we can't test much better than this.
  127. test 34, length(E2BIG) > 6;
  128. test 35, index(E2BIG, " ") > 0;
  129.  
  130. test 36, @warnings == 0, join "\n", "unexpected warning", @warnings;
  131. @warnings = ();        # just in case
  132. undef &PI;
  133. test 37, @warnings &&
  134.     ($warnings[0] =~ /Constant sub.* undefined/),
  135.     shift @warnings;
  136.  
  137. test 38, @warnings == 0, "unexpected warning";
  138. test 39, 1;
  139.  
  140. use constant CSCALAR    => \"ok 40\n";
  141. use constant CHASH    => { foo => "ok 41\n" };
  142. use constant CARRAY    => [ undef, "ok 42\n" ];
  143. use constant CPHASH    => [ { foo => 1 }, "ok 43\n" ];
  144. use constant CCODE    => sub { "ok $_[0]\n" };
  145.  
  146. print ${+CSCALAR};
  147. print CHASH->{foo};
  148. print CARRAY->[1];
  149. print CPHASH->{foo};
  150. eval q{ CPHASH->{bar} };
  151. test 44, scalar($@ =~ /^No such pseudo-hash field/);
  152. print CCODE->(45);
  153. eval q{ CCODE->{foo} };
  154. test 46, scalar($@ =~ /^Constant is not a HASH/);
  155.  
  156. # Allow leading underscore
  157. use constant _PRIVATE => 47;
  158. test 47, _PRIVATE == 47;
  159.  
  160. # Disallow doubled leading underscore
  161. eval q{
  162.     use constant __DISALLOWED => "Oops";
  163. };
  164. test 48, $@ =~ /begins with '__'/;
  165.  
  166. # Check on declared() and %declared. This sub should be EXACTLY the
  167. # same as the one quoted in the docs!
  168. sub declared ($) {
  169.     use constant 1.01;              # don't omit this!
  170.     my $name = shift;
  171.     $name =~ s/^::/main::/;
  172.     my $pkg = caller;
  173.     my $full_name = $name =~ /::/ ? $name : "${pkg}::$name";
  174.     $constant::declared{$full_name};
  175. }
  176.  
  177. test 49, declared 'PI';
  178. test 50, $constant::declared{'main::PI'};
  179.  
  180. test 51, !declared 'PIE';
  181. test 52, !$constant::declared{'main::PIE'};
  182.  
  183. {
  184.     package Other;
  185.     use constant IN_OTHER_PACK => 42;
  186.     ::test 53, ::declared 'IN_OTHER_PACK';
  187.     ::test 54, $constant::declared{'Other::IN_OTHER_PACK'};
  188.     ::test 55, ::declared 'main::PI';
  189.     ::test 56, $constant::declared{'main::PI'};
  190. }
  191.  
  192. test 57, declared 'Other::IN_OTHER_PACK';
  193. test 58, $constant::declared{'Other::IN_OTHER_PACK'};
  194.  
  195. @warnings = ();
  196. eval q{
  197.     no warnings;
  198.     use warnings 'constant';
  199.     use constant 'BEGIN' => 1 ;
  200.     use constant 'INIT' => 1 ;
  201.     use constant 'CHECK' => 1 ;
  202.     use constant 'END' => 1 ;
  203.     use constant 'DESTROY' => 1 ;
  204.     use constant 'AUTOLOAD' => 1 ;
  205.     use constant 'STDIN' => 1 ;
  206.     use constant 'STDOUT' => 1 ;
  207.     use constant 'STDERR' => 1 ;
  208.     use constant 'ARGV' => 1 ;
  209.     use constant 'ARGVOUT' => 1 ;
  210.     use constant 'ENV' => 1 ;
  211.     use constant 'INC' => 1 ;
  212.     use constant 'SIG' => 1 ;
  213. };
  214.  
  215. test 59, @warnings == 14 ;
  216. test 60, (shift @warnings) =~ /^Constant name 'BEGIN' is a Perl keyword at/;
  217. test 61, (shift @warnings) =~ /^Constant name 'INIT' is a Perl keyword at/;
  218. test 62, (shift @warnings) =~ /^Constant name 'CHECK' is a Perl keyword at/;
  219. test 63, (shift @warnings) =~ /^Constant name 'END' is a Perl keyword at/;
  220. test 64, (shift @warnings) =~ /^Constant name 'DESTROY' is a Perl keyword at/;
  221. test 65, (shift @warnings) =~ /^Constant name 'AUTOLOAD' is a Perl keyword at/;
  222. test 66, (shift @warnings) =~ /^Constant name 'STDIN' is forced into package main:: a/;
  223. test 67, (shift @warnings) =~ /^Constant name 'STDOUT' is forced into package main:: at/;
  224. test 68, (shift @warnings) =~ /^Constant name 'STDERR' is forced into package main:: at/;
  225. test 69, (shift @warnings) =~ /^Constant name 'ARGV' is forced into package main:: at/;
  226. test 70, (shift @warnings) =~ /^Constant name 'ARGVOUT' is forced into package main:: at/;
  227. test 71, (shift @warnings) =~ /^Constant name 'ENV' is forced into package main:: at/;
  228. test 72, (shift @warnings) =~ /^Constant name 'INC' is forced into package main:: at/;
  229. test 73, (shift @warnings) =~ /^Constant name 'SIG' is forced into package main:: at/;
  230. @warnings = ();
  231.