Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
BHK.pm	260 B	-r--r--r--	2014-12-27 11:48
Block.pm	9 B	-r--r--r--	2014-12-27 11:48
Markers.pm	245 B	-r--r--r--	2014-12-27 11:48
Null.pm	3 B	-r--r--r--	2014-12-27 11:48
addissub.t	481 B	-r--r--r--	2014-12-27 11:48
arrayexpr.t	7.85 KB	-r--r--r--	2014-12-27 11:48
autoload.t	4.03 KB	-r--r--r--	2014-12-27 11:48
blockasexpr.t	1.46 KB	-r--r--r--	2014-12-27 11:48
blockhooks-csc.t	2.26 KB	-r--r--r--	2014-12-27 11:48
blockhooks.t	5.21 KB	-r--r--r--	2014-12-27 11:48
call.t	8.9 KB	-r--r--r--	2014-12-27 11:49
call_checker.t	4.03 KB	-r--r--r--	2014-12-27 11:49
caller.t	1.78 KB	-r--r--r--	2014-12-27 11:48
callregexec.t	2.46 KB	-r--r--r--	2014-12-27 11:49
check_warnings.t	495 B	-r--r--r--	2014-12-27 11:48
cleanup.t	1.41 KB	-r--r--r--	2014-12-27 11:48
clone-with-stack.t	1.45 KB	-r--r--r--	2015-01-10 12:06
cophh.t	280 B	-r--r--r--	2014-12-27 11:48
coplabel.t	112 B	-r--r--r--	2014-12-27 11:48
copstash.t	156 B	-r--r--r--	2014-12-27 11:48
copyhints.t	123 B	-r--r--r--	2014-12-27 11:48
customop.t	2.42 KB	-r--r--r--	2014-12-27 11:49
eval-filter.t	743 B	-r--r--r--	2014-12-27 11:48
exception.t	616 B	-r--r--r--	2014-12-27 11:48
fetch_pad_names.t	10.58 KB	-r--r--r--	2014-12-27 11:49
gotosub.t	351 B	-r--r--r--	2014-12-27 11:48
grok.t	2.07 KB	-r--r--r--	2014-12-27 11:49
gv_autoload4.t	2.01 KB	-r--r--r--	2014-12-27 11:48
gv_fetchmeth.t	2.3 KB	-r--r--r--	2014-12-27 11:48
gv_fetchmeth_autoload.t	3.38 KB	-r--r--r--	2014-12-27 11:48
gv_fetchmethod_flags.t	1.86 KB	-r--r--r--	2014-12-27 11:48
gv_init.t	489 B	-r--r--r--	2014-12-27 11:48
handy.t	15.33 KB	-r--r--r--	2014-12-27 11:49
hash.t	17.07 KB	-r--r--r--	2014-12-27 11:48
keyword_multiline.t	259 B	-r--r--r--	2014-12-27 11:48
keyword_plugin.t	1.15 KB	-r--r--r--	2014-12-27 11:48
labelconst.aux	146 B	-r--r--r--	2014-12-27 11:48
labelconst.t	2.63 KB	-r--r--r--	2014-12-27 11:48
labelconst_utf8.aux	194 B	-r--r--r--	2014-12-27 11:48
lexsub.t	524 B	-r--r--r--	2014-12-27 11:48
loopblock.t	1.46 KB	-r--r--r--	2014-12-27 11:48
looprest.t	1.39 KB	-r--r--r--	2014-12-27 11:48
lvalue.t	800 B	-r--r--r--	2014-12-27 11:48
magic.t	804 B	-r--r--r--	2014-12-27 11:49
magic_chain.t	115 B	-r--r--r--	2014-12-27 11:48
mro.t	237 B	-r--r--r--	2014-12-27 11:48
multicall.t	1.32 KB	-r--r--r--	2014-12-27 11:48
my_cxt.t	1.28 KB	-r--r--r--	2014-12-27 11:48
my_exit.t	790 B	-r--r--r--	2014-12-27 11:48
newCONSTSUB.t	2.58 KB	-r--r--r--	2014-12-27 11:48
op.t	359 B	-r--r--r--	2014-12-27 11:48
op_contextualize.t	120 B	-r--r--r--	2014-12-27 11:48
op_list.t	151 B	-r--r--r--	2014-12-27 11:48
overload.t	2.21 KB	-r--r--r--	2014-12-27 11:48
pad_scalar.t	1.83 KB	-r--r--r--	2014-12-27 11:48
peep.t	1013 B	-r--r--r--	2014-12-27 11:48
pmflag.t	192 B	-r--r--r--	2014-12-27 11:48
postinc.t	800 B	-r--r--r--	2014-12-27 11:48
printf.t	1.05 KB	-r--r--r--	2014-12-27 11:49
ptr_table.t	916 B	-r--r--r--	2014-12-27 11:48
push.t	746 B	-r--r--r--	2014-12-27 11:48
refs.t	578 B	-r--r--r--	2014-12-27 11:48
rmagical.t	823 B	-r--r--r--	2014-12-27 11:48
rv2cv_op_cv.t	115 B	-r--r--r--	2014-12-27 11:48
savehints.t	123 B	-r--r--r--	2014-12-27 11:48
scopelessblock.t	1.59 KB	-r--r--r--	2014-12-27 11:48
sort.t	411 B	-r--r--r--	2014-12-27 11:48
stmtasexpr.t	893 B	-r--r--r--	2014-12-27 11:48
stmtsasexpr.t	949 B	-r--r--r--	2014-12-27 11:48
stuff_modify_bug.t	151 B	-r--r--r--	2014-12-27 11:48
stuff_svcur_bug.t	260 B	-r--r--r--	2014-12-27 11:48
subcall.t	179 B	-r--r--r--	2014-12-27 11:48
sviscow.t	229 B	-r--r--r--	2014-12-27 11:48
svpeek.t	3.16 KB	-r--r--r--	2014-12-27 11:49
svpv.t	1.01 KB	-r--r--r--	2014-12-27 11:48
svpv_magic.t	1.29 KB	-r--r--r--	2014-12-27 11:48
svsetsv.t	1015 B	-r--r--r--	2014-12-27 11:48
swaplabel.t	7.06 KB	-r--r--r--	2014-12-27 11:48
swaptwostmts.t	2.79 KB	-r--r--r--	2014-12-27 11:48
sym-hook.t	730 B	-r--r--r--	2014-12-27 11:48
temp_lv_sub.t	532 B	-r--r--r--	2014-12-27 11:48
underscore_length.t	338 B	-r--r--r--	2014-12-27 11:48
utf16_to_utf8.t	2.09 KB	-r--r--r--	2014-12-27 11:48
utf8.t	13.46 KB	-r--r--r--	2014-12-27 11:48
whichsig.t	653 B	-r--r--r--	2014-12-27 11:48
xs_special_subs.t	6.54 KB	-r--r--r--	2014-12-27 11:48
xs_special_subs_require.t	7.46 KB	-r--r--r--	2014-12-27 11:48
xsub_h.t	2.81 KB	-r--r--r--	2014-12-27 11:48

