# 06_general.t
#
# Test suite for Regexp::Assemble
# Check out the general functionality, now that all the subsystems have been exercised
#
# copyright (C) 2004-2007 David Landgren
use strict;
use Regexp::Assemble;
eval qq{use Test::More tests => 142 };
if( $@ ) {
warn "# Test::More not available, no tests performed\n";
print "1..1\nok 1\n";
exit 0;
}
use constant NR_GOOD => 45;
use constant NR_BAD => 529;
use constant NR_ERROR => 0;
my $fixed = 'The scalar remains the same';
$_ = $fixed;
my $target;
my $ra = Regexp::Assemble->new->add( qw/foo bar rat/ );
for $target( qw/unfooled disembark vibration/ ) {
like( $target, qr/$ra/, "match ok $target" )
}
ok( !defined($ra->source()), 'source() undefined' );
for $target( qw/unfooled disembark vibration/ ) {
unlike( $target, qr/^$ra/, "anchored match not ok $target" )
}
$ra->reset;
for $target( qw/unfooled disembark vibration/ ) {
unlike( $target, qr/$ra/, "fail after reset $target" )
}
$ra->add( qw/who what where why when/ );
for $target( qw/unfooled disembark vibration/ ) {
unlike( $target, qr/$ra/, "fail ok $target" )
}
for $target( qw/snowhouse somewhat nowhereness whyever nowhence/ ) {
like( $target, qr/$ra/, "new match ok $target" )
}
$ra->reset->mutable(1);
unlike( 'nothing', qr/$ra/, "match nothing after reset" );
$ra->add( '^foo\\d+' );
like( 'foo12', qr/$ra/, "match 1 ok foo12" );
unlike( 'nfoo12', qr/$ra/, "match 1 nok nfoo12" );
unlike( 'bar6', qr/$ra/, "match 1 nok bar6" );
ok( !defined($ra->mvar()), 'mvar() undefined' );
$ra->add( 'bar\\d+' );
like( 'foo12', qr/$ra/, "match 2 ok foo12" );
unlike( 'nfoo12', qr/$ra/, "match 2 nok nfoo12" );
like( 'bar6', qr/$ra/, "match 2 ok bar6" );
$ra->reset->filter( sub { not grep { $_ !~ /[\d ]/ } @_ } );
$ra->add( '1 2 4' );
$ra->insert( '1', '2', '8*' );
unlike( '3 4 1 2', qr/$ra/, 'filter nok 3 4 1 2' );
like( '3 1 2 4', qr/$ra/, 'filter ok 3 1 2 4' );
unlike( '5 2 3 4', qr/$ra/, 'filter ok 5 2 3 4' );
$ra->add( '2 3 a+' );
$ra->insert( '2', ' ', '3', ' ', 'a+' );
unlike( '5 2 3 4', qr/$ra/, 'filter ok 5 2 3 4 (2)' );
unlike( '5 2 3 aaa', qr/$ra/, 'filter nok 5 2 3 a+' );
$ra->reset->filter( undef );
$ra->add( '1 2 a+' );
like( '5 1 2 aaaa', qr/$ra/, 'filter now ok 5 1 2 a+' );
$ra->reset->pre_filter( sub { $_[0] !~ /^#/ } );
$ra->add( '#de' );
$ra->add( 'abc' );
unlike( '#de', qr/^$ra$/, '#de not matched by comment-filtered assembly' );
like( 'abc', qr/^$ra$/, 'abc matched by comment-filtered assembly' );
SKIP: {
skip( "is_deeply is broken in this version of Test::More (v$Test::More::VERSION)", 5 )
unless $Test::More::VERSION > 0.47;
{
my $orig = Regexp::Assemble->new;
my $clone = $orig->clone;
is_deeply( $orig, $clone, 'clone empty' );
}
{
my $orig = Regexp::Assemble->new->add( qw/ dig dug dog / );
my $clone = $orig->clone;
is_deeply( $orig, $clone, 'clone path' );
}
{
my $orig = Regexp::Assemble->new->add( qw/ dig dug dog / );
my $clone = $orig->clone;
$orig->add( 'digger' );
$clone->add( 'digger' );
is_deeply( $orig, $clone, 'clone then add' );
}
{
my $orig = Regexp::Assemble->new
->add( qw/ bird cat dog elephant fox/ );
my $clone = $orig->clone;
is_deeply( $orig, $clone, 'clone node' );
}
{
my $orig = Regexp::Assemble->new
->add( qw/ after alter amber cheer steer / );
my $clone = $orig->clone;
is_deeply( $orig, $clone, 'clone more' );
}
}
SKIP: {
# If the Storable module is available, we will have used
# that above, however, we will not have tested the pure-Perl
# fallback routines.
skip( 'Pure-Perl clone() already tested', 5 )
unless $Regexp::Assemble::have_Storable;
skip( "is_deeply is broken in this version of Test::More (v$Test::More::VERSION)", 5 )
unless $Test::More::VERSION > 0.47;
local $Regexp::Assemble::have_Storable = 0;
{
my $orig = Regexp::Assemble->new;
my $clone = $orig->clone;
is_deeply( $orig, $clone, 'clone empty' );
}
{
my $orig = Regexp::Assemble->new->add( qw/ dig dug dog / );
my $clone = $orig->clone;
is_deeply( $orig, $clone, 'clone path' );
}
{
my $orig = Regexp::Assemble->new->add( qw/ dig dug dog / );
my $clone = $orig->clone;
$orig->add( 'digger' );
$clone->add( 'digger' );
is_deeply( $orig, $clone, 'clone then add' );
}
{
my $orig = Regexp::Assemble->new
->add( qw/ bird cat dog elephant fox/ );
my $clone = $orig->clone;
is_deeply( $orig, $clone, 'clone node' );
}
{
my $orig = Regexp::Assemble->new
->add( qw/ after alter amber cheer steer / );
my $clone = $orig->clone;
is_deeply( $orig, $clone, 'clone more' );
}
}
{
my $r = Regexp::Assemble->new ->add( qw/ dig dug / );
cmp_ok( $r->dump, 'eq', '[d {i=>[i g] u=>[u g]}]', 'dump path' );
}
{
my $r = Regexp::Assemble->new ->add( 'a b' );
cmp_ok( $r->dump, 'eq', q<[a ' ' b]>, 'dump path with space' );
$r->insert( 'a', ' ', 'b', 'c', 'd' );
cmp_ok( $r->dump, 'eq', q([a ' ' b {* c=>[c d]}]),
'dump path with space 2' );
}
{
my $r = Regexp::Assemble->new ->add( qw/ dog cat / );
cmp_ok( $r->dump, 'eq', '[{c=>[c a t] d=>[d o g]}]', 'dump node' );
}
{
my $r = Regexp::Assemble->new->add( qw/ house home / );
$r->insert();
cmp_ok( $r->dump, 'eq', '[{* h=>[h o {m=>[m e] u=>[u s e]}]}]',
'add opt to path' );
}
{
my $r = Regexp::Assemble->new->add( qw/ dog cat / );
$r->insert();
cmp_ok( $r->dump, 'eq', '[{* c=>[c a t] d=>[d o g]}]',
'add opt to node' );
}
{
my $slide = Regexp::Assemble->new;
cmp_ok( $slide->add( qw/schoolkids acids acidoids/ )->as_string,
'eq', '(?:ac(?:ido)?|schoolk)ids', 'schoolkids acids acidoids' );
cmp_ok( $slide->add( qw/schoolkids acidoids/ )->as_string,
'eq', '(?:schoolk|acido)ids', 'schoolkids acidoids' );
cmp_ok( $slide->add( qw/nonschoolkids nonacidoids/ )->as_string,
'eq', 'non(?:schoolk|acido)ids', 'nonschoolkids nonacidoids' );
}
{
cmp_ok( Regexp::Assemble->new
->add( qw( sing singing ))
->as_string, 'eq', 'sing(?:ing)?', 'super slide sing singing' # no sliding done
);
cmp_ok( Regexp::Assemble->new
->add( qw( sing singing sling))
->as_string, 'eq', 's(?:(?:ing)?|l)ing',
'super slide sing singing sling'
);
cmp_ok( Regexp::Assemble->new
->add( qw( sing singing sling slinging))
->as_string, 'eq', 'sl?(?:ing)?ing',
'super slide sing singing sling slinging'
);
cmp_ok( Regexp::Assemble->new
->add( qw( sing singing sling slinging sting stinging ))
->as_string, 'eq', 's[lt]?(?:ing)?ing',
'super slide sing singing sling slinging sting stinging'
);
cmp_ok( Regexp::Assemble->new
->add( qw( sing singing sling slinging sting stinging string stringing swing swinging ))
->as_string, 'eq', 's(?:[lw]|tr?)?(?:ing)?ing',
'super slide sing singing sling slinging sting stinging string stringing swing swinging'
);
}
{
my $re = Regexp::Assemble->new( flags => 'i' )->add( qw/ ^ab ^are de / );
like( 'able', qr/$re/, '{^ab ^are de} /i matches able' );
like( 'About', qr/$re/, '{^ab ^are de} /i matches About' );
unlike( 'bare', qr/$re/, '{^ab ^are de} /i fails bare' );
like( 'death', qr/$re/, '{^ab ^are de} /i matches death' );
like( 'DEEP', qr/$re/, '{^ab ^are de} /i matches DEEP' );
}
{
my $re = Regexp::Assemble->new->add( qw/abc def ghi/ );
cmp_ok( $re->{stats_add}, '==', 3, "stats add 3x3" );
cmp_ok( $re->{stats_raw}, '==', 9, "stats raw 3x3" );
cmp_ok( $re->{stats_cooked}, '==', 9, "stats cooked 3x3" );
ok( !defined($re->{stats_dup}), "stats dup 3x3" );
$re->add( 'de' );
cmp_ok( $re->{stats_add}, '==', 4, "stats add 3x3 +1" );
cmp_ok( $re->{stats_raw}, '==', 11, "stats raw 3x3 +1" );
cmp_ok( $re->{stats_cooked}, '==', 11, "stats cooked 3x3 +1" );
}
{
my $re = Regexp::Assemble->new->add( '\\Qabc.def.ghi\\E' );
cmp_ok( $re->{stats_add}, '==', 1, "stats add qm" );
cmp_ok( $re->{stats_raw}, '==', 15, "stats raw qm" );
cmp_ok( $re->{stats_cooked}, '==', 13, "stats cooked qm" );
ok( !defined($re->{stats_dup}), "stats dup qm" );
}
{
my $re = Regexp::Assemble->new->add( 'abc\\,def', 'abc\\,def' );
cmp_ok( $re->{stats_add}, '==', 1, "stats add unqm dup" );
cmp_ok( $re->{stats_raw}, '==', 16, "stats raw unqm dup" );
cmp_ok( $re->{stats_cooked}, '==', 7, "stats cooked unqm dup" );
cmp_ok( $re->{stats_dup}, '==', 1, "stats dup unqm dup" );
cmp_ok( $re->stats_length, '==', 0, "stats_length unqm dup" );
my $str = $re->as_string;
cmp_ok( $str, 'eq', 'abc,def', "stats str unqm dup" );
cmp_ok( $re->stats_length, '==', 7, "stats len unqm dup" );
}
{
my $re = Regexp::Assemble->new->add( '' );
cmp_ok( $re->{stats_add}, '==', 1, "stats add empty" );
cmp_ok( $re->{stats_raw}, '==', 0, "stats raw empty" );
ok( !defined($re->{stats_cooked}), "stats cooked empty" );
ok( !defined($re->{stats_dup}), "stats dup empty" );
}
{
my $re = Regexp::Assemble->new;
cmp_ok( $re->stats_add, '==', 0, "stats_add empty" );
cmp_ok( $re->stats_raw, '==', 0, "stats_raw empty" );
cmp_ok( $re->stats_cooked, '==', 0, "stats_cooked empty" );
cmp_ok( $re->stats_dup, '==', 0, "stats_dup empty" );
cmp_ok( $re->stats_length, '==', 0, "stats_length empty" );
my $str = $re->as_string;
cmp_ok( $str, 'eq', $Regexp::Assemble::Always_Fail, "stats str empty" ); # tricky!
cmp_ok( $re->stats_length, '==', 0, "stats len empty" );
}
{
my $re = Regexp::Assemble->new->add( '\\Q.+\\E', '\\Q.+\\E', '\\Q.*\\E' );
cmp_ok( $re->stats_add, '==', 2, "stats_add 2" );
cmp_ok( $re->stats_raw, '==', 18, "stats_raw 2" );
cmp_ok( $re->stats_cooked, '==', 8, "stats_cooked 2" );
cmp_ok( $re->stats_dup, '==', 1, "stats_dup 2" );
cmp_ok( $re->stats_length, '==', 0, "stats_length 2" );
my $str = $re->as_string;
cmp_ok( $str, 'eq', '\\.[*+]', "stats str 2" );
cmp_ok( $re->stats_length, '==', 6, "stats len 2 <$str>" );
}
{
# CPAN bug #24171
# given a list of strings
my @str = ( 'a b', 'awb', 'a1b', 'bar', "a\nb" );
for my $meta (qw( s w d )) {
# given a list of patterns
my @re = ( "a\\${meta}b", "a\\@{[uc$meta]}b" );
# produce an assembled pattern
my $re = Regexp::Assemble->new()->add(@re)->re();
my $re_fold = Regexp::Assemble->new()->fold_meta_pairs(0)->add(@re)->re();
# test it against the strings
for my $str (@str) {
# any match?
my $ok = 0;
$str =~ $_ && ( $ok = 1 ) for @re;
# does the assemble regexp match as well?
my $ptr = $str;
$ptr =~ s/\\/\\\\/;
$ptr =~ s/\n/\\n/;
my $bug_success = ($str =~ /\n/) ? 0 : 1;
my $bug_fail = 1 - $bug_success;
is( ($str =~ $re) ? $bug_success : $bug_fail, $ok,
"Folded meta pairs behave as list for \\$meta ($ptr,ok=$ok/$bug_success/$bug_fail)"
);
is( ($str =~ $re_fold) ? 1 : 0, $ok,
"Unfolded meta pairs behave as list for \\$meta ($ptr,ok=$ok)"
);
}
}
}
{
my $u = Regexp::Assemble->new(unroll_plus => 1);
my $str;
$u->add( "a+b", 'ac' );
$str = $u->as_string;
is( $str, 'a(?:a*b|c)', 'unroll plus a+b ac' );
$u->add( "\\LA+B", "ac" );
$str = $u->as_string;
is( $str, 'a(?:a*b|c)', 'unroll plus \\LA+B ac' );
$u->add( '\\Ua+?b', "AC" );
$str = $u->as_string;
is( $str, 'A(?:A*?B|C)', 'unroll plus \\Ua+?b AC' );
$u->add( qw(\\d+d \\de \\w+?x \\wy ));
$str = $u->as_string;
is( $str, '(?:\\w(?:\\w*?x|y)|\\d(?:\d*d|e))', 'unroll plus \\d and \\w' );
$u->add( qw( \\xab+f \\xabg \\xcd+?h \\xcdi ));
$str = $u->as_string;
is( $str, "(?:\xcd(?:\xcd*?h|i)|\xab(?:\xab*f|g))", 'unroll plus meta x' );
$u->add( qw([a-e]+h [a-e]i [f-j]+?k [f-j]m ));
$str = $u->as_string;
is( $str, "(?:[f-j](?:[f-j]*?k|m)|[a-e](?:[a-e]*h|i))", 'unroll plus class' );
$u->add( "a+b" );
$str = $u->as_string;
is( $str, "a+b", 'reroll a+b' );
$u->add( "a+b", "a+" );
$str = $u->as_string;
is( $str, "a+b?", 'reroll a+b?' );
$u->add( "a+?b", "a+?" );
$str = $u->as_string;
is( $str, "a+?b?", 'reroll a+?b?' );
$u->unroll_plus(0)->add( qw(1+2 13) );
$str = $u->as_string;
is( $str, "(?:1+2|13)", 'no unrolling' );
$u->unroll_plus()->add( qw(1+2 13) );
$str = $u->as_string;
is( $str, "1(?:1*2|3)", 'unrolling again via implicit' );
$u->add(qw(d+ldrt d+ndrt d+ldt d+ndt d+x));
$str = $u->as_string;
is( $str, 'd+(?:[ln]dr?t|x)', 'visit ARRAY codepath' );
}
cmp_ok( $_, 'eq', $fixed, '$_ has not been altered' );