view release on metacpan or  search on metacpan

lib/unicore/mktables  view on Meta::CPAN

                "# ",scalar(@files_actually_output)+1," output files\n\n",
                "# End list\n";
        close $ofh
            or Carp::my_carp("Failed to close $ofh: $!");

        print "Filelist has ",scalar(@input_files)," input files and ",
            scalar(@files_actually_output)+1," output files\n"
            if $verbosity >= $VERBOSE;
    }
}

# Output these warnings unless -q explicitly specified.
if ($verbosity >= $NORMAL_VERBOSITY && ! $debug_skip) {
    if (@unhandled_properties) {
        print "\nProperties and tables that unexpectedly have no code points\n";
        foreach my $property (sort @unhandled_properties) {
            print $property, "\n";
        }
    }

    if (%potential_files) {
        print "\nInput files that are not considered:\n";
        foreach my $file (sort keys %potential_files) {
            print File::Spec->abs2rel($file), "\n";
        }
    }
    print "\nAll done\n" if $verbosity >= $VERBOSE;
}

if ($version_of_mk_invlist_bounds lt $v_version) {
    Carp::my_carp("WARNING: \\b{} algorithms (regen/mk_invlist.pl) need"
                . " to be checked and possibly updated to Unicode"
                . " $string_version.  Failing tests will be marked TODO");
}

exit(0);

# TRAILING CODE IS USED BY make_property_test_script()
__DATA__

use strict;
use warnings;

use feature 'signatures';

no warnings 'experimental::uniprop_wildcards';

# Test qr/\X/ and the \p{} regular expression constructs.  This file is
# constructed by mktables from the tables it generates, so if mktables is
# buggy, this won't necessarily catch those bugs.  Tests are generated for all
# feasible properties; a few aren't currently feasible; see
# is_code_point_usable() in mktables for details.

# Standard test packages are not used because this manipulates SIG_WARN.  It
# exits 0 if every non-skipped test succeeded; -1 if any failed.

my $Tests = 0;
my $Fails = 0;

# loc_tools.pl requires this function to be defined
sub ok($pass, @msg) {
    print "not " unless $pass;
    print "ok ";
    print ++$Tests;
    print " - ", join "", @msg if @msg;
    print "\n";
}

sub Expect($expected, $ord, $regex, $warning_type='') {
    my $line   = (caller)[2];

    # Convert the code point to hex form
    my $string = sprintf "\"\\x{%04X}\"", $ord;

    my @tests = "";

    # The first time through, use all warnings.  If the input should generate
    # a warning, add another time through with them turned off
    push @tests, "no warnings '$warning_type';" if $warning_type;

    foreach my $no_warnings (@tests) {

        # Store any warning messages instead of outputting them
        local $SIG{__WARN__} = $SIG{__WARN__};
        my $warning_message;
        $SIG{__WARN__} = sub { $warning_message = $_[0] };

        $Tests++;

        # A string eval is needed because of the 'no warnings'.
        # Assumes no parentheses in the regular expression
        my $result = eval "$no_warnings
                            my \$RegObj = qr($regex);
                            $string =~ \$RegObj ? 1 : 0";
        if (not defined $result) {
            print "not ok $Tests - couldn't compile /$regex/; line $line: $@\n";
            $Fails++;
        }
        elsif ($result ^ $expected) {
            print "not ok $Tests - expected $expected but got $result for $string =~ qr/$regex/; line $line\n";
            $Fails++;
        }
        elsif ($warning_message) {
            if (! $warning_type || ($warning_type && $no_warnings)) {
                print "not ok $Tests - for qr/$regex/ did not expect warning message '$warning_message'; line $line\n";
                $Fails++;
            }
            else {
                print "ok $Tests - expected and got a warning message for qr/$regex/; line $line\n";
            }
        }
        elsif ($warning_type && ! $no_warnings) {
            print "not ok $Tests - for qr/$regex/ expected a $warning_type warning message, but got none; line $line\n";
            $Fails++;
        }
        else {
            print "ok $Tests - got $result for $string =~ qr/$regex/; line $line\n";
        }
    }
    return;
}