home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / base / lex.t < prev    next >
Text File  |  1999-07-20  |  4KB  |  209 lines
  1. #!./perl
  2.  
  3. print "1..46\n";
  4.  
  5. $x = 'x';
  6.  
  7. print "#1    :$x: eq :x:\n";
  8. if ($x eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
  9.  
  10. $x = $#;    # this is the register $#
  11.  
  12. if ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";}
  13.  
  14. $x = $#x;
  15.  
  16. if ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
  17.  
  18. $x = '\\'; # ';
  19.  
  20. if (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
  21.  
  22. eval 'while (0) {
  23.     print "foo\n";
  24. }
  25. /^/ && (print "ok 5\n");
  26. ';
  27.  
  28. eval '$foo{1} / 1;';
  29. if (!$@) {print "ok 6\n";} else {print "not ok 6 $@\n";}
  30.  
  31. eval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
  32.  
  33. $foo = int($foo * 100 + .5);
  34. if ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7 :$foo:\n";}
  35.  
  36. print <<'EOF';
  37. ok 8
  38. EOF
  39.  
  40. $foo = 'ok 9';
  41. print <<EOF;
  42. $foo
  43. EOF
  44.  
  45. eval <<\EOE, print $@;
  46. print <<'EOF';
  47. ok 10
  48. EOF
  49.  
  50. $foo = 'ok 11';
  51. print <<EOF;
  52. $foo
  53. EOF
  54. EOE
  55.  
  56. print <<`EOS` . <<\EOF;
  57. echo ok 12
  58. EOS
  59. ok 13
  60. EOF
  61.  
  62. print qq/ok 14\n/;
  63. print qq(ok 15\n);
  64.  
  65. print qq
  66. [ok 16\n]
  67. ;
  68.  
  69. print q<ok 17
  70. >;
  71.  
  72. print <<;   # Yow!
  73. ok 18
  74.  
  75. # previous line intentionally left blank.
  76.  
  77. print <<E1 eq "foo\n\n" ? "ok 19\n" : "not ok 19\n";
  78. @{[ <<E2 ]}
  79. foo
  80. E2
  81. E1
  82.  
  83. print <<E1 eq "foo\n\n" ? "ok 20\n" : "not ok 20\n";
  84. @{[
  85.   <<E2
  86. foo
  87. E2
  88. ]}
  89. E1
  90.  
  91. $foo = FOO;
  92. $bar = BAR;
  93. $foo{$bar} = BAZ;
  94. $ary[0] = ABC;
  95.  
  96. print "$foo{$bar}" eq "BAZ" ? "ok 21\n" : "not ok 21\n";
  97.  
  98. print "${foo}{$bar}" eq "FOO{BAR}" ? "ok 22\n" : "not ok 22\n";
  99. print "${foo{$bar}}" eq "BAZ" ? "ok 23\n" : "not ok 23\n";
  100.  
  101. print "FOO:" =~ /$foo[:]/ ? "ok 24\n" : "not ok 24\n";
  102. print "ABC" =~ /^$ary[$A]$/ ? "ok 25\n" : "not ok 25\n";
  103. print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 26\n" : "not ok 26\n";
  104.  
  105. # MJD 19980425
  106. ($X, @X) = qw(a b c d); 
  107. print "d" =~ /^$X[-1]$/ ? "ok 27\n" : "not ok 27\n";
  108. print "a1" !~ /^$X[-1]$/ ? "ok 28\n" : "not ok 28\n";
  109.  
  110. print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 29\n" : "not ok 29\n");
  111.  
  112.  
  113. $foo = "not ok 30\n";
  114. $foo =~ s/^not /substr(<<EOF, 0, 0)/e;
  115.   Ignored
  116. EOF
  117. print $foo;
  118.  
  119. # Tests for new extended control-character variables
  120. # MJD 19990227
  121.  
  122. { my $CX = "\cX";
  123.   my $CXY  ="\cXY";
  124.   $ {$CX} = 17;
  125.   $ {$CXY} = 23;
  126.   if ($ {^XY} != 23) { print "not "  }
  127.   print "ok 31\n";
  128.  
  129. # Does the syntax where we use the literal control character still work?
  130.   if (eval "\$ {\cX}" != 17 or $@) { print "not "  }
  131.   print "ok 32\n";
  132.  
  133.   eval "\$\cN = 24";                 # Literal control character
  134.   if ($@ or ${"\cN"} != 24) {  print "not "  }
  135.   print "ok 33\n";
  136.   if ($^N != 24) {  print "not "  }  # Control character escape sequence
  137.   print "ok 34\n";
  138.  
  139. # Does the old UNBRACED syntax still do what it used to?
  140.   if ("$^XY" ne "17Y") { print "not " }
  141.   print "ok 35\n";
  142.  
  143.   sub XX () { 6 }
  144.   $ {"\cN\cXX"} = 119; 
  145.   $^N = 5; #  This should be an unused ^Var.
  146.   $N = 5;
  147.   # The second caret here should be interpreted as an xor
  148.   if (($^N^XX) != 3) { print "not " } 
  149.   print "ok 36\n";
  150. #  if (($N  ^  XX()) != 3) { print "not " } 
  151. #  print "ok 32\n";
  152.  
  153.   # These next two tests are trying to make sure that
  154.   # $^FOO is always global; it doesn't make sense to `my' it.
  155.   # 
  156.  
  157.   eval 'my $^X;';
  158.   print "not " unless index ($@, 'Can\'t use global $^X in "my"') > -1;
  159.   print "ok 37\n";
  160. #  print "($@)\n" if $@;
  161.  
  162.   eval 'my $ {^XYZ};';
  163.   print "not " unless index ($@, 'Can\'t use global $^XYZ in "my"') > -1;
  164.   print "ok 38\n";
  165. #  print "($@)\n" if $@;
  166.  
  167. # Now let's make sure that caret variables are all forced into the main package.
  168.   package Someother;
  169.   $^N = 'Someother';
  170.   $ {^Nostril} = 'Someother 2';
  171.   $ {^M} = 'Someother 3';
  172.   package main;
  173.   print "not " unless $^N eq 'Someother';
  174.   print "ok 39\n";
  175.   print "not " unless $ {^Nostril} eq 'Someother 2';
  176.   print "ok 40\n";
  177.   print "not " unless $ {^M} eq 'Someother 3';
  178.   print "ok 41\n";
  179.  
  180.   
  181. }
  182.  
  183. # see if eval '', s///e, and heredocs mix
  184.  
  185. sub T {
  186.     my ($where, $num) = @_;
  187.     my ($p,$f,$l) = caller;
  188.     print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/;
  189.     print "ok $num\n";
  190. }
  191.  
  192. my $test = 42;
  193.  
  194. {
  195. # line 42 "plink"
  196.     local $_ = "not ok ";
  197.     eval q{
  198.     s/^not /<<EOT/e and T '^main:\(eval \d+\):2$', $test++;
  199. # fuggedaboudit
  200. EOT
  201.         print $_, $test++, "\n";
  202.     T('^main:\(eval \d+\):6$', $test++);
  203. # line 1 "plunk"
  204.     T('^main:plunk:1$', $test++);
  205.     };
  206.     print "# $@\nnot ok $test\n" if $@;
  207.     T '^main:plink:53$', $test++;
  208. }
  209.