File Coverage

blib/lib/Test/MixedScripts.pm

Criterion	Covered	Total	%
statement	85	96	88.5
branch	20	26	76.9
condition	5	10	50.0
subroutine	19	24	79.1
pod	2	2	100.0
total	131	158	82.9

package Test::MixedScripts;

use utf8;

# ABSTRACT: test text for mixed and potentially confusable Unicode scripts

use v5.16;
use warnings;

use Carp          qw( croak );
use Exporter 5.57 qw( import );
use File::Basename qw( basename );
use File::Spec;
use IO            qw( File );
use List::Util    qw( first );
use Unicode::UCD  qw( charinfo charscripts );

use Test2::API 1.302200 qw( context );
use Test2::Util::DistFiles v0.2.0 qw( manifest_files is_perl_file );

our @EXPORT_OK = qw( all_perl_files_scripts_ok file_scripts_ok );

our $VERSION = 'v0.6.5';


sub file_scripts_ok {
    my ( $file, @args ) = @_;

    my $options = @args == 1 && ref( $args[0] ) eq "HASH" ? $args[0] : { scripts => \@args };
    $options->{scripts} //= [];
    push @{ $options->{scripts} }, qw( Latin Common ) unless defined $options->{scripts}[0];

    my $ctx = context();

    if ( my $error = _check_file_scripts( $file, $options ) ) {

        my ( $lino, $pre, $char ) = @{$error};

        # Ideally we would use charprop instead of charscript, since that supports Script_Extensions, but Unicode::UCD
        # is not dual life and charprop is only available after v5.22.0.

        my $info    = charinfo( ord($char) );
        my $message = sprintf(
            'Unexpected %s character %s on line %u character %u in %s',
            $info->{script},               #
            $info->{name} || "NO NAME",    #
            $lino,                         #
            length($pre) + 1,              #
            "$file"
        );

        $ctx->fail( $file, $message );

    }
    else {
        $ctx->pass( $file );
    }

    $ctx->release;
}

sub _check_file_scripts {
    my ( $file, $options ) = @_;

    my @scripts = @{ $options->{scripts} };
    my $default = _make_regex(@scripts);

    my $fh = IO::File->new( $file, "r" ) or croak "Cannot open ${file}: $!";

    $fh->binmode(":utf8");

    my $current = $default;

    while ( my $line = $fh->getline ) {
        my $re = $current;
        # TODO custom comment prefix based on the file type
        if ( $line =~ s/\s*##\s+Test::MixedScripts\s+(\w+(?:,\w+)*).*$// ) {
            $re = _make_regex( split /,\s*/, $1 );
        }
        elsif ( $line =~ /^=for\s+Test::MixedScripts\s+(\w+(?:,\w+)*)$/ ) {
            $current = $1 eq "default" ? $default : _make_regex( split /,\s*/, $1 );
            next;
        }

        unless ( $line =~ $re ) {
            my $fail = _make_negative_regex(@scripts);
            $line =~ $fail;
            return [ $fh->input_line_number, ${^PREMATCH}, ${^MATCH} ];
        }
    }

    $fh->close;

    return 0;
}

sub _make_regex_set {
    state $scripts = { ASCII => undef, map { $_ => 1 } keys %{ charscripts() } };
    if ( my $err = first { !exists $scripts->{$_} } @_ ) {
        croak "Unknown script ${err}";
    }
    return join( "", map { $_ eq "ASCII" ? '\x00-\x7f' : sprintf( '\p{scx=%s}', $_ ) } @_ );
}

sub _make_regex {
    my $set = _make_regex_set(@_);
    return qr/^[${set}]*$/u;
}

sub _make_negative_regex {
    my $set = _make_regex_set(@_);
    return qr/([^${set}])/up;
}


sub all_perl_files_scripts_ok {
    my $options = { };
    $options = shift if ref $_[0] eq 'HASH';
    my @files = manifest_files( \&is_perl_file);
    foreach my $file (@files) {
        file_scripts_ok( $file, $options );
    }
}

sub _is_perl_file {
    my ($file) = @_;
    return is_perl_file($file) || _is_pod_file($file) || _is_perl_config($file) || _is_xs_file($file) || _is_template($file);
}

sub _is_pod_file {
    $_[0] =~ /\.pod$/i;
}

sub _is_perl_config {
    my ($file) = @_;
    my $name = basename($file);
    return 1 if $name =~ /^(?:Rexfile|cpanfile)$/;
    return;
}

sub _is_xs_file {
    $_[0] =~ /\.(c|h|xs)$/i;
}

sub _is_template {
    my ($file) = @_;
    my $name = basename($file);
    return 1 if $name =~ /\.(?:epl?|inc|mc|psp|tal|tm?pl|tt)$/;
}

1;

__END__