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

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
    require './test.pl';
}

use strict;
use warnings;
plan "no_plan";

my @pats=(
            "\\w",
	    "\\W",
	    "\\s",
	    "\\S",
	    "\\d",
	    "\\D",
            "\\h",
	    "\\H",
            "\\v",
	    "\\V",
	    "[:alnum:]",
	    "[:^alnum:]",
	    "[:alpha:]",
	    "[:^alpha:]",
	    "[:ascii:]",
	    "[:^ascii:]",
	    "[:cntrl:]",
	    "[:^cntrl:]",
	    "[:graph:]",
	    "[:^graph:]",
	    "[:lower:]",
	    "[:^lower:]",
	    "[:print:]",
	    "[:^print:]",
	    "[:punct:]",
	    "[:^punct:]",
	    "[:upper:]",
	    "[:^upper:]",
	    "[:xdigit:]",
	    "[:^xdigit:]",
	    "[:space:]",
	    "[:^space:]",
	    "[:blank:]",
	    "[:^blank:]" );

sub rangify {
    my $ary= shift;
    my $fmt= shift || '%d';
    my $sep= shift || ' ';
    my $rng= shift || '..';
    
    
    my $first= $ary->[0];
    my $last= $ary->[0];
    my $ret= sprintf $fmt, $first;
    for my $idx (1..$#$ary) {
        if ( $ary->[$idx] != $last + 1) {
            if ($last!=$first) {
                $ret.=sprintf "%s$fmt",$rng, $last;
            }             
            $first= $last= $ary->[$idx];
            $ret.=sprintf "%s$fmt",$sep,$first;
         } else {
            $last= $ary->[$idx];
         }
    }
    if ( $last != $first) {
        $ret.=sprintf "%s$fmt",$rng, $last;
    }
    return $ret;
}

# The bug is only fixed for /u
use feature 'unicode_strings';

my $description = "";
while (@pats) {
    my ($yes,$no)= splice @pats,0,2;
    
    my %err_by_type;
    my %singles;
    my %complements;
    foreach my $b (0..255) {
        my %got;
        my $display_b = sprintf("\\x%02X", $b);
        for my $type ('utf8','not-utf8') {
            my $str=chr($b).chr($b);
            if ($type eq 'utf8') {
                $str.=chr(256);
                chop $str;
            }
            if ($str=~/[$yes][$no]/){
                unlike($str,qr/[$yes][$no]/,
                    "chr($display_b) X 2 =~/[$yes][$no]/ should not match under $type");
                push @{$err_by_type{$type}},$b;
            }
            $got{"[$yes]"}{$type} = $str=~/[$yes]/ ? 1 : 0;
            $got{"[$no]"}{$type} = $str=~/[$no]/ ? 1 : 0;
            $got{"[^$yes]"}{$type} = $str=~/[^$yes]/ ? 1 : 0;
            $got{"[^$no]"}{$type} = $str=~/[^$no]/ ? 1 : 0;

# For \w, \s, and \d, \h, \v, also test without being in character
            # classes.
            next if $yes =~ /\[/;

# The rest of this .t was written when there were many test
            # failures, so it goes to some lengths to summarize things.  Now
            # those are fixed, so these missing tests just do standard
            # procedures

my $chr = chr($b);
            utf8::upgrade $chr if $type eq 'utf8';
            ok (($chr =~ /$yes/) != ($chr =~ /$no/),
                "$type: chr($display_b) isn't both $yes and $no");
        }
        foreach my $which ("[$yes]","[$no]","[^$yes]","[^$no]") {
            if ($got{$which}{'utf8'} != $got{$which}{'not-utf8'}){
                is($got{$which}{'utf8'},$got{$which}{'not-utf8'},
                    "chr($display_b) X 2=~ /$which/ should have the same results regardless of internal string encoding");
                push @{$singles{$which}},$b;
            }
        }
        foreach my $which ($yes,$no) {
            foreach my $strtype ('utf8','not-utf8') {
                if ($got{"[$which]"}{$strtype} == $got{"[^$which]"}{$strtype}) {
                    isnt($got{"[$which]"}{$strtype},$got{"[^$which]"}{$strtype},
                        "chr($display_b) X 2 =~ /[$which]/ should not have the same result as chr($display_b)=~/[^$which]/");
                    push @{$complements{$which}{$strtype}},$b;
                }
            }
        }
    }
    
    
    if (%err_by_type || %singles || %complements) {
        $description||=" Error:\n";
        $description .= "/[$yes][$no]/\n";
        if (%err_by_type) {
            foreach my $type (sort keys %err_by_type) {
                $description .= "\tmatches $type codepoints:\t";
                $description .= rangify($err_by_type{$type});
                $description .= "\n";
            }
            $description .= "\n";
        }
        if (%singles) {
            $description .= "Unicode/Nonunicode mismatches:\n";
            foreach my $type (sort keys %singles) {
                $description .= "\t$type:\t";
                $description .= rangify($singles{$type});
                $description .= "\n";
            }
            $description .= "\n";
        }
        if (%complements) {
            foreach my $class (sort keys %complements) {
                foreach my $strtype (sort keys %{$complements{$class}}) {
                    $description .= "\t$class has complement failures under $strtype for:\t";
                    $description .= rangify($complements{$class}{$strtype});
                    $description .= "\n";
                }
            }
        }
    }
}
__DATA__