Rename

#!perl -w

BEGIN {
    require 'loc_tools.pl';   # Contains find_utf8_ctype_locale()
}

use strict;
use Test::More;
use Config;

use XS::APItest;

use Unicode::UCD qw(prop_invlist prop_invmap);

sub truth($) {  # Converts values so is() works
    return (shift) ? 1 : 0;
}

my $locale;
my $utf8_locale;
if($Config{d_setlocale}) {
    require POSIX;
    $locale = POSIX::setlocale( &POSIX::LC_ALL, "C");
    if (defined $locale && $locale eq 'C') {
        BEGIN {
            if($Config{d_setlocale}) {
                require locale; import locale; # make \w work right in non-ASCII lands
            }
        }

# Some locale implementations don't have the 128-255 characters all
        # mean nothing.  Skip the locale tests in that situation
        for my $i (128 .. 255) {
            if (chr($i) =~ /[[:print:]]/) {
                undef $locale;
                last;
            }
        }

$utf8_locale = find_utf8_ctype_locale();
    }
}

my %properties = (
                   # name => Lookup-property name
                   alnum => 'Word',
                   wordchar => 'Word',
                   alphanumeric => 'Alnum',
                   alpha => 'Alpha',
                   ascii => 'ASCII',
                   blank => 'Blank',
                   cntrl => 'Control',
                   digit => 'Digit',
                   graph => 'Graph',
                   idfirst => '_Perl_IDStart',
                   idcont => '_Perl_IDCont',
                   lower => 'Lower',
                   print => 'Print',
                   psxspc => 'XPosixSpace',
                   punct => 'XPosixPunct',
                   quotemeta => '_Perl_Quotemeta',
                   space => 'XPerlSpace',
                   vertws => 'VertSpace',
                   upper => 'Upper',
                   xdigit => 'XDigit',
                );

