dslinux/user/perl/lib/Text/Balanced/t extbrk.t extcbk.t extdel.t extmul.t extqlk.t exttag.t extvar.t gentag.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:12 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/lib/Text/Balanced/t
In directory antilope:/tmp/cvs-serv17422/lib/Text/Balanced/t

Added Files:
	extbrk.t extcbk.t extdel.t extmul.t extqlk.t exttag.t extvar.t 
	gentag.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: exttag.t ---
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir('t') if -d 't';
        @INC = qw(../lib);
    }
}

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..53\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( extract_tagged gen_extract_tagged );
$loaded = 1;
print "ok 1\n";
$count=2;
use vars qw( $DEBUG );
sub debug { print "\t>>>", at _ if $DEBUG }

######################### End of black magic.


$cmd = "print";
$neg = 0;
while (defined($str = <DATA>))
{
	chomp $str;
	if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
	elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
	elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
	$str =~ s/\\n/\n/g;
	debug "\tUsing: $cmd\n";
	debug "\t   on: [$str]\n";

	my @res;
	$var = eval "\@res = $cmd";
	debug "\t list got: [" . join("|", at res) . "]\n";
	debug "\t list left: [$str]\n";
	print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";

	pos $str = 0;
	$var = eval $cmd;
	$var = "<undef>" unless defined $var;
	debug "\t scalar got: [$var]\n";
	debug "\t scalar left: [$str]\n";
	print "not " if ($str =~ '\A;')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";
}

__DATA__
# USING: gen_extract_tagged("BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)")->($str);
	ignore\n this and then BEGINHERE at the ENDHERE;
	ignore\n this and then BEGINTHIS at the ENDTHIS;

# USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)");
	ignore\n this and then BEGINHERE at the ENDHERE;
	ignore\n this and then BEGINTHIS at the ENDTHIS;

# USING: extract_tagged($str,"BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)");
	ignore\n this and then BEGINHERE at the ENDHERE;
	ignore\n this and then BEGINTHIS at the ENDTHIS;

# THIS SHOULD FAIL
	ignore\n this and then BEGINTHIS at the ENDTHAT;

# USING: extract_tagged($str,"BEGIN","END","(?s).*?(?=BEGIN)");
	ignore\n this and then BEGIN at the END;

# USING: extract_tagged($str);
	<A-1 HREF="#section2">some text</A-1>;

# USING: extract_tagged($str,qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]});
	<A>aaa<B>bbb<BR>ccc</B>ddd</A>;

# USING: extract_tagged($str,"BEGIN","END");
	BEGIN at the BEGIN keyword and END at the END;
	BEGIN at the beginning and end at the END;

# USING: extract_tagged($str,undef,undef,undef,{ignore=>["<[^>]*/>"]});
	<A>aaa<B>bbb<BR/>ccc</B>ddd</A>;

# USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"MAX"});
	; at the ;-) keyword

# USING: extract_tagged($str,"<[A-Z]+>",undef, undef, {ignore=>["<BR>"]});
	<A>aaa<B>bbb<BR>ccc</B>ddd</A>;

# THESE SHOULD FAIL
	BEGIN at the beginning and end at the end;
	BEGIN at the BEGIN keyword and END at the end;

# TEST EXTRACTION OF TAGGED STRINGS
# USING: extract_tagged($str,"BEGIN","END",undef,{reject=>["BEGIN","END"]});
# THESE SHOULD FAIL
	BEGIN at the BEGIN keyword and END at the end;

# USING: extract_tagged($str,";","-",undef,{reject=>[";"],fail=>"PARA"});
	; at the ;-) keyword


# USING: extract_tagged($str);
	<A>some text</A>;
	<B>some text<A>other text</A></B>;
	<A>some text<A>other text</A></A>;
	<A HREF="#section2">some text</A>;

# THESE SHOULD FAIL
	<A>some text
	<A>some text<A>other text</A>;
	<B>some text<A>other text</B>;

