1use 5.008001; 2 3use strict; 4use warnings; 5use Test::More; 6use Text::Balanced qw ( :ALL ); 7 8our $DEBUG; 9sub debug { print "\t>>>",@_ if $DEBUG } 10 11sub expect 12{ 13 my ($l1, $l2) = @_; 14 is_deeply $l1, $l2 or do { 15 diag 'got:', explain $l1; 16 diag 'expected:', explain $l2; 17 }; 18} 19 20sub divide 21{ 22 my ($text, @index) = @_; 23 my @bits = (); 24 unshift @index, 0; 25 push @index, length($text); 26 for ( my $i= 0; $i < $#index; $i++) 27 { 28 push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]); 29 } 30 pop @bits; 31 return @bits; 32 33} 34 35my $stdtext1 = q{$var = do {"val" && $val;};}; 36 37my $text = $stdtext1; 38expect [ extract_multiple($text,undef,1) ], 39 [ divide $stdtext1 => 4 ]; 40 41expect [ pos $text], [ 4 ]; 42expect [ $text ], [ $stdtext1 ]; 43 44$text = $stdtext1; 45expect [ scalar extract_multiple($text,undef,1) ], 46 [ divide $stdtext1 => 4 ]; 47 48expect [ pos $text], [ 0 ]; 49expect [ $text ], [ substr($stdtext1,4) ]; 50 51 52$text = $stdtext1; 53expect [ extract_multiple($text,undef,2) ], 54 [ divide($stdtext1 => 4, 10) ]; 55 56expect [ pos $text], [ 10 ]; 57expect [ $text ], [ $stdtext1 ]; 58 59$text = $stdtext1; 60expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ], 61 [ substr($stdtext1,0,4) ]; 62 63expect [ pos $text], [ 0 ]; 64expect [ $text ], [ substr($stdtext1,4) ]; 65 66 67$text = $stdtext1; 68expect [ extract_multiple($text,undef,3) ], 69 [ divide($stdtext1 => 4, 10, 26) ]; 70 71expect [ pos $text], [ 26 ]; 72expect [ $text ], [ $stdtext1 ]; 73 74$text = $stdtext1; 75expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ], 76 [ substr($stdtext1,0,4) ]; 77 78expect [ pos $text], [ 0 ]; 79expect [ $text ], [ substr($stdtext1,4) ]; 80 81 82$text = $stdtext1; 83expect [ extract_multiple($text,undef,4) ], 84 [ divide($stdtext1 => 4, 10, 26, 27) ]; 85 86expect [ pos $text], [ 27 ]; 87expect [ $text ], [ $stdtext1 ]; 88 89$text = $stdtext1; 90expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ], 91 [ substr($stdtext1,0,4) ]; 92 93expect [ pos $text], [ 0 ]; 94expect [ $text ], [ substr($stdtext1,4) ]; 95 96 97$text = $stdtext1; 98expect [ extract_multiple($text,undef,5) ], 99 [ divide($stdtext1 => 4, 10, 26, 27) ]; 100 101expect [ pos $text], [ 27 ]; 102expect [ $text ], [ $stdtext1 ]; 103 104 105$text = $stdtext1; 106expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ], 107 [ substr($stdtext1,0,4) ]; 108 109expect [ pos $text], [ 0 ]; 110expect [ $text ], [ substr($stdtext1,4) ]; 111 112 113 114my $stdtext2 = q{$var = "val" && (1,2,3);}; 115 116$text = $stdtext2; 117expect [ extract_multiple($text) ], 118 [ divide($stdtext2 => 4, 7, 12, 24) ]; 119 120expect [ pos $text], [ 24 ]; 121expect [ $text ], [ $stdtext2 ]; 122 123$text = $stdtext2; 124expect [ scalar extract_multiple($text) ], 125 [ substr($stdtext2,0,4) ]; 126 127expect [ pos $text], [ 0 ]; 128expect [ $text ], [ substr($stdtext2,4) ]; 129 130 131$text = $stdtext2; 132expect [ extract_multiple($text,[\&extract_bracketed]) ], 133 [ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ]; 134 135expect [ pos $text], [ 24 ]; 136expect [ $text ], [ $stdtext2 ]; 137 138$text = $stdtext2; 139expect [ scalar extract_multiple($text,[\&extract_bracketed]) ], 140 [ substr($stdtext2,0,16) ]; 141 142expect [ pos $text], [ 0 ]; 143expect [ $text ], [ substr($stdtext2,15) ]; 144 145 146$text = $stdtext2; 147expect [ extract_multiple($text,[\&extract_variable]) ], 148 [ substr($stdtext2,0,4), substr($stdtext2,4) ]; 149 150expect [ pos $text], [ length($text) ]; 151expect [ $text ], [ $stdtext2 ]; 152 153$text = $stdtext2; 154expect [ scalar extract_multiple($text,[\&extract_variable]) ], 155 [ substr($stdtext2,0,4) ]; 156 157expect [ pos $text], [ 0 ]; 158expect [ $text ], [ substr($stdtext2,4) ]; 159 160 161$text = $stdtext2; 162expect [ extract_multiple($text,[\&extract_quotelike]) ], 163 [ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ]; 164 165expect [ pos $text], [ length($text) ]; 166expect [ $text ], [ $stdtext2 ]; 167 168$text = $stdtext2; 169expect [ scalar extract_multiple($text,[\&extract_quotelike]) ], 170 [ substr($stdtext2,0,7) ]; 171 172expect [ pos $text], [ 0 ]; 173expect [ $text ], [ substr($stdtext2,6) ]; 174 175 176$text = $stdtext2; 177expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], 178 [ substr($stdtext2,7,5) ]; 179 180expect [ pos $text], [ 23 ]; 181expect [ $text ], [ $stdtext2 ]; 182 183$text = $stdtext2; 184expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ], 185 [ substr($stdtext2,7,5) ]; 186 187expect [ pos $text], [ 6 ]; 188expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; 189 190 191$text = $stdtext2; 192expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], 193 [ substr($stdtext2,7,5) ]; 194 195expect [ pos $text], [ 12 ]; 196expect [ $text ], [ $stdtext2 ]; 197 198$text = $stdtext2; 199expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], 200 [ substr($stdtext2,7,5) ]; 201 202expect [ pos $text], [ 6 ]; 203expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; 204 205my $stdtext3 = "a,b,c"; 206 207$_ = $stdtext3; 208expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], 209 [ divide($stdtext3 => 1,2,3,4,5) ]; 210 211expect [ pos ], [ 5 ]; 212expect [ $_ ], [ $stdtext3 ]; 213 214$_ = $stdtext3; 215expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], 216 [ divide($stdtext3 => 1) ]; 217 218expect [ pos ], [ 0 ]; 219expect [ $_ ], [ substr($stdtext3,1) ]; 220 221$_ = $stdtext3; 222expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], 223 [ divide($stdtext3 => 1,2,3,4,5) ]; 224 225expect [ pos ], [ 5 ]; 226expect [ $_ ], [ $stdtext3 ]; 227 228$_ = $stdtext3; 229expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], 230 [ divide($stdtext3 => 1) ]; 231 232expect [ pos ], [ 0 ]; 233expect [ $_ ], [ substr($stdtext3,1) ]; 234 235$_ = $stdtext3; 236expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], 237 [ qw(a b c) ]; 238 239expect [ pos ], [ 5 ]; 240expect [ $_ ], [ $stdtext3 ]; 241 242$_ = $stdtext3; 243expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], 244 [ divide($stdtext3 => 1) ]; 245 246expect [ pos ], [ 0 ]; 247expect [ $_ ], [ substr($stdtext3,2) ]; 248 249# Fails in Text-Balanced-1.95 with result ['1 ', '""', '1234'] 250$_ = q{ ""1234}; 251expect [ extract_multiple(undef, [\&extract_quotelike]) ], 252 [ ' ', '""', '1234' ]; 253 254my $not_here_doc = "sub f {\n my \$pa <<= 2;\n}\n\n"; # wrong in 2.04 255expect [ extract_multiple($not_here_doc, [ 256 { DONT_MATCH => \&extract_quotelike } 257]) ], 258 [ "sub f {\n my \$pa <<= 2;\n}\n\n" ]; 259 260my $y_falsematch = <<'EOF'; # wrong in 2.04 261my $p = {y => 1}; 262{ $pa=ones(3,3,3); my $f = do { my $i=1; my $v=$$p{y}-$i; $pb = $pa(,$i,) }; } 263EOF 264expect [ extract_multiple($y_falsematch, [ 265 \&extract_variable, 266 { DONT_MATCH => \&extract_quotelike } 267]) ], 268 [ 'my ', '$p', " = {y => 1};\n{ ", '$pa', '=ones(3,3,3); my ', '$f', 269 ' = do { my ', '$i', '=1; my ', '$v', qw(= $$p{y} - $i), '; ', '$pb', 270 ' = ', '$pa', '(,', '$i', ",) }; }\n", 271 ]; 272 273my $slashmatch = <<'EOF'; # wrong in 2.04 274my $var = 10 / 3; if ($var !~ /\./) { decimal() ;} 275EOF 276my @expect_slash = ('my ', '$var', ' = 10 / 3; if (', '$var', " !~ ", 277 '/\\./', ") { decimal() ;}\n" 278); 279expect [ extract_multiple($slashmatch, [ 280 \&extract_variable, 281 \&extract_quotelike, 282]) ], 283 \@expect_slash; 284 285$slashmatch = <<'EOF'; # wrong in 2.04 286my $var = 10 / 3; if ($var =~ /\./) { decimal() ;} 287EOF 288$expect_slash[4] = " =~ "; 289expect [ extract_multiple($slashmatch, [ 290 \&extract_variable, 291 \&extract_quotelike, 292]) ], 293 \@expect_slash; 294 295$slashmatch = <<'EOF'; # wrong in 2.04 296my $var = 10 / 3; if ($var =~ 297 # a comment 298 /\./) { decimal() ;} 299EOF 300my $comment = qr/(?<![\$\@%])#.*/; 301my $id = qr/\b(?!([ysm]|q[rqxw]?|tr)\b)\w+/; 302expect [ extract_multiple($slashmatch, [ 303 $comment, 304 \&extract_variable, 305 $id, 306 \&extract_quotelike, 307]) ], 308 [ 'my', ' ', '$var', ' = ', '10', ' / ', '3', '; ', 'if', ' (', '$var', 309 " =~\n ", '# a comment', "\n ", '/\\./', ') { ', 'decimal', "() ;}\n" 310 ]; 311 312$slashmatch = <<'EOF'; # wrong in 2.04_01 313my $r=(1-$PCi)/1+czip(1, -1)/czip(1, 1); 314EOF 315expect [ extract_multiple($slashmatch, [ 316 \&extract_variable, $id, \&extract_quotelike, 317]) ], 318 [ 319 'my', ' ', '$r', '=(', '1', '-', '$PCi', ')/', '1', '+', 320 'czip', '(', '1', ', -', '1', ')/', 321 'czip', '(', '1', ', ', '1', ");\n" 322 ]; 323 324$slashmatch = <<'EOF'; # wrong in 2.04_01 325$ndim--; $min = $mdim <= $ndim ? 1 : 0; $min = $mdim < $ndim ? 1 : 0; 326EOF 327expect [ extract_multiple($slashmatch, [ 328 \&extract_variable, $id, \&extract_quotelike, 329]) ], 330 [ 331 '$ndim', '--; ', 332 '$min', ' = ', '$mdim', ' <= ', '$ndim', ' ? ', '1', ' : ', '0', '; ', 333 '$min', ' = ', '$mdim', ' < ', '$ndim', ' ? ', '1', ' : ', '0', ";\n" 334 ]; 335 336$slashmatch = <<'EOF'; # wrong in 2.04_01 337$x->t->(($a))->sever; 338wantarray ? 1 : 0; $min = $var ? 0; 339EOF 340expect [ extract_multiple($slashmatch, [ 341 \&extract_variable, $id, \&extract_quotelike, 342]) ], 343 [ 344 '$x->t->(($a))->sever', ";\n", 345 'wantarray', ' ? ', '1', ' : ', '0', '; ', 346 '$min', ' = ', '$var', ' ? ', '0', ";\n", 347 ]; 348 349$slashmatch = <<'EOF'; # wrong in 2.04_01 350$var //= 'default'; $x = 1 / 2; 351EOF 352expect [ extract_multiple($slashmatch, [ 353 \&extract_variable, \&extract_quotelike, 354]) ], 355 [ 356 '$var', ' //= ', '\'default\'', '; ', '$x', " = 1 / 2;\n" 357 ]; 358 359$slashmatch = <<'EOF'; # wrong in 2.04_01 360$m; return wantarray ? ($m, $i) : $var ? $m : 0; 361EOF 362expect [ extract_multiple($slashmatch, [ 363 \&extract_variable, \&extract_quotelike, 364]) ], 365 [ 366 '$m', 367 '; return wantarray ? (', '$m', ', ', '$i', ') : ', '$var', ' ? ', '$m', 368 " : 0;\n" 369 ]; 370 371$slashmatch = <<'EOF'; # wrong in 2.05 372$_ = 1 unless defined $_ and /\d\b/; 373EOF 374expect [ extract_multiple($slashmatch, [ 375 \&extract_variable, \&extract_quotelike, 376]) ], 377 [ '$_', ' = 1 unless defined ', '$_', ' and ', '/\\d\\b/', ";\n" ]; 378 379done_testing; 380