Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
charset.t	13.16 KB	-r--r--r--	2014-12-27 11:49
fold_grind.t	39.63 KB	-r--r--r--	2014-12-27 12:37
no_utf8_pm.t	500 B	-r--r--r--	2014-12-27 11:49
overload.t	5.94 KB	-r--r--r--	2014-12-27 11:49
pat.t	48.6 KB	-r--r--r--	2015-01-24 15:03
pat_advanced.t	87.75 KB	-r--r--r--	2014-12-27 11:49
pat_advanced_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_psycho.t	6.42 KB	-r--r--r--	2014-12-27 12:37
pat_psycho_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_re_eval.t	37.05 KB	-r--r--r--	2014-12-27 11:49
pat_re_eval_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_rt_report.t	36.98 KB	-r--r--r--	2014-12-27 11:49
pat_rt_report_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_special_cc.t	1.64 KB	-r--r--r--	2014-12-27 11:49
pat_special_cc_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pat_thr.t	56 B	-r--r--r--	2014-12-27 11:49
pos.t	957 B	-r--r--r--	2014-12-27 11:49
qr-72922.t	1.12 KB	-r--r--r--	2014-12-27 11:49
qr.t	1.95 KB	-r--r--r--	2014-12-27 11:49
qr_gc.t	416 B	-r--r--r--	2014-12-27 11:49
qrstack.t	191 B	-r--r--r--	2014-12-27 11:49
re_tests	62.97 KB	-r--r--r--	2014-12-27 11:49
recompile.t	4.63 KB	-r--r--r--	2014-12-27 11:49
reg_60508.t	687 B	-r--r--r--	2014-12-27 11:49
reg_email.t	3.33 KB	-r--r--r--	2014-12-27 11:49
reg_email_thr.t	56 B	-r--r--r--	2014-12-27 11:49
reg_eval.t	2.35 KB	-r--r--r--	2014-12-27 11:49
reg_eval_scope.t	8.85 KB	-r--r--r--	2014-12-27 11:49
reg_fold.t	6.14 KB	-r--r--r--	2014-12-27 11:49
reg_mesg.t	24.47 KB	-r--r--r--	2014-12-27 11:49
reg_namedcapture.t	760 B	-r--r--r--	2014-12-27 11:49
reg_nc_tie.t	2.22 KB	-r--r--r--	2014-12-27 11:49
reg_pmod.t	2.1 KB	-r--r--r--	2014-12-27 11:49
reg_posixcc.t	4.92 KB	-r--r--r--	2014-12-27 11:49
regex_sets.t	4.62 KB	-r--r--r--	2014-12-27 11:49
regex_sets_compat.t	492 B	-r--r--r--	2014-12-27 11:49
regexp.t	14.42 KB	-r--r--r--	2014-12-27 11:49
regexp_noamp.t	257 B	-r--r--r--	2014-12-27 11:49
regexp_notrie.t	275 B	-r--r--r--	2014-12-27 11:49
regexp_qr.t	194 B	-r--r--r--	2014-12-27 11:49
regexp_qr_embed.t	209 B	-r--r--r--	2014-12-27 11:49
regexp_qr_embed_thr.t	235 B	-r--r--r--	2014-12-27 11:49
regexp_trielist.t	289 B	-r--r--r--	2014-12-27 11:49
regexp_unicode_prop.t	11.15 KB	-r--r--r--	2014-12-27 11:49
regexp_unicode_prop_thr.t	56 B	-r--r--r--	2014-12-27 11:49
rt122747.t	555 B	-r--r--r--	2015-01-10 12:06
rxcode.t	3.15 KB	-r--r--r--	2015-01-11 13:46
subst.t	24.25 KB	-r--r--r--	2014-12-27 11:49
substT.t	170 B	-r--r--r--	2014-12-27 11:49
subst_amp.t	1.45 KB	-r--r--r--	2014-12-27 11:49
subst_wamp.t	211 B	-r--r--r--	2014-12-27 11:49
uniprops.t	543 B	-r--r--r--	2014-12-27 12:37

Rename

#!./perl

# This is a test for bugs in (?{ }) and (??{ }) caused by corrupting the regex
# engine state within the eval-ed code
# --rafl

BEGIN {
    require './test.pl';
}

fresh_perl_is(<<'CODE', 'ok', {});
'42' =~ /4(?{ 'foo' =~ m{(foo)} })2/
    and print 'ok';
CODE

fresh_perl_is(<<'CODE', 'ok', {}, 'RT#33936');
'aba' =~ /(??{join('',split(qr{(?=)},'aba'))})/
    and print 'ok';
CODE

fresh_perl_is(<<'CODE', 'ok', {}, 'match vars are localized');
my $x = 'aba';
$x =~ s/(a)(?{ 'moo' =~ m{(o)} })/uc($1)/e;
print 'ok' if $x eq 'Aba';
CODE

my $preamble = <<'CODE';
sub build_obj {
  # In the real world we would die on validation fails, but RT#27838
  # is still unresolved, so don't tempt fate.
  $hash->{name} =~ /^[A-Z][a-z]+ [A-Z][a-z]+$/ or return "name error";
  $hash->{age} =~ /^[1-9][0-9]*$/ or return "age error";

# Add another layer of (?{...}) to try really hard to break things
  $hash->{square} =~
  /^(\d+)(?(?{my $sqrt = sprintf "%.0f", sqrt($^N); $sqrt**2==$^N })|(?!))$/
  or return "squareness error";

return bless { %$hash }, "Foo";
}

sub match {
  my $str = shift;
  our ($hash, $obj);
  # Do something like Regexp::Grammars does building an object.
  my $matched = $str =~ /
    ()
    ([A-Za-z][A-Za-z ]*)(?{ local $hash->{name} = $^N }),[ ]
    (\d+)(?{ local $hash->{age} = $^N })[ ]years[ ]old,[ ]
    secret[ ]number[ ](\d+)(?{ local $hash->{square} = $^N }).
    (?{ $obj = build_obj(); })
  /x;

if ($matched) {
    print "match ";
    if (ref($obj)) {
      print ref($obj), ":$obj->{name}:$obj->{age}:$obj->{square}";
    } else {
      print $obj, ":$hash->{name}:$hash->{age}:$hash->{square}";
    }
  } else {
    print "no match $hash->{name}:$hash->{age}:$hash->{square}";
  }

}
CODE

fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 1');
match("John Smith, 42 years old, secret number 36.");
CODE

fresh_perl_is($preamble . <<'CODE', 'match Foo:John Smith:42:36', {}, 'regex distillation 2');
match("Jim Jones, 35 years old, secret wombat 007."
  ." John Smith, 42 years old, secret number 36.");
CODE

fresh_perl_is($preamble . <<'CODE', 'match squareness error:::', {}, 'regex distillation 3');
match("John Smith, 54 years old, secret number 7.");
CODE

fresh_perl_is($preamble . <<'CODE', 'no match ::', {}, 'regex distillation 4');
match("Jim Jones, 35 years old, secret wombat 007.");
CODE

done_testing;