1256a93a4Safresh1use 5.008001; 2256a93a4Safresh1 3256a93a4Safresh1use strict; 4256a93a4Safresh1use warnings; 5*f2a19305Safresh1use Test::More; 6*f2a19305Safresh1use Text::Balanced qw ( extract_delimited extract_multiple ); 7256a93a4Safresh1 8*f2a19305Safresh1our $DEBUG; 9b39c5158Smillertsub 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 27256a93a4Safresh1 my $var = eval "() = $cmd"; 28*f2a19305Safresh1 is $@, '', 'no error'; 29b39c5158Smillert debug "\t list got: [$var]\n"; 30b39c5158Smillert debug "\t list left: [$str]\n"; 31*f2a19305Safresh1 ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); 32b39c5158Smillert 33b39c5158Smillert pos $str = 0; 34b39c5158Smillert $var = eval $cmd; 35*f2a19305Safresh1 is $@, '', 'no error'; 36b39c5158Smillert $var = "<undef>" unless defined $var; 37b39c5158Smillert debug "\t scalar got: [$var]\n"; 38b39c5158Smillert debug "\t scalar left: [$str]\n"; 39*f2a19305Safresh1 ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); 40b39c5158Smillert} 41b39c5158Smillert 42*f2a19305Safresh1my $text = 'while($a == "test"){ print "true";}'; 43*f2a19305Safresh1my ($extracted, $remainder) = extract_delimited($text, '#'); 44*f2a19305Safresh1ok '' ne $@, 'string overload should not crash'; 45*f2a19305Safresh1 46*f2a19305Safresh1$text = "a,'x b',c"; 47*f2a19305Safresh1my @fields = extract_multiple($text, 48*f2a19305Safresh1 [ 49*f2a19305Safresh1 sub { extract_delimited($_[0],q{'"}) }, 50*f2a19305Safresh1 qr/([^,]+)/, 51*f2a19305Safresh1 ], 52*f2a19305Safresh1 undef,1); 53*f2a19305Safresh1is_deeply \@fields, ['a', "'x b'", 'c'] or diag 'got: ', explain \@fields; 54*f2a19305Safresh1 55*f2a19305Safresh1done_testing; 56*f2a19305Safresh1 57b39c5158Smillert__DATA__ 58b39c5158Smillert# USING: extract_delimited($str,'/#$',undef,'/#$'); 59b39c5158Smillert/a/; 60b39c5158Smillert/a///; 61b39c5158Smillert#b#; 62b39c5158Smillert#b###; 63b39c5158Smillert$c$; 64b39c5158Smillert$c$$$; 65b39c5158Smillert 66b39c5158Smillert# TEST EXTRACTION OF DELIMITED TEXT WITH ESCAPES 67b39c5158Smillert# USING: extract_delimited($str,'/#$',undef,'\\'); 68b39c5158Smillert/a/; 69b39c5158Smillert/a\//; 70b39c5158Smillert#b#; 71b39c5158Smillert#b\##; 72b39c5158Smillert$c$; 73b39c5158Smillert$c\$$; 74b39c5158Smillert 75b39c5158Smillert# TEST EXTRACTION OF DELIMITED TEXT 76b39c5158Smillert# USING: extract_delimited($str); 77b39c5158Smillert'a'; 78b39c5158Smillert"b"; 79b39c5158Smillert`c`; 80b39c5158Smillert'a\''; 81b39c5158Smillert'a\\'; 82b39c5158Smillert'\\a'; 83b39c5158Smillert"a\\"; 84b39c5158Smillert"\\a"; 85b39c5158Smillert"b\'\"\'"; 86b39c5158Smillert`c '\`abc\`'`; 87b39c5158Smillert 88b39c5158Smillert# TEST EXTRACTION OF DELIMITED TEXT 89b39c5158Smillert# USING: extract_delimited($str,'/#$','-->'); 90b39c5158Smillert-->/a/; 91b39c5158Smillert-->#b#; 92b39c5158Smillert-->$c$; 93b39c5158Smillert 94b39c5158Smillert# THIS SHOULD FAIL 95b39c5158Smillert$c$; 96