--- NEW FILE: extdel.t ---
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir('t') if -d 't';
        @INC = qw(../lib);
    }
}

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..45\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( extract_delimited );
$loaded = 1;
print "ok 1\n";
$count=2;
use vars qw( $DEBUG );
sub debug { print "\t>>>", at _ if $DEBUG }

######################### End of black magic.


$cmd = "print";
$neg = 0;
while (defined($str = <DATA>))
{
	chomp $str;
	if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
	elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
	elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
	$str =~ s/\\n/\n/g;
	debug "\tUsing: $cmd\n";
	debug "\t   on: [$str]\n";

	$var = eval "() = $cmd";
	debug "\t list got: [$var]\n";
	debug "\t list left: [$str]\n";
	print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";

	pos $str = 0;
	$var = eval $cmd;
	$var = "<undef>" unless defined $var;
	debug "\t scalar got: [$var]\n";
	debug "\t scalar left: [$str]\n";
	print "not " if ($str =~ '\A;')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";
}

__DATA__
# USING: extract_delimited($str,'/#$',undef,'/#$');
/a/;
/a///;
#b#;
#b###;
$c$;
$c$$$;

# TEST EXTRACTION OF DELIMITED TEXT WITH ESCAPES
# USING: extract_delimited($str,'/#$',undef,'\\');
/a/;
/a\//;
#b#;
#b\##;
$c$;
$c\$$;

# TEST EXTRACTION OF DELIMITED TEXT
# USING: extract_delimited($str);
'a';
"b";
`c`;
'a\'';
'a\\';
'\\a';
"a\\";
"\\a";
"b\'\"\'";
`c '\`abc\`'`;

# TEST EXTRACTION OF DELIMITED TEXT
# USING: extract_delimited($str,'/#$','-->');
-->/a/;
-->#b#;
-->$c$;

# THIS SHOULD FAIL
$c$;

--- NEW FILE: gentag.t ---
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir('t') if -d 't';
        @INC = qw(../lib);
    }
}

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..37\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( gen_extract_tagged );
$loaded = 1;
print "ok 1\n";
$count=2;
use vars qw( $DEBUG );
sub debug { print "\t>>>", at _ if $DEBUG }

######################### End of black magic.


$cmd = "print";
$neg = 0;
while (defined($str = <DATA>))
{
	chomp $str;
	$str =~ s/\\n/\n/g;
	if ($str =~ s/\A# USING://)
	{
		$neg = 0;
		eval{local$^W;*f = eval $str || die};
		next;
	}
	elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
	elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
	$str =~ s/\\n/\n/g;
	debug "\tUsing: $cmd\n";
	debug "\t   on: [$str]\n";

	my @res;
	$var = eval { @res = f($str) };
	debug "\t list got: [" . join("|", at res) . "]\n";
	debug "\t list left: [$str]\n";
	print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";

	pos $str = 0;
	$var = eval { scalar f($str) };
	$var = "<undef>" unless defined $var;
	debug "\t scalar got: [$var]\n";
	debug "\t scalar left: [$str]\n";
	print "not " if ($str =~ '\A;')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";
}

__DATA__

# USING: gen_extract_tagged('{','}');
	{ a test };

# USING: gen_extract_tagged(qr/<[A-Z]+>/,undef, undef, {ignore=>["<BR>"]});
	<A>aaa<B>bbb<BR>ccc</B>ddd</A>;

# USING: gen_extract_tagged("BEGIN","END");
	BEGIN at the BEGIN keyword and END at the END;
	BEGIN at the beginning and end at the END;

# USING: gen_extract_tagged(undef,undef,undef,{ignore=>["<[^>]*/>"]});
	<A>aaa<B>bbb<BR/>ccc</B>ddd</A>;

# USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"MAX"});
	; at the ;-) keyword

# USING: gen_extract_tagged("<[A-Z]+>",undef, undef, {ignore=>["<BR>"]});
	<A>aaa<B>bbb<BR>ccc</B>ddd</A>;

