home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / subst.t < prev    next >
Text File  |  1999-12-08  |  10KB  |  382 lines
  1. #!./perl
  2.  
  3. BEGIN {
  4.     chdir 't' if -d 't';
  5.     unshift @INC, '../lib' if -d '../lib';
  6.     require Config; import Config;
  7. }
  8.  
  9. print "1..84\n";
  10.  
  11. $x = 'foo';
  12. $_ = "x";
  13. s/x/\$x/;
  14. print "#1\t:$_: eq :\$x:\n";
  15. if ($_ eq '$x') {print "ok 1\n";} else {print "not ok 1\n";}
  16.  
  17. $_ = "x";
  18. s/x/$x/;
  19. print "#2\t:$_: eq :foo:\n";
  20. if ($_ eq 'foo') {print "ok 2\n";} else {print "not ok 2\n";}
  21.  
  22. $_ = "x";
  23. s/x/\$x $x/;
  24. print "#3\t:$_: eq :\$x foo:\n";
  25. if ($_ eq '$x foo') {print "ok 3\n";} else {print "not ok 3\n";}
  26.  
  27. $b = 'cd';
  28. ($a = 'abcdef') =~ s<(b${b}e)>'\n$1';
  29. print "#4\t:$1: eq :bcde:\n";
  30. print "#4\t:$a: eq :a\\n\$1f:\n";
  31. if ($1 eq 'bcde' && $a eq 'a\n$1f') {print "ok 4\n";} else {print "not ok 4\n";}
  32.  
  33. $a = 'abacada';
  34. if (($a =~ s/a/x/g) == 4 && $a eq 'xbxcxdx')
  35.     {print "ok 5\n";} else {print "not ok 5\n";}
  36.  
  37. if (($a =~ s/a/y/g) == 0 && $a eq 'xbxcxdx')
  38.     {print "ok 6\n";} else {print "not ok 6 $a\n";}
  39.  
  40. if (($a =~ s/b/y/g) == 1 && $a eq 'xyxcxdx')
  41.     {print "ok 7\n";} else {print "not ok 7 $a\n";}
  42.  
  43. $_ = 'ABACADA';
  44. if (/a/i && s///gi && $_ eq 'BCD') {print "ok 8\n";} else {print "not ok 8 $_\n";}
  45.  
  46. $_ = '\\' x 4;
  47. if (length($_) == 4) {print "ok 9\n";} else {print "not ok 9\n";}
  48. s/\\/\\\\/g;
  49. if ($_ eq '\\' x 8) {print "ok 10\n";} else {print "not ok 10 $_\n";}
  50.  
  51. $_ = '\/' x 4;
  52. if (length($_) == 8) {print "ok 11\n";} else {print "not ok 11\n";}
  53. s/\//\/\//g;
  54. if ($_ eq '\\//' x 4) {print "ok 12\n";} else {print "not ok 12\n";}
  55. if (length($_) == 12) {print "ok 13\n";} else {print "not ok 13\n";}
  56.  
  57. $_ = 'aaaXXXXbbb';
  58. s/^a//;
  59. print $_ eq 'aaXXXXbbb' ? "ok 14\n" : "not ok 14\n";
  60.  
  61. $_ = 'aaaXXXXbbb';
  62. s/a//;
  63. print $_ eq 'aaXXXXbbb' ? "ok 15\n" : "not ok 15\n";
  64.  
  65. $_ = 'aaaXXXXbbb';
  66. s/^a/b/;
  67. print $_ eq 'baaXXXXbbb' ? "ok 16\n" : "not ok 16\n";
  68.  
  69. $_ = 'aaaXXXXbbb';
  70. s/a/b/;
  71. print $_ eq 'baaXXXXbbb' ? "ok 17\n" : "not ok 17\n";
  72.  
  73. $_ = 'aaaXXXXbbb';
  74. s/aa//;
  75. print $_ eq 'aXXXXbbb' ? "ok 18\n" : "not ok 18\n";
  76.  
  77. $_ = 'aaaXXXXbbb';
  78. s/aa/b/;
  79. print $_ eq 'baXXXXbbb' ? "ok 19\n" : "not ok 19\n";
  80.  
  81. $_ = 'aaaXXXXbbb';
  82. s/b$//;
  83. print $_ eq 'aaaXXXXbb' ? "ok 20\n" : "not ok 20\n";
  84.  
  85. $_ = 'aaaXXXXbbb';
  86. s/b//;
  87. print $_ eq 'aaaXXXXbb' ? "ok 21\n" : "not ok 21\n";
  88.  
  89. $_ = 'aaaXXXXbbb';
  90. s/bb//;
  91. print $_ eq 'aaaXXXXb' ? "ok 22\n" : "not ok 22\n";
  92.  
  93. $_ = 'aaaXXXXbbb';
  94. s/aX/y/;
  95. print $_ eq 'aayXXXbbb' ? "ok 23\n" : "not ok 23\n";
  96.  
  97. $_ = 'aaaXXXXbbb';
  98. s/Xb/z/;
  99. print $_ eq 'aaaXXXzbb' ? "ok 24\n" : "not ok 24\n";
  100.  
  101. $_ = 'aaaXXXXbbb';
  102. s/aaX.*Xbb//;
  103. print $_ eq 'ab' ? "ok 25\n" : "not ok 25\n";
  104.  
  105. $_ = 'aaaXXXXbbb';
  106. s/bb/x/;
  107. print $_ eq 'aaaXXXXxb' ? "ok 26\n" : "not ok 26\n";
  108.  
  109. # now for some unoptimized versions of the same.
  110.  
  111. $_ = 'aaaXXXXbbb';
  112. $x ne $x || s/^a//;
  113. print $_ eq 'aaXXXXbbb' ? "ok 27\n" : "not ok 27\n";
  114.  
  115. $_ = 'aaaXXXXbbb';
  116. $x ne $x || s/a//;
  117. print $_ eq 'aaXXXXbbb' ? "ok 28\n" : "not ok 28\n";
  118.  
  119. $_ = 'aaaXXXXbbb';
  120. $x ne $x || s/^a/b/;
  121. print $_ eq 'baaXXXXbbb' ? "ok 29\n" : "not ok 29\n";
  122.  
  123. $_ = 'aaaXXXXbbb';
  124. $x ne $x || s/a/b/;
  125. print $_ eq 'baaXXXXbbb' ? "ok 30\n" : "not ok 30\n";
  126.  
  127. $_ = 'aaaXXXXbbb';
  128. $x ne $x || s/aa//;
  129. print $_ eq 'aXXXXbbb' ? "ok 31\n" : "not ok 31\n";
  130.  
  131. $_ = 'aaaXXXXbbb';
  132. $x ne $x || s/aa/b/;
  133. print $_ eq 'baXXXXbbb' ? "ok 32\n" : "not ok 32\n";
  134.  
  135. $_ = 'aaaXXXXbbb';
  136. $x ne $x || s/b$//;
  137. print $_ eq 'aaaXXXXbb' ? "ok 33\n" : "not ok 33\n";
  138.  
  139. $_ = 'aaaXXXXbbb';
  140. $x ne $x || s/b//;
  141. print $_ eq 'aaaXXXXbb' ? "ok 34\n" : "not ok 34\n";
  142.  
  143. $_ = 'aaaXXXXbbb';
  144. $x ne $x || s/bb//;
  145. print $_ eq 'aaaXXXXb' ? "ok 35\n" : "not ok 35\n";
  146.  
  147. $_ = 'aaaXXXXbbb';
  148. $x ne $x || s/aX/y/;
  149. print $_ eq 'aayXXXbbb' ? "ok 36\n" : "not ok 36\n";
  150.  
  151. $_ = 'aaaXXXXbbb';
  152. $x ne $x || s/Xb/z/;
  153. print $_ eq 'aaaXXXzbb' ? "ok 37\n" : "not ok 37\n";
  154.  
  155. $_ = 'aaaXXXXbbb';
  156. $x ne $x || s/aaX.*Xbb//;
  157. print $_ eq 'ab' ? "ok 38\n" : "not ok 38\n";
  158.  
  159. $_ = 'aaaXXXXbbb';
  160. $x ne $x || s/bb/x/;
  161. print $_ eq 'aaaXXXXxb' ? "ok 39\n" : "not ok 39\n";
  162.  
  163. $_ = 'abc123xyz';
  164. s/(\d+)/$1*2/e;              # yields 'abc246xyz'
  165. print $_ eq 'abc246xyz' ? "ok 40\n" : "not ok 40\n";
  166. s/(\d+)/sprintf("%5d",$1)/e; # yields 'abc  246xyz'
  167. print $_ eq 'abc  246xyz' ? "ok 41\n" : "not ok 41\n";
  168. s/(\w)/$1 x 2/eg;            # yields 'aabbcc  224466xxyyzz'
  169. print $_ eq 'aabbcc  224466xxyyzz' ? "ok 42\n" : "not ok 42\n";
  170.  
  171. $_ = "aaaaa";
  172. print y/a/b/ == 5 ? "ok 43\n" : "not ok 43\n";
  173. print y/a/b/ == 0 ? "ok 44\n" : "not ok 44\n";
  174. print y/b// == 5 ? "ok 45\n" : "not ok 45\n";
  175. print y/b/c/s == 5 ? "ok 46\n" : "not ok 46\n";
  176. print y/c// == 1 ? "ok 47\n" : "not ok 47\n";
  177. print y/c//d == 1 ? "ok 48\n" : "not ok 48\n";
  178. print $_ eq "" ? "ok 49\n" : "not ok 49\n";
  179.  
  180. $_ = "Now is the %#*! time for all good men...";
  181. print (($x=(y/a-zA-Z //cd)) == 7 ? "ok 50\n" : "not ok 50\n");
  182. print y/ / /s == 8 ? "ok 51\n" : "not ok 51\n";
  183.  
  184. $_ = 'abcdefghijklmnopqrstuvwxyz0123456789';
  185. tr/a-z/A-Z/;
  186.  
  187. print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n";
  188.  
  189. # same as tr/A-Z/a-z/;
  190. if ($Config{ebcdic} eq 'define') {    # EBCDIC.
  191.     no utf8;
  192.     y[\301-\351][\201-\251];
  193. } else {        # Ye Olde ASCII.  Or something like it.
  194.     y[\101-\132][\141-\172];
  195. }
  196.  
  197. print $_ eq 'abcdefghijklmnopqrstuvwxyz0123456789' ? "ok 53\n" : "not ok 53\n";
  198.  
  199. if (ord("+") == ord(",") - 1 && ord(",") == ord("-") - 1 &&
  200.     ord("a") == ord("b") - 1 && ord("b") == ord("c") - 1) {
  201.   $_ = '+,-';
  202.   tr/+--/a-c/;
  203.   print "not " unless $_ eq 'abc';
  204. }
  205. print "ok 54\n";
  206.  
  207. $_ = '+,-';
  208. tr/+\--/a\/c/;
  209. print $_ eq 'a,/' ? "ok 55\n" : "not ok 55\n";
  210.  
  211. $_ = '+,-';
  212. tr/-+,/ab\-/;
  213. print $_ eq 'b-a' ? "ok 56\n" : "not ok 56\n";
  214.  
  215.  
  216. # test recursive substitutions
  217. # code based on the recursive expansion of makefile variables
  218.  
  219. my %MK = (
  220.     AAAAA => '$(B)', B=>'$(C)', C => 'D',            # long->short
  221.     E     => '$(F)', F=>'p $(G) q', G => 'HHHHH',    # short->long
  222.     DIR => '$(UNDEFINEDNAME)/xxx',
  223. );
  224. sub var { 
  225.     my($var,$level) = @_;
  226.     return "\$($var)" unless exists $MK{$var};
  227.     return exp_vars($MK{$var}, $level+1); # can recurse
  228. }
  229. sub exp_vars { 
  230.     my($str,$level) = @_;
  231.     $str =~ s/\$\((\w+)\)/var($1, $level+1)/ge; # can recurse
  232.     #warn "exp_vars $level = '$str'\n";
  233.     $str;
  234. }
  235.  
  236. print exp_vars('$(AAAAA)',0)           eq 'D'
  237.     ? "ok 57\n" : "not ok 57\n";
  238. print exp_vars('$(E)',0)               eq 'p HHHHH q'
  239.     ? "ok 58\n" : "not ok 58\n";
  240. print exp_vars('$(DIR)',0)             eq '$(UNDEFINEDNAME)/xxx'
  241.     ? "ok 59\n" : "not ok 59\n";
  242. print exp_vars('foo $(DIR)/yyy bar',0) eq 'foo $(UNDEFINEDNAME)/xxx/yyy bar'
  243.     ? "ok 60\n" : "not ok 60\n";
  244.  
  245. # a match nested in the RHS of a substitution:
  246.  
  247. $_ = "abcd";
  248. s/(..)/$x = $1, m#.#/eg;
  249. print $x eq "cd" ? "ok 61\n" : "not ok 61\n";
  250.  
  251. # Subst and lookbehind
  252.  
  253. $_="ccccc";
  254. s/(?<!x)c/x/g;
  255. print $_ eq "xxxxx" ? "ok 62\n" : "not ok 62 # `$_' ne `xxxxx'\n";
  256.  
  257. $_="ccccc";
  258. s/(?<!x)(c)/x/g;
  259. print $_ eq "xxxxx" ? "ok 63\n" : "not ok 63 # `$_' ne `xxxxx'\n";
  260.  
  261. $_="foobbarfoobbar";
  262. s/(?<!r)foobbar/foobar/g;
  263. print $_ eq "foobarfoobbar" ? "ok 64\n" : "not ok 64 # `$_' ne `foobarfoobbar'\n";
  264.  
  265. $_="foobbarfoobbar";
  266. s/(?<!ar)(foobbar)/foobar/g;
  267. print $_ eq "foobarfoobbar" ? "ok 65\n" : "not ok 65 # `$_' ne `foobarfoobbar'\n";
  268.  
  269. $_="foobbarfoobbar";
  270. s/(?<!ar)foobbar/foobar/g;
  271. print $_ eq "foobarfoobbar" ? "ok 66\n" : "not ok 66 # `$_' ne `foobarfoobbar'\n";
  272.  
  273. # check parsing of split subst with comment
  274. eval 's{foo} # this is a comment, not a delimiter
  275.        {bar};';
  276. print @? ? "not ok 67\n" : "ok 67\n";
  277.  
  278. # check if squashing works at the end of string
  279. $_="baacbaa";
  280. tr/a/b/s;
  281. print $_ eq "bbcbb" ? "ok 68\n" : "not ok 68 # `$_' ne `bbcbb'\n";
  282.  
  283. # XXX TODO: Most tests above don't test return values of the ops. They should.
  284. $_ = "ab";
  285. print (s/a/b/ == 1 ? "ok 69\n" : "not ok 69\n");
  286.  
  287. $_ = <<'EOL';
  288.      $url = new URI::URL "http://www/";   die if $url eq "xXx";
  289. EOL
  290. $^R = 'junk';
  291.  
  292. $foo = ' $@%#lowercase $@%# lowercase UPPERCASE$@%#UPPERCASE' .
  293.   ' $@%#lowercase$@%#lowercase$@%# lowercase lowercase $@%#lowercase' .
  294.   ' lowercase $@%#MiXeD$@%# ';
  295.  
  296. s{  \d+          \b [,.;]? (?{ 'digits' })
  297.    |
  298.     [a-z]+       \b [,.;]? (?{ 'lowercase' })
  299.    |
  300.     [A-Z]+       \b [,.;]? (?{ 'UPPERCASE' })
  301.    |
  302.     [A-Z] [a-z]+ \b [,.;]? (?{ 'Capitalized' })
  303.    |
  304.     [A-Za-z]+    \b [,.;]? (?{ 'MiXeD' })
  305.    |
  306.     [A-Za-z0-9]+ \b [,.;]? (?{ 'alphanumeric' })
  307.    |
  308.     \s+                    (?{ ' ' })
  309.    |
  310.     [^A-Za-z0-9\s]+          (?{ '$@%#' })
  311. }{$^R}xg;
  312. print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n");
  313.  
  314. $_ = 'x' x 20; 
  315. s/(\d*|x)/<$1>/g; 
  316. $foo = '<>' . ('<x><>' x 20) ;
  317. print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n");
  318.  
  319. $t = 'aaaaaaaaa'; 
  320.  
  321. $_ = $t;
  322. pos = 6;
  323. s/\Ga/xx/g;
  324. print "not " unless $_ eq 'aaaaaaxxxxxx';
  325. print "ok 72\n";
  326.  
  327. $_ = $t;
  328. pos = 6;
  329. s/\Ga/x/g;
  330. print "not " unless $_ eq 'aaaaaaxxx';
  331. print "ok 73\n";
  332.  
  333. $_ = $t;
  334. pos = 6;
  335. s/\Ga/xx/;
  336. print "not " unless $_ eq 'aaaaaaxxaa';
  337. print "ok 74\n";
  338.  
  339. $_ = $t;
  340. pos = 6;
  341. s/\Ga/x/;
  342. print "not " unless $_ eq 'aaaaaaxaa';
  343. print "ok 75\n";
  344.  
  345. $_ = $t;
  346. s/\Ga/xx/g;
  347. print "not " unless $_ eq 'xxxxxxxxxxxxxxxxxx';
  348. print "ok 76\n";
  349.  
  350. $_ = $t;
  351. s/\Ga/x/g;
  352. print "not " unless $_ eq 'xxxxxxxxx';
  353. print "ok 77\n";
  354.  
  355. $_ = $t;
  356. s/\Ga/xx/;
  357. print "not " unless $_ eq 'xxaaaaaaaa';
  358. print "ok 78\n";
  359.  
  360. $_ = $t;
  361. s/\Ga/x/;
  362. print "not " unless $_ eq 'xaaaaaaaa';
  363. print "ok 79\n";
  364.  
  365. $_ = 'aaaa';
  366. s/\ba/./g;
  367. print "#'$_'\nnot " unless $_ eq '.aaa';
  368. print "ok 80\n";
  369.  
  370. eval q% s/a/"b"}/e %;
  371. print ($@ =~ /Bad evalled substitution/ ? "ok 81\n" : "not ok 81\n");
  372. eval q% ($_ = "x") =~ s/(.)/"$1 "/e %;
  373. print +($_ eq "x " and !length $@) ? "ok 82\n" : "not ok 82\n# \$_ eq $_, $@\n";
  374. $x = $x = 'interp';
  375. eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %;
  376. print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n";
  377.  
  378. $_ = "C:/";
  379. s/^([a-z]:)/\u$1/ and print "not ";
  380. print "ok 84\n";
  381.  
  382.