home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / substr.t < prev    next >
Text File  |  2000-02-20  |  8KB  |  271 lines
  1.  
  2. print "1..125\n";
  3.  
  4. #P = start of string  Q = start of substr  R = end of substr  S = end of string
  5.  
  6. BEGIN {
  7.     unshift @INC, '../lib' if -d '../lib' ;
  8. }
  9. use warnings ;
  10.  
  11. $a = 'abcdefxyz';
  12. $SIG{__WARN__} = sub {
  13.      if ($_[0] =~ /^substr outside of string/) {
  14.           $w++;
  15.      } elsif ($_[0] =~ /^Attempt to use reference as lvalue in substr/) {
  16.           $w += 2;
  17.      } elsif ($_[0] =~ /^Use of uninitialized value/) {
  18.           $w += 3;
  19.      } else {
  20.           warn $_[0];
  21.      }
  22. };
  23.  
  24. sub ok { print (($_[1] ? "" : "not ") . "ok $_[0]\n") }
  25.  
  26. $FATAL_MSG = '^substr outside of string' ;
  27.  
  28. ok 1, substr($a,0,3) eq 'abc';   # P=Q R S
  29. ok 2, substr($a,3,3) eq 'def';   # P Q R S
  30. ok 3, substr($a,6,999) eq 'xyz'; # P Q S R
  31. $b = substr($a,999,999) ; # warn # P R Q S
  32. ok 4, $w-- == 1 ;
  33. eval{substr($a,999,999) = "" ; };# P R Q S
  34. ok 5, $@ =~ /$FATAL_MSG/;
  35. ok 6, substr($a,0,-6) eq 'abc';  # P=Q R S
  36. ok 7, substr($a,-3,1) eq 'x';    # P Q R S
  37.  
  38. $[ = 1;
  39.  
  40. ok 8, substr($a,1,3) eq 'abc' ;  # P=Q R S
  41. ok 9, substr($a,4,3) eq 'def' ;  # P Q R S
  42. ok 10, substr($a,7,999) eq 'xyz';# P Q S R
  43. $b = substr($a,999,999) ; # warn # P R Q S
  44. ok 11, $w-- == 1 ;
  45. eval{substr($a,999,999) = "" ; } ; # P R Q S
  46. ok 12, $@ =~ /$FATAL_MSG/;
  47. ok 13, substr($a,1,-6) eq 'abc' ;# P=Q R S
  48. ok 14, substr($a,-3,1) eq 'x' ;  # P Q R S
  49.  
  50. $[ = 0;
  51.  
  52. substr($a,3,3) = 'XYZ';
  53. ok 15, $a eq 'abcXYZxyz' ;
  54. substr($a,0,2) = '';
  55. ok 16, $a eq 'cXYZxyz' ;
  56. substr($a,0,0) = 'ab';
  57. ok 17, $a eq 'abcXYZxyz' ;
  58. substr($a,0,0) = '12345678';
  59. ok 18, $a eq '12345678abcXYZxyz' ;
  60. substr($a,-3,3) = 'def';
  61. ok 19, $a eq '12345678abcXYZdef';
  62. substr($a,-3,3) = '<';
  63. ok 20, $a eq '12345678abcXYZ<' ;
  64. substr($a,-1,1) = '12345678';
  65. ok 21, $a eq '12345678abcXYZ12345678' ;
  66.  
  67. $a = 'abcdefxyz';
  68.  
  69. ok 22, substr($a,6) eq 'xyz' ;        # P Q R=S
  70. ok 23, substr($a,-3) eq 'xyz' ;       # P Q R=S
  71. $b = substr($a,999,999) ; # warning   # P R=S Q
  72. ok 24, $w-- == 1 ;
  73. eval{substr($a,999,999) = "" ; } ;    # P R=S Q
  74. ok 25, $@ =~ /$FATAL_MSG/;
  75. ok 26, substr($a,0) eq 'abcdefxyz' ;  # P=Q R=S
  76. ok 27, substr($a,9) eq '' ;           # P Q=R=S
  77. ok 28, substr($a,-11) eq 'abcdefxyz'; # Q P R=S
  78. ok 29, substr($a,-9) eq 'abcdefxyz';  # P=Q R=S
  79.  
  80. $a = '54321';
  81.  
  82. $b = substr($a,-7, 1) ; # warn  # Q R P S
  83. ok 30, $w-- == 1 ;
  84. eval{substr($a,-7, 1) = "" ; }; # Q R P S
  85. ok 31, $@ =~ /$FATAL_MSG/;
  86. $b = substr($a,-7,-6) ; # warn  # Q R P S
  87. ok 32, $w-- == 1 ;
  88. eval{substr($a,-7,-6) = "" ; }; # Q R P S
  89. ok 33, $@ =~ /$FATAL_MSG/;
  90. ok 34, substr($a,-5,-7) eq '';  # R P=Q S
  91. ok 35, substr($a, 2,-7) eq '';  # R P Q S
  92. ok 36, substr($a,-3,-7) eq '';  # R P Q S
  93. ok 37, substr($a, 2,-5) eq '';  # P=R Q S
  94. ok 38, substr($a,-3,-5) eq '';  # P=R Q S
  95. ok 39, substr($a, 2,-4) eq '';  # P R Q S
  96. ok 40, substr($a,-3,-4) eq '';  # P R Q S
  97. ok 41, substr($a, 5,-6) eq '';  # R P Q=S
  98. ok 42, substr($a, 5,-5) eq '';  # P=R Q S
  99. ok 43, substr($a, 5,-3) eq '';  # P R Q=S
  100. $b = substr($a, 7,-7) ; # warn  # R P S Q
  101. ok 44, $w-- == 1 ;
  102. eval{substr($a, 7,-7) = "" ; }; # R P S Q
  103. ok 45, $@ =~ /$FATAL_MSG/;
  104. $b = substr($a, 7,-5) ; # warn  # P=R S Q
  105. ok 46, $w-- == 1 ;
  106. eval{substr($a, 7,-5) = "" ; }; # P=R S Q
  107. ok 47, $@ =~ /$FATAL_MSG/;
  108. $b = substr($a, 7,-3) ; # warn  # P Q S Q
  109. ok 48, $w-- == 1 ;
  110. eval{substr($a, 7,-3) = "" ; }; # P Q S Q
  111. ok 49, $@ =~ /$FATAL_MSG/;
  112. $b = substr($a, 7, 0) ; # warn  # P S Q=R
  113. ok 50, $w-- == 1 ;
  114. eval{substr($a, 7, 0) = "" ; }; # P S Q=R
  115. ok 51, $@ =~ /$FATAL_MSG/;
  116.  
  117. ok 52, substr($a,-7,2) eq '';   # Q P=R S
  118. ok 53, substr($a,-7,4) eq '54'; # Q P R S
  119. ok 54, substr($a,-7,7) eq '54321';# Q P R=S
  120. ok 55, substr($a,-7,9) eq '54321';# Q P S R
  121. ok 56, substr($a,-5,0) eq '';   # P=Q=R S
  122. ok 57, substr($a,-5,3) eq '543';# P=Q R S
  123. ok 58, substr($a,-5,5) eq '54321';# P=Q R=S
  124. ok 59, substr($a,-5,7) eq '54321';# P=Q S R
  125. ok 60, substr($a,-3,0) eq '';   # P Q=R S
  126. ok 61, substr($a,-3,3) eq '321';# P Q R=S
  127. ok 62, substr($a,-2,3) eq '21'; # P Q S R
  128. ok 63, substr($a,0,-5) eq '';   # P=Q=R S
  129. ok 64, substr($a,2,-3) eq '';   # P Q=R S
  130. ok 65, substr($a,0,0) eq '';    # P=Q=R S
  131. ok 66, substr($a,0,5) eq '54321';# P=Q R=S
  132. ok 67, substr($a,0,7) eq '54321';# P=Q S R
  133. ok 68, substr($a,2,0) eq '';    # P Q=R S
  134. ok 69, substr($a,2,3) eq '321'; # P Q R=S
  135. ok 70, substr($a,5,0) eq '';    # P Q=R=S
  136. ok 71, substr($a,5,2) eq '';    # P Q=S R
  137. ok 72, substr($a,-7,-5) eq '';  # Q P=R S
  138. ok 73, substr($a,-7,-2) eq '543';# Q P R S
  139. ok 74, substr($a,-5,-5) eq '';  # P=Q=R S
  140. ok 75, substr($a,-5,-2) eq '543';# P=Q R S
  141. ok 76, substr($a,-3,-3) eq '';  # P Q=R S
  142. ok 77, substr($a,-3,-1) eq '32';# P Q R S
  143.  
  144. $a = '';
  145.  
  146. ok 78, substr($a,-2,2) eq '';   # Q P=R=S
  147. ok 79, substr($a,0,0) eq '';    # P=Q=R=S
  148. ok 80, substr($a,0,1) eq '';    # P=Q=S R
  149. ok 81, substr($a,-2,3) eq '';   # Q P=S R
  150. ok 82, substr($a,-2) eq '';     # Q P=R=S
  151. ok 83, substr($a,0) eq '';      # P=Q=R=S
  152.  
  153.  
  154. ok 84, substr($a,0,-1) eq '';   # R P=Q=S
  155. $b = substr($a,-2, 0) ; # warn  # Q=R P=S
  156. ok 85, $w-- == 1 ;
  157. eval{substr($a,-2, 0) = "" ; }; # Q=R P=S
  158. ok 86, $@ =~ /$FATAL_MSG/;
  159.  
  160. $b = substr($a,-2, 1) ; # warn  # Q R P=S
  161. ok 87, $w-- == 1 ;
  162. eval{substr($a,-2, 1) = "" ; }; # Q R P=S
  163. ok 88, $@ =~ /$FATAL_MSG/;
  164.  
  165. $b = substr($a,-2,-1) ; # warn  # Q R P=S
  166. ok 89, $w-- == 1 ;
  167. eval{substr($a,-2,-1) = "" ; }; # Q R P=S
  168. ok 90, $@ =~ /$FATAL_MSG/;
  169.  
  170. $b = substr($a,-2,-2) ; # warn  # Q=R P=S
  171. ok 91, $w-- == 1 ;
  172. eval{substr($a,-2,-2) = "" ; }; # Q=R P=S
  173. ok 92, $@ =~ /$FATAL_MSG/;
  174.  
  175. $b = substr($a, 1,-2) ; # warn  # R P=S Q
  176. ok 93, $w-- == 1 ;
  177. eval{substr($a, 1,-2) = "" ; }; # R P=S Q
  178. ok 94, $@ =~ /$FATAL_MSG/;
  179.  
  180. $b = substr($a, 1, 1) ; # warn  # P=S Q R
  181. ok 95, $w-- == 1 ;
  182. eval{substr($a, 1, 1) = "" ; }; # P=S Q R
  183. ok 96, $@ =~ /$FATAL_MSG/;
  184.  
  185. $b = substr($a, 1, 0) ;# warn   # P=S Q=R
  186. ok 97, $w-- == 1 ;
  187. eval{substr($a, 1, 0) = "" ; }; # P=S Q=R
  188. ok 98, $@ =~ /$FATAL_MSG/;
  189.  
  190. $b = substr($a,1) ; # warning   # P=R=S Q
  191. ok 99, $w-- == 1 ;
  192. eval{substr($a,1) = "" ; };     # P=R=S Q
  193. ok 100, $@ =~ /$FATAL_MSG/;
  194.  
  195. my $a = 'zxcvbnm';
  196. substr($a,2,0) = '';
  197. ok 101, $a eq 'zxcvbnm';
  198. substr($a,7,0) = '';
  199. ok 102, $a eq 'zxcvbnm';
  200. substr($a,5,0) = '';
  201. ok 103, $a eq 'zxcvbnm';
  202. substr($a,0,2) = 'pq';
  203. ok 104, $a eq 'pqcvbnm';
  204. substr($a,2,0) = 'r';
  205. ok 105, $a eq 'pqrcvbnm';
  206. substr($a,8,0) = 'asd';
  207. ok 106, $a eq 'pqrcvbnmasd';
  208. substr($a,0,2) = 'iop';
  209. ok 107, $a eq 'ioprcvbnmasd';
  210. substr($a,0,5) = 'fgh';
  211. ok 108, $a eq 'fghvbnmasd';
  212. substr($a,3,5) = 'jkl';
  213. ok 109, $a eq 'fghjklsd';
  214. substr($a,3,2) = '1234';
  215. ok 110, $a eq 'fgh1234lsd';
  216.  
  217.  
  218. # with lexicals (and in re-entered scopes)
  219. for (0,1) {
  220.   my $txt;
  221.   unless ($_) {
  222.     $txt = "Foo";
  223.     substr($txt, -1) = "X";
  224.     ok 111, $txt eq "FoX";
  225.   }
  226.   else {
  227.     substr($txt, 0, 1) = "X";
  228.     ok 112, $txt eq "X";
  229.   }
  230. }
  231.  
  232. $w = 0 ;
  233. # coercion of references
  234. {
  235.   my $s = [];
  236.   substr($s, 0, 1) = 'Foo';
  237.   ok 113, substr($s,0,7) eq "FooRRAY" && !($w-=2);
  238. }
  239.  
  240. # check no spurious warnings
  241. ok 114, $w == 0;
  242.  
  243. # check new 4 arg replacement syntax
  244. $a = "abcxyz";
  245. $w = 0;
  246. ok 115, substr($a, 0, 3, "") eq "abc" && $a eq "xyz";
  247. ok 116, substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz";
  248. ok 117, substr($a, 3, -1, "") eq "xy" && $a eq "abcz";
  249.  
  250. ok 118, substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz"
  251.                  && $w == 3;
  252.  
  253. $w = 0;
  254.  
  255. ok 119, substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc";
  256. eval{substr($a, -99, 0, "") };
  257. ok 120, $@ =~ /$FATAL_MSG/;
  258. eval{substr($a, 99, 3, "") };
  259. ok 121, $@ =~ /$FATAL_MSG/;
  260.  
  261. substr($a, 0, length($a), "foo");
  262. ok 122, $a eq "foo" && !$w;
  263.  
  264. # using 4 arg substr as lvalue is a compile time error
  265. eval 'substr($a,0,0,"") = "abc"';
  266. ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo";
  267.  
  268. $a = "abcdefgh";
  269. ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd';
  270. ok 125, $a eq 'xxxxefgh';
  271.