1256a93a4Safresh1use 5.008001; 2256a93a4Safresh1 3256a93a4Safresh1use strict; 4256a93a4Safresh1use warnings; 5*f2a19305Safresh1use Test::More; 6b39c5158Smillertuse Text::Balanced qw ( extract_codeblock ); 7b39c5158Smillert 8*f2a19305Safresh1our $DEBUG; 9*f2a19305Safresh1sub debug { print "\t>>>",@_ if $DEBUG } 10b39c5158Smillert 11256a93a4Safresh1## no critic (BuiltinFunctions::ProhibitStringyEval) 12b39c5158Smillert 13256a93a4Safresh1my $cmd = "print"; 14256a93a4Safresh1my $neg = 0; 15256a93a4Safresh1my $str; 16b39c5158Smillertwhile (defined($str = <DATA>)) 17b39c5158Smillert{ 18b39c5158Smillert chomp $str; 19b39c5158Smillert if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } 20b39c5158Smillert elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } 21b39c5158Smillert elsif (!$str || $str =~ /\A#/) { $neg = 0; next } 22*f2a19305Safresh1 my $orig_str = $str; 23b39c5158Smillert $str =~ s/\\n/\n/g; 24b39c5158Smillert debug "\tUsing: $cmd\n"; 25b39c5158Smillert debug "\t on: [$str]\n"; 26b39c5158Smillert 27b39c5158Smillert my @res; 28256a93a4Safresh1 my $var = eval "\@res = $cmd"; 29*f2a19305Safresh1 is $@, '', 'no error'; 30b39c5158Smillert debug "\t list got: [" . join("|", map {defined $_ ? $_ : '<undef>'} @res) . "]\n"; 31b39c5158Smillert debug "\t list left: [$str]\n"; 32*f2a19305Safresh1 ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); 33b39c5158Smillert 34b39c5158Smillert pos $str = 0; 35b39c5158Smillert $var = eval $cmd; 36*f2a19305Safresh1 is $@, '', 'no error'; 37b39c5158Smillert $var = "<undef>" unless defined $var; 38b39c5158Smillert debug "\t scalar got: [$var]\n"; 39b39c5158Smillert debug "\t scalar left: [$str]\n"; 40*f2a19305Safresh1 ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); 41b39c5158Smillert} 42b39c5158Smillert 43*f2a19305Safresh1my $grammar = <<'EOF'; 44*f2a19305Safresh1given 2 { when __ < 1 { ok(0) } else { ok(1) } } 45*f2a19305Safresh1EOF 46*f2a19305Safresh1pos $grammar = 8; 47*f2a19305Safresh1my ($out) = Text::Balanced::_match_codeblock(\$grammar,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef); 48*f2a19305Safresh1ok $out, 'Switch error from calling _match_codeblock'; 49*f2a19305Safresh1 50*f2a19305Safresh1$grammar = <<'EOF'; 51*f2a19305Safresh1comment: m/a/ 52*f2a19305Safresh1enum_list: (/b/) 53*f2a19305Safresh1EOF 54*f2a19305Safresh1pos $grammar = 10; 55*f2a19305Safresh1($out) = Text::Balanced::extract_quotelike($grammar); 56*f2a19305Safresh1is $out, 'm/a/', 'PRD error (setup for real error)'; 57*f2a19305Safresh1pos $grammar = 26; 58*f2a19305Safresh1($out) = extract_codeblock($grammar,'{([',undef,'(',1); 59*f2a19305Safresh1is $out, '(/b/)', 'PRD error'; 60*f2a19305Safresh1 61*f2a19305Safresh1done_testing; 62*f2a19305Safresh1 63b39c5158Smillert__DATA__ 64b39c5158Smillert 65b39c5158Smillert# USING: extract_codeblock($str,'(){}',undef,'()'); 66b39c5158Smillert(Foo(')')); 67b39c5158Smillert 68b39c5158Smillert# USING: extract_codeblock($str); 69b39c5158Smillert{ $data[4] =~ /['"]/; }; 70*f2a19305Safresh1{1<<2}; 71*f2a19305Safresh1{1<<2};\n 72*f2a19305Safresh1{1<<2};\n\n 73*f2a19305Safresh1{ $a = /\}/; }; 74*f2a19305Safresh1{ sub { $_[0] /= $_[1] } }; # / here 75*f2a19305Safresh1{ 1; }; 76*f2a19305Safresh1{ $a = 1; }; 77b39c5158Smillert 78b39c5158Smillert# USING: extract_codeblock($str,'<>'); 79b39c5158Smillert< %x = ( try => "this") >; 80b39c5158Smillert< %x = () >; 81b39c5158Smillert< %x = ( $try->{this}, "too") >; 82b39c5158Smillert< %'x = ( $try->{this}, "too") >; 83b39c5158Smillert< %'x'y = ( $try->{this}, "too") >; 84b39c5158Smillert< %::x::y = ( $try->{this}, "too") >; 85b39c5158Smillert 86b39c5158Smillert# THIS SHOULD FAIL 87b39c5158Smillert< %x = do { $try > 10 } >; 88b39c5158Smillert 89*f2a19305Safresh1# USING: extract_codeblock($str, '()'); 90*f2a19305Safresh1(($x || 2)); split /z/, $y 91*f2a19305Safresh1(($x // 2)); split /z/, $y 92b39c5158Smillert 93b39c5158Smillert# USING: extract_codeblock($str,undef,'=*'); 94b39c5158Smillert========{$a=1}; 95b39c5158Smillert 96b39c5158Smillert# USING: extract_codeblock($str,'{}<>'); 97b39c5158Smillert< %x = do { $try > 10 } >; 98b39c5158Smillert 99b39c5158Smillert# USING: extract_codeblock($str,'{}',undef,'<>'); 100b39c5158Smillert< %x = do { $try > 10 } >; 101b39c5158Smillert 102b39c5158Smillert# USING: extract_codeblock($str,'{}'); 103b39c5158Smillert{ $a = $b; # what's this doing here? \n };' 104b39c5158Smillert{ $a = $b; \n $a =~ /$b/; \n @a = map /\s/ @b }; 105b39c5158Smillert 106b39c5158Smillert# THIS SHOULD FAIL 107b39c5158Smillert{ $a = $b; # what's this doing here? };' 108b39c5158Smillert{ $a = $b; # what's this doing here? ;' 109