my @warnings;
local $SIG{__WARN__} = sub { push @warnings, @_ };

use charnames ();
foreach my $name (sort keys %properties) {
    my $property = $properties{$name};
    my @invlist = prop_invlist($property, '_perl_core_internal_ok');
    if (! @invlist) {
        fail("No inversion list found for $property");
        next;
    }

# Include all the Latin1 code points, plus 0x100.
    my @code_points = (0 .. 256);

# Then include the next few boundaries above those from this property
    my $above_latins = 0;
    foreach my $range_start (@invlist) {
        next if $range_start < 257;
        push @code_points, $range_start - 1, $range_start;
        $above_latins++;
        last if $above_latins > 5;
    }

# This makes sure we are using the Perl definition of idfirst and idcont,
    # and not the Unicode.  There are a few differences.
    push @code_points, ord "\N{ESTIMATED SYMBOL}" if $name =~ /^id(first|cont)/;
    if ($name eq "idcont") {    # And some that are continuation but not start
        push @code_points, ord("\N{GREEK ANO TELEIA}"),
                           ord("\N{COMBINING GRAVE ACCENT}");
    }

# And finally one non-Unicode code point.
    push @code_points, 0x110000;    # Above Unicode, no prop should match
    no warnings 'non_unicode';

for my $j (@code_points) {
        my $i = utf8::native_to_unicode($j);
        my $function = uc($name);

my $matches = Unicode::UCD::search_invlist(\@invlist, $i);
        if (! defined $matches) {
            $matches = 0;
        }
        else {
            $matches = truth(! ($matches % 2));
        }

my $ret;
        my $char_name = charnames::viacode($i) // "No name";
        my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;

if ($name eq 'quotemeta') { # There is only one macro for this, and is
                                    # defined only for Latin1 range
            $ret = truth eval "test_is${function}($i)";
            if ($@) {
                fail $@;
            }
            else {
                my $truth = truth($matches && $i < 256);
                is ($ret, $truth, "is${function}( $display_name ) == $truth");
            }
            next;
        }

# vertws is always all of Unicode; ALNUM_A and ALNUM_L1 are not
        # defined as they were added later, after WORDCHAR was created to be a
        # clearer synonym for ALNUM
        if ($name ne 'vertws') {
            if ($name ne 'alnum') {
                $ret = truth eval "test_is${function}_A($i)";
                if ($@) {
                    fail($@);
                }
                else {
                    my $truth = truth($matches && $i < 128);
                    is ($ret, $truth, "is${function}_A( $display_name ) == $truth");
                }
                $ret = truth eval "test_is${function}_L1($i)";
                if ($@) {
                    fail($@);
                }
                else {
                    my $truth = truth($matches && $i < 256);
                    is ($ret, $truth, "is${function}_L1( $display_name ) == $truth");
                }
            }

if (defined $locale) {
                require locale; import locale;

POSIX::setlocale( &POSIX::LC_ALL, "C");
                $ret = truth eval "test_is${function}_LC($i)";
                if ($@) {
                    fail($@);
                }
                else {
                    my $truth = truth($matches && $i < 128);
                    is ($ret, $truth, "is${function}_LC( $display_name ) == $truth (C locale)");
                }
            }

if (defined $utf8_locale) {
                use locale;

POSIX::setlocale( &POSIX::LC_ALL, $utf8_locale);
                $ret = truth eval "test_is${function}_LC($i)";
                if ($@) {
                    fail($@);
                }
                else {

# UTF-8 locale works on full range 0-255
                    my $truth = truth($matches && $i < 256);
                    is ($ret, $truth, "is${function}_LC( $display_name ) == $truth ($utf8_locale)");
                }
            }
        }

$ret = truth eval "test_is${function}_uni($i)";
        if ($@) {
            fail($@);
        }
        else {
            is ($ret, $matches, "is${function}_uni( $display_name ) == $matches");
        }

if (defined $locale && $name ne 'vertws') {
            require locale; import locale;

POSIX::setlocale( &POSIX::LC_ALL, "C");
            $ret = truth eval "test_is${function}_LC_uvchr('$i')";
            if ($@) {
                fail($@);
            }
            else {
                my $truth = truth($matches && ($i < 128 || $i > 255));
                is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth (C locale)");
            }
        }

if (defined $utf8_locale && $name ne 'vertws') {
            use locale;

POSIX::setlocale( &POSIX::LC_ALL, $utf8_locale);
            $ret = truth eval "test_is${function}_LC_uvchr('$i')";
            if ($@) {
                fail($@);
            }
            else {
                my $truth = truth($matches);
                is ($ret, $truth, "is${function}_LC_uvchr( $display_name ) == $truth ($utf8_locale)");
            }
        }

my $char = chr($i);
        utf8::upgrade($char);
        $char = quotemeta $char if $char eq '\\' || $char eq "'";
        $ret = truth eval "test_is${function}_utf8('$char')";
        if ($@) {
            fail($@);
        }
        else {
            is ($ret, $matches, "is${function}_utf8( $display_name ) == $matches");
        }

if ($name ne 'vertws' && defined $locale) {
            require locale; import locale;

POSIX::setlocale( &POSIX::LC_ALL, "C");
            $ret = truth eval "test_is${function}_LC_utf8('$char')";
            if ($@) {
                fail($@);
            }
            else {
                my $truth = truth($matches && ($i < 128 || $i > 255));
                is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth (C locale)");
            }
        }

if ($name ne 'vertws' && defined $utf8_locale) {
            use locale;

POSIX::setlocale( &POSIX::LC_ALL, $utf8_locale);
            $ret = truth eval "test_is${function}_LC_utf8('$char')";
            if ($@) {
                fail($@);
            }
            else {
                my $truth = truth($matches);
                is ($ret, $truth, "is${function}_LC_utf8( $display_name ) == $truth ($utf8_locale)");
            }
        }
    }
}