# THESE SHOULD FAIL
	BEGIN at the beginning and end at the end;
	BEGIN at the BEGIN keyword and END at the end;

# TEST EXTRACTION OF TAGGED STRINGS
# USING: gen_extract_tagged("BEGIN","END",undef,{reject=>["BEGIN","END"]});
# THESE SHOULD FAIL
	BEGIN at the BEGIN keyword and END at the end;

# USING: gen_extract_tagged(";","-",undef,{reject=>[";"],fail=>"PARA"});
	; at the ;-) keyword


# USING: gen_extract_tagged();
	<A>some text</A>;
	<B>some text<A>other text</A></B>;
	<A>some text<A>other text</A></A>;
	<A HREF="#section2">some text</A>;

# THESE SHOULD FAIL
	<A>some text
	<A>some text<A>other text</A>;
	<B>some text<A>other text</B>;

--- NEW FILE: extvar.t ---
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir('t') if -d 't';
        @INC = qw(../lib);
    }
}

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..183\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( extract_variable );
$loaded = 1;
print "ok 1\n";
$count=2;
use vars qw( $DEBUG );
sub debug { print "\t>>>", at _ if $DEBUG }

######################### End of black magic.


$cmd = "print";
$neg = 0;
while (defined($str = <DATA>))
{
	chomp $str;
	if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
	elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
	elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
	$str =~ s/\\n/\n/g;
	debug "\tUsing: $cmd\n";
	debug "\t   on: [$str]\n";

	my @res;
	$var = eval "\@res = $cmd";
	debug "\t list got: [" . join("|", at res) . "]\n";
	debug "\t list left: [$str]\n";
	print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";

	pos $str = 0;
	$var = eval $cmd;
	$var = "<undef>" unless defined $var;
	debug "\t scalar got: [$var]\n";
	debug "\t scalar left: [$str]\n";
	print "not " if ($str =~ '\A;')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";
}

__DATA__

# USING: extract_variable($str);
# THESE SHOULD FAIL
$a->;
$a (1..3) { print $a };

# USING: extract_variable($str);
$::obj;
$obj->nextval;
*var;
*$var;
*{var};
*{$var};
*var{cat};
\&var;
\&mod::var;
\&mod'var;
$a;
$_;
$a[1];
$_[1];
$a{cat};
$_{cat};
$a->[1];
$a->{"cat"}[1];
@$listref;
@{$listref};
$obj->nextval;
$obj->_nextval;
$obj->next_val_;
@{$obj->nextval};
@{$obj->nextval($cat,$dog)->{new}};
@{$obj->nextval($cat?$dog:$fish)->{new}};
@{$obj->nextval(cat()?$dog:$fish)->{new}};
$ a {'cat'};
$a::b::c{d}->{$e->()};
$a'b'c'd{e}->{$e->()};
$a'b::c'd{e}->{$e->()};
$#_;
$#array;
$#{array};
$var[$#var];
$1;
$11;
$&;
$`;
$';
$+;
$*;
$.;
$/;
$|;
$,;
$";
$;;
$#;
$%;
$=;
$-;
$~;
$^;
$:;
$^L;
$^A;
$?;
$!;
$^E;
$@;
$$;
$<;
$>;
$(;
$);
$[;
$];
$^C;
$^D;
$^F;
$^H;
$^I;
$^M;
$^O;
$^P;
$^R;
$^S;
$^T;
$^V;
$^W;
${^WARNING_BITS};
${^WIDE_SYSTEM_CALLS};
$^X;

# THESE SHOULD FAIL
$a->;
@{$;
$ a :: b :: c
$ a ' b ' c

# USING: extract_variable($str,'=*');
========$a;

--- NEW FILE: extqlk.t ---
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir('t') if -d 't';
        @INC = qw(../lib);
    }
}

#! /usr/local/bin/perl -ws
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..89\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( extract_quotelike );
$loaded = 1;
print "ok 1\n";
$count=2;
use vars qw( $DEBUG );
# $DEBUG=1;
sub debug { print "\t>>>", at _ if $DEBUG }

######################### End of black magic.


$cmd = "print";
$neg = 0;
while (defined($str = <DATA>))
{
	chomp $str;
	if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
	elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
	elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
	debug "\tUsing: $cmd\n";
	debug "\t   on: [$str]\n";
	$str =~ s/\\n/\n/g;
	my $orig = $str;

	 my @res;
	eval qq{\@res = $cmd; };
	debug "\t  got:\n" . join "", map { $res[$_]=~s/\n/\\n/g; "\t\t\t$_: [$res[$_]]\n"} (0..$#res);
	debug "\t left: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy1 = $str)[0];
	debug "\t  pos: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy2 = substr($str,pos($str)))[0] . "...]\n";
	print "not " if (substr($str,pos($str),1) eq ';')==$neg;
	print "ok ", $count++;
	print "\n";

	$str = $orig;
	debug "\tUsing: scalar $cmd\n";
	debug "\t   on: [$str]\n";
	$var = eval $cmd;
	print " ($@)" if $@ && $DEBUG;
	$var = "<undef>" unless defined $var;
	debug "\t scalar got: " . (map { s/\n/\\n/g; "[$_]\n" } $var)[0];
	debug "\t scalar left: " . (map { s/\n/\\n/g; "[$_]\n" } $str)[0];
	print "not " if ($str =~ '\A;')==$neg;
	print "ok ", $count++;
	print "\n";
}

__DATA__

# USING: extract_quotelike($str);
'';
"";
"a";
'b';
`cc`;


<<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
     <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
<<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next
<<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next
<<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next
<<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next
<<"   EOHERE"; done() \nline1\nline2\n   EOHERE\nand next
<<""; done()\nline1\nline2\n\n and next
<<; done()\nline1\nline2\n\n and next


"this is a nested $var[$x] {";
/a/gci;
m/a/gci;

q(d);
qq(e);
qx(f);
qr(g);
qw(h i j);
q{d};
qq{e};
qx{f};
qr{g};
qq{a nested { and } are okay as are () and <> pairs and escaped \}'s };
q/slash/;
q # slash #;
qr qw qx;

s/x/y/;
s/x/y/cgimsox;
s{a}{b};
s{a}\n {b};
s(a){b};
s(a)/b/;
s/'/\\'/g;
tr/x/y/;
y/x/y/;

# THESE SHOULD FAIL
s<$self->{pat}>{$self->{sub}};		# CAN'T HANDLE '>' in '->'
s-$self->{pap}-$self->{sub}-;		# CAN'T HANDLE '-' in '->'
<<EOHERE; done();\nline1\nline2\nEOHERE;\n; next;	    # RDEL HAS NO ';'
<<'EOHERE'; done();\nline1\nline2\nEOHERE;\n; next;	    # RDEF HAS NO ';'
     <<    EOTHERE; done();\nline1\nline2\n    EOTHERE\n; next;  # RDEL IS "" (!)

--- NEW FILE: extcbk.t ---
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir('t') if -d 't';
        @INC = qw(../lib);
    }
}

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..41\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( extract_codeblock );
$loaded = 1;
print "ok 1\n";
$count=2;
use vars qw( $DEBUG );
sub debug { print "\t>>>", at _ if $DEBUG }

######################### End of black magic.


$cmd = "print";
$neg = 0;
while (defined($str = <DATA>))
{
	chomp $str;
	if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
	elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
	elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
	$str =~ s/\\n/\n/g;
	debug "\tUsing: $cmd\n";
	debug "\t   on: [$str]\n";

	my @res;
	$var = eval "\@res = $cmd";
	debug "\t   Failed: $@ at " . $@+0 .")" if $@;
	debug "\t list got: [" . join("|", at res) . "]\n";
	debug "\t list left: [$str]\n";
	print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
	print "ok ", $count++;
	print "\n";

	pos $str = 0;
	$var = eval $cmd;
	$var = "<undef>" unless defined $var;
	debug "\t scalar got: [$var]\n";
	debug "\t scalar left: [$str]\n";
	print "not " if ($str =~ '\A;')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";
}

__DATA__

# USING: extract_codeblock($str,'(){}',undef,'()');
(Foo(')'));

# USING: extract_codeblock($str);
{ $data[4] =~ /['"]/; };

# USING: extract_codeblock($str,'<>');
< %x = ( try => "this") >;
< %x = () >;
< %x = ( $try->{this}, "too") >;
< %'x = ( $try->{this}, "too") >;
< %'x'y = ( $try->{this}, "too") >;
< %::x::y = ( $try->{this}, "too") >;

# THIS SHOULD FAIL
< %x = do { $try > 10 } >;

# USING: extract_codeblock($str);

{ $a = /\}/; };
{ sub { $_[0] /= $_[1] } };  # / here
{ 1; };
{ $a = 1; };


# USING: extract_codeblock($str,undef,'=*');
========{$a=1};

# USING: extract_codeblock($str,'{}<>');
< %x = do { $try > 10 } >;

# USING: extract_codeblock($str,'{}',undef,'<>');
< %x = do { $try > 10 } >;

# USING: extract_codeblock($str,'{}');
{ $a = $b; # what's this doing here? \n };'
{ $a = $b; \n $a =~ /$b/; \n @a = map /\s/ @b };

# THIS SHOULD FAIL
{ $a = $b; # what's this doing here? };'
{ $a = $b; # what's this doing here? ;'

--- NEW FILE: extmul.t ---
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir('t') if -d 't';
        @INC = qw(../lib);
    }
}

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..85\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( :ALL );
$loaded = 1;
print "ok 1\n";
$count=2;
use vars qw( $DEBUG );
sub debug { print "\t>>>", at _ if $DEBUG }

######################### End of black magic.

sub expect
{
	local $^W;
	my ($l1, $l2) = @_;

	if (@$l1 != @$l2)
	{
		print "\@l1: ", join(", ", @$l1), "\n";
		print "\@l2: ", join(", ", @$l2), "\n";
		print "not ";
	}
	else
	{
		for (my $i = 0; $i < @$l1; $i++)
		{
			if ($l1->[$i] ne $l2->[$i])
			{
				print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n";
				print "not ";
				last;
			}
		}
	}

	print "ok $count\n";
	$count++;
}

sub divide
{
	my ($text, @index) = @_;
	my @bits = ();
	unshift @index, 0;
	push @index, length($text);
	for ( my $i= 0; $i < $#index; $i++)
	{
		push @bits, substr($text, $index[$i], $index[$i+1]-$index[$i]);
	}
	pop @bits;
	return @bits;

}


$stdtext1 = q{$var = do {"val" && $val;};};

# TESTS 2-4
$text = $stdtext1;
expect	[ extract_multiple($text,undef,1) ],
	[ divide $stdtext1 => 4 ];

expect [ pos $text], [ 4 ];
expect [ $text ], [ $stdtext1 ];

# TESTS 5-7
$text = $stdtext1;
expect	[ scalar extract_multiple($text,undef,1) ],
	[ divide $stdtext1 => 4 ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext1,4) ];


# TESTS 8-10
$text = $stdtext1;
expect	[ extract_multiple($text,undef,2) ],
	[ divide($stdtext1 => 4, 10) ];

expect [ pos $text], [ 10 ];
expect [ $text ], [ $stdtext1 ];

# TESTS 11-13
$text = $stdtext1;
expect	[ eval{local$^W;scalar extract_multiple($text,undef,2)} ],
	[ substr($stdtext1,0,4) ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext1,4) ];


# TESTS 14-16
$text = $stdtext1;
expect	[ extract_multiple($text,undef,3) ],
	[ divide($stdtext1 => 4, 10, 26) ];

expect [ pos $text], [ 26 ];
expect [ $text ], [ $stdtext1 ];

# TESTS 17-19
$text = $stdtext1;
expect	[ eval{local$^W;scalar extract_multiple($text,undef,3)} ],
	[ substr($stdtext1,0,4) ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext1,4) ];


# TESTS 20-22
$text = $stdtext1;
expect	[ extract_multiple($text,undef,4) ],
	[ divide($stdtext1 => 4, 10, 26, 27) ];

expect [ pos $text], [ 27 ];
expect [ $text ], [ $stdtext1 ];

# TESTS 23-25
$text = $stdtext1;
expect	[ eval{local$^W;scalar extract_multiple($text,undef,4)} ],
	[ substr($stdtext1,0,4) ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext1,4) ];


# TESTS 26-28
$text = $stdtext1;
expect	[ extract_multiple($text,undef,5) ],
	[ divide($stdtext1 => 4, 10, 26, 27) ];

expect [ pos $text], [ 27 ];
expect [ $text ], [ $stdtext1 ];


# TESTS 29-31
$text = $stdtext1;
expect	[ eval{local$^W;scalar extract_multiple($text,undef,5)} ],
	[ substr($stdtext1,0,4) ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext1,4) ];



# TESTS 32-34
$stdtext2 = q{$var = "val" && (1,2,3);};

$text = $stdtext2;
expect	[ extract_multiple($text) ],
	[ divide($stdtext2 => 4, 7, 12, 24) ];

expect [ pos $text], [ 24 ];
expect [ $text ], [ $stdtext2 ];

# TESTS 35-37
$text = $stdtext2;
expect	[ scalar extract_multiple($text) ],
	[ substr($stdtext2,0,4) ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext2,4) ];


# TESTS 38-40
$text = $stdtext2;
expect	[ extract_multiple($text,[\&extract_bracketed]) ],
	[ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ];

expect [ pos $text], [ 24 ];
expect [ $text ], [ $stdtext2 ];

# TESTS 41-43
$text = $stdtext2;
expect	[ scalar extract_multiple($text,[\&extract_bracketed]) ],
	[ substr($stdtext2,0,16) ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext2,15) ];


# TESTS 44-46
$text = $stdtext2;
expect	[ extract_multiple($text,[\&extract_variable]) ],
	[ substr($stdtext2,0,4), substr($stdtext2,4) ];

expect [ pos $text], [ length($text) ];
expect [ $text ], [ $stdtext2 ];

# TESTS 47-49
$text = $stdtext2;
expect	[ scalar extract_multiple($text,[\&extract_variable]) ],
	[ substr($stdtext2,0,4) ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext2,4) ];


# TESTS 50-52
$text = $stdtext2;
expect	[ extract_multiple($text,[\&extract_quotelike]) ],
	[ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ];

expect [ pos $text], [ length($text) ];
expect [ $text ], [ $stdtext2 ];

# TESTS 53-55
$text = $stdtext2;
expect	[ scalar extract_multiple($text,[\&extract_quotelike]) ],
	[ substr($stdtext2,0,7) ];

expect [ pos $text], [ 0 ];
expect [ $text ], [ substr($stdtext2,6) ];


# TESTS 56-58
$text = $stdtext2;
expect	[ extract_multiple($text,[\&extract_quotelike],2,1) ],
	[ substr($stdtext2,7,5) ];

expect [ pos $text], [ 23 ];
expect [ $text ], [ $stdtext2 ];

# TESTS 59-61
$text = $stdtext2;
expect	[ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ],
	[ substr($stdtext2,7,5) ];

expect [ pos $text], [ 6 ];
expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ];


# TESTS 62-64
$text = $stdtext2;
expect	[ extract_multiple($text,[\&extract_quotelike],1,1) ],
	[ substr($stdtext2,7,5) ];

expect [ pos $text], [ 12 ];
expect [ $text ], [ $stdtext2 ];

# TESTS 65-67
$text = $stdtext2;
expect	[ scalar extract_multiple($text,[\&extract_quotelike],1,1) ],
	[ substr($stdtext2,7,5) ];

expect [ pos $text], [ 6 ];
expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ];

# TESTS 68-70
my $stdtext3 = "a,b,c";

$_ = $stdtext3;
expect	[ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ],
	[ divide($stdtext3 => 1,2,3,4,5) ];

expect [ pos ], [ 5 ];
expect [ $_ ], [ $stdtext3 ];

# TESTS 71-73

$_ = $stdtext3;
expect	[ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ],
	[ divide($stdtext3 => 1) ];

expect [ pos ], [ 0 ];
expect [ $_ ], [ substr($stdtext3,1) ];


# TESTS 74-76

$_ = $stdtext3;
expect	[ extract_multiple(undef, [ qr/\G[a-z]/ ]) ],
	[ divide($stdtext3 => 1,2,3,4,5) ];

expect [ pos ], [ 5 ];
expect [ $_ ], [ $stdtext3 ];

# TESTS 77-79

$_ = $stdtext3;
expect	[ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ],
	[ divide($stdtext3 => 1) ];

expect [ pos ], [ 0 ];
expect [ $_ ], [ substr($stdtext3,1) ];


# TESTS 80-82

$_ = $stdtext3;
expect	[ extract_multiple(undef, [ q/([a-z]),?/ ]) ],
	[ qw(a b c) ];

expect [ pos ], [ 5 ];
expect [ $_ ], [ $stdtext3 ];

# TESTS 83-85

$_ = $stdtext3;
expect	[ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ],
	[ divide($stdtext3 => 1) ];

expect [ pos ], [ 0 ];
expect [ $_ ], [ substr($stdtext3,2) ];

--- NEW FILE: extbrk.t ---
BEGIN {
    if ($ENV{PERL_CORE}) {
        chdir('t') if -d 't';
        @INC = qw(../lib);
    }
}

# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..19\n"; }
END {print "not ok 1\n" unless $loaded;}
use Text::Balanced qw ( extract_bracketed );
$loaded = 1;
print "ok 1\n";
$count=2;
use vars qw( $DEBUG );
sub debug { print "\t>>>", at _ if $DEBUG }

######################### End of black magic.


$cmd = "print";
$neg = 0;
while (defined($str = <DATA>))
{
	chomp $str;
	if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
	elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
	elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
	$str =~ s/\\n/\n/g;
	debug "\tUsing: $cmd\n";
	debug "\t   on: [$str]\n";

	$var = eval "() = $cmd";
	debug "\t list got: [$var]\n";
	debug "\t list left: [$str]\n";
	print "not " if (substr($str,pos($str),1) eq ';')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";

	pos $str = 0;
	$var = eval $cmd;
	$var = "<undef>" unless defined $var;
	debug "\t scalar got: [$var]\n";
	debug "\t scalar left: [$str]\n";
	print "not " if ($str =~ '\A;')==$neg;
	print "ok ", $count++;
	print " ($@)" if $@ && $DEBUG;
	print "\n";
}

__DATA__

# USING: extract_bracketed($str);
{a nested { and } are okay as are () and <> pairs and escaped \}'s };
{a nested\n{ and } are okay as are\n() and <> pairs and escaped \}'s };

# USING: extract_bracketed($str,'{}');
{a nested { and } are okay as are unbalanced ( and < pairs and escaped \}'s };

# THESE SHOULD FAIL
{an unmatched nested { isn't okay, nor are ( and < };
{an unbalanced nested [ even with } and ] to match them;


# USING: extract_bracketed($str,'<"`q>');
<a q{uoted} ">" unbalanced right bracket of /(q>)/ either sort (`>>>""">>>>`) is okay >;

# USING: extract_bracketed($str,'<">');
<a quoted ">" unbalanced right bracket is okay >;

# USING: extract_bracketed($str,'<"`>');
<a quoted ">" unbalanced right bracket of either sort (`>>>""">>>>`) is okay >;

# THIS SHOULD FAIL
<a misquoted '>' unbalanced right bracket is bad >;




More information about the dslinux-commit mailing list