my %to_properties = (
                FOLD => 'Case_Folding',
                LOWER => 'Lowercase_Mapping',
                TITLE => 'Titlecase_Mapping',
                UPPER => 'Uppercase_Mapping',
            );

foreach my $name (sort keys %to_properties) {
    my $property = $to_properties{$name};
    my ($list_ref, $map_ref, $format, $missing)
                                      = prop_invmap($property, );
    if (! $list_ref || ! $map_ref) {
        fail("No inversion map found for $property");
        next;
    }
    if ($format ne "al") {
        fail("Unexpected inversion map format ('$format') found for $property");
        next;
    }

# Include all the Latin1 code points, plus 0x100.
    my @code_points = (0 .. 256);

# Then include the next few multi-char folds above those from this
    # property, and include the next few single folds as well
    my $above_latins = 0;
    my $multi_char = 0;
    for my $i (0 .. @{$list_ref} - 1) {
        my $range_start = $list_ref->[$i];
        next if $range_start < 257;
        if (ref $map_ref->[$i] && $multi_char < 5)  {
            push @code_points, $range_start - 1 if $code_points[-1] != $range_start - 1;
            push @code_points, $range_start;
            $multi_char++;
        }
        elsif ($above_latins < 5) {
            push @code_points, $range_start - 1 if $code_points[-1] != $range_start - 1;
            push @code_points, $range_start;
            $above_latins++;
        }
        last if $above_latins >= 5 && $multi_char >= 5;
    }

# And finally one non-Unicode code point.
    push @code_points, 0x110000;    # Above Unicode, no prop should match
    no warnings 'non_unicode';

# $j is native; $i unicode.
    for my $j (@code_points) {
        my $i = utf8::native_to_unicode($j);
        my $function = $name;

my $index = Unicode::UCD::search_invlist(\@{$list_ref}, $j);

my $ret;
        my $char_name = charnames::viacode($j) // "No name";
        my $display_name = sprintf "\\N{U+%02X, %s}", $i, $char_name;

# Test the base function
        $ret = eval "test_to${function}($j)";
        if ($@) {
            fail($@);
        }
        else {
            my $should_be = ($i < 128 && $map_ref->[$index] != $missing)
                             ? $map_ref->[$index] + $j - $list_ref->[$index]
                             : $j;
            is ($ret, $should_be, sprintf("to${function}( $display_name ) == 0x%02X", $should_be));
        }

# Test _L1
        if ($name eq 'LOWER') {
            $ret = eval "test_to${function}_L1($j)";
            if ($@) {
                fail($@);
            }
            else {
                my $should_be = ($i < 256 && $map_ref->[$index] != $missing)
                                ? $map_ref->[$index] + $j - $list_ref->[$index]
                                : $j;
                is ($ret, $should_be, sprintf("to${function}_L1( $display_name ) == 0x%02X", $should_be));
            }
        }

if ($name ne 'TITLE') { # Test _LC;  titlecase is not defined in locales.
            if (defined $locale) {
                require locale; import locale;

POSIX::setlocale( &POSIX::LC_ALL, "C");
                $ret = eval "test_to${function}_LC($j)";
                if ($@) {
                    fail($@);
                }
                else {
                    my $should_be = ($i < 128 && $map_ref->[$index] != $missing)
                                ? $map_ref->[$index] + $j - $list_ref->[$index]
                                : $j;
                    is ($ret, $should_be, sprintf("to${function}_LC( $display_name ) == 0x%02X (C locale)", $should_be));
                }
            }

if (defined $utf8_locale) {
                use locale;

SKIP: {
                    skip "to${property}_LC does not work for LATIN SMALL LETTER SHARP S", 1
                        if $j == 0xDF && ($name eq 'FOLD' || $name eq 'UPPER');

POSIX::setlocale( &POSIX::LC_ALL, $utf8_locale);
                    $ret = eval "test_to${function}_LC($j)";
                    if ($@) {
                        fail($@);
                    }
                    else {
                        my $should_be = ($i < 256
                                         && ! ref $map_ref->[$index]
                                         && $map_ref->[$index] != $missing
                                        )
                                        ? $map_ref->[$index] + $j - $list_ref->[$index]
                                        : $j;
                        is ($ret, $should_be, sprintf("to${function}_LC( $display_name ) == 0x%02X ($utf8_locale)", $should_be));
                    }
                }
            }
        }

# The _uni and _utf8 functions return both the ordinal of the first
        # code point of the result, and the result in utf8.  The .xs tests
        # return these in an array, in [0] and [1] respectively, with [2] the
        # length of the utf8 in bytes.
        my $utf8_should_be = "";
        my $first_ord_should_be;
        if (ref $map_ref->[$index]) {   # A multi-char result
            for my $j (0 .. @{$map_ref->[$index]} - 1) {
                $utf8_should_be .= chr $map_ref->[$index][$j];
            }

$first_ord_should_be = $map_ref->[$index][0];
        }
        else {  # A single-char result
            $first_ord_should_be = ($map_ref->[$index] != $missing)
                                    ? $map_ref->[$index] + $j - $list_ref->[$index]
                                    : $j;
            $utf8_should_be = chr $first_ord_should_be;
        }
        utf8::upgrade($utf8_should_be);

# Test _uni
        my $s;
        my $len;
        $ret = eval "test_to${function}_uni($j)";
        if ($@) {
            fail($@);
        }
        else {
            is ($ret->[0], $first_ord_should_be, sprintf("to${function}_uni( $display_name ) == 0x%02X", $first_ord_should_be));
            is ($ret->[1], $utf8_should_be, sprintf("utf8 of to${function}_uni( $display_name )"));
            use bytes;
            is ($ret->[2], length $utf8_should_be, sprintf("number of bytes in utf8 of to${function}_uni( $display_name )"));
        }

# Test _utf8
        my $char = chr($j);
        utf8::upgrade($char);
        $char = quotemeta $char if $char eq '\\' || $char eq "'";
        $ret = eval "test_to${function}_utf8('$char')";
        if ($@) {
            fail($@);
        }
        else {
            is ($ret->[0], $first_ord_should_be, sprintf("to${function}_utf8( $display_name ) == 0x%02X", $first_ord_should_be));
            is ($ret->[1], $utf8_should_be, sprintf("utf8 of to${function}_utf8( $display_name )"));
            use bytes;
            is ($ret->[2], length $utf8_should_be, sprintf("number of bytes in utf8 of to${function}_uni( $display_name )"));
        }

}
}

# This is primarily to make sure that no non-Unicode warnings get generated
is(scalar @warnings, 0, "No warnings were generated " . join ", ", @warnings);

done_testing;