File Coverage

blib/lib/Test/PureASCII.pm

Criterion	Covered	Total	%
statement	97	150	64.6
branch	41	100	41.0
condition	7	24	29.1
subroutine	12	15	80.0
pod	3	7	42.8
total	160	296	54.0

package Test::PureASCII;

our $VERSION = '0.02';

use strict;
use warnings;

use Test::Builder;
use File::Spec;

my $test = Test::Builder->new;

our @TESTED;

sub import {
    my $self = shift;
    my $caller = caller;

    for my $func ( qw( file_is_pure_ascii all_perl_files_are_pure_ascii all_files_are_pure_ascii) ) {
        no strict 'refs';
        *{$caller."::".$func} = \&$func;
    }

    $test->exported_to($caller);
    $test->plan(@_);
}

sub _skip_file_p {
    my %opts;
    %opts = %{shift @_} if ref $_[0] eq 'HASH';
    if (defined(my $skip = $opts{skip})) {
        my $file = shift;
        for my $s (ref $skip eq 'ARRAY' ? @$skip : $skip) {
            if (ref $s eq 'Regexp') {
                return 1 if $file =~ $s;
            }
            else {
                return 1 if $file eq $s;
            }
        }
    }
    return 0;
}

sub _make_error {
    my ($bad, $error, $ln, $file) = @_;
    my @chars = map sprintf("0x%02x", ord $_), split //, $bad;
    my $chars = join(', ', @chars);
    my $s = @chars > 1 ? ' sequence' : '';
    '  ' . sprintf($error, $s, $chars) . " at line $ln in $file";
}

sub file_is_pure_ascii {
    my %opts;
    %opts = %{shift @_} if ref $_[0] eq 'HASH';
    my $skip_data = $opts{skip_data};
    my $forbid_control = $opts{forbid_control};
    my $forbid_cr = $opts{forbid_cr};
    my $forbid_tab = $opts{forbid_tab};
    my $require_crlf = $opts{require_crlf};

    my $file = shift;

    _skip_file_p(\%opts, $file) and return 1;

    my $name = @_ ? shift : "Pure ASCII test for $file";

    push @TESTED, $file;
    # $test->diag("FILE: $file");

    my $fh;
    unless (open $fh, '<', $file) {
        $test->ok(0, $name);
        $test->diag("  unable to open '$file': $!");
        return 0;
    }
    binmode $fh, ':bytes';

    my $failed = 0;
    while (<$fh>) {
        # $test->diag("line $.: $_");
        next if /\bpa_test_ignore\b/;
        last if /\bpa_test_end\b/;
        if (my ($lines) = /pa_test_skip_lines\(\d+\)/) {
            <$fh> for 1..$lines;
            next;
        }

        my @errors;
        /([^\x00-\x7f]+)/ and
            push @errors, _make_error($1, "non ASCII character%s %s",
                                      $., $file);
        $forbid_control and /([\x00-\x08\x0b-\x1F])/ and
            push @errors, _make_error($1, "forbidden control character%s %s",
                                      $., $file);
        $forbid_tab and /([\x09])/ and
            push @errors, _make_error($1, "forbidden tab character%s %s",
                                      $., $file);
        $forbid_cr and /([\x0d])/ and
            push @errors, _make_error($1, "forbidden CR character%s %s",
                                      $., $file);
        $require_crlf and /(\x0d(?!\x0a)|(?
            push @errors, _make_error($a, "forbidden end of line character%s %s",
                                      $., $file);

        if (@errors) {
            $test->ok(0, $name) unless $failed;
            $test->diag($_) for @errors;
            $failed = 1;
        }

        last if ($skip_data and /^__DATA__$/);
    }
    unless (close $fh) {
        $test->ok(0, $name) unless $failed;
        $test->diag("  unable to read from '$file': $!");
        return 0;
    }
    $failed ? 0 : $test->ok(1, $name);
}

sub all_perl_files_are_pure_ascii {
    my %opts;
    %opts = %{shift @_} if ref $_[0] eq 'HASH';

    my @files = all_perl_files(\%opts, @_);

    $test->plan( tests => scalar @files );

    my $ok = 1;
    foreach my $file (@files) {
        file_is_pure_ascii(\%opts, $file) or undef $ok;
    }
    return $ok;
}

sub all_files_are_pure_ascii {
    my %opts;
    %opts = %{shift @_} if ref $_[0] eq 'HASH';

    my @files = all_files(\%opts, @_);
    $test->plan( tests => scalar @files );

    my $ok = 1;
    foreach my $file (@files) {
        file_is_pure_ascii(\%opts, $file) or undef $ok;
    }
    return $ok;
}

sub all_perl_files {
    my %opts;
    %opts = %{shift @_} if ref $_[0] eq 'HASH';

    my @queue = @_ ? @_ : starting_points();
    my @perl = ();

    while ( @queue ) {
        my $file = shift @queue;
        if ( -d $file ) {
            opendir my $dh, $file or next;
            my @newfiles = readdir $dh;
            closedir $dh;

            @newfiles = File::Spec->no_upwards( @newfiles );
            @newfiles = grep { $_ ne "CVS" and $_ ne ".svn" and !/~$/ } @newfiles;

            foreach my $newfile (@newfiles) {
                my $filename = File::Spec->catfile( $file, $newfile );
                if ( -f $filename ) {
                    push @queue, $filename;
                }
                else {
                    push @queue, File::Spec->catdir( $file, $newfile );
                }
            }
        }
        if ( -f $file ) {
            push @perl, $file if is_perl( $file );
        }
    }
    return @perl;
}

sub all_files {
    my %opts;
    %opts = %{shift @_} if ref $_[0] eq 'HASH';

    my @queue = @_ ? @_ : '.';
    my @all = ();

    while ( @queue ) {
        my $file = shift @queue;
        if ( -d $file ) {
            opendir my $dh, $file or next;
            my @newfiles = readdir $dh;
            closedir $dh;

            @newfiles = File::Spec->no_upwards( @newfiles );
            @newfiles = grep { $_ ne "CVS" and $_ ne ".svn" and !/~$/ } @newfiles;

            foreach my $newfile (@newfiles) {
                my $filename = File::Spec->catfile( $file, $newfile );
                if ( -f $filename ) {
                    push @queue, $filename;
                }
                else {
                    push @queue, File::Spec->catdir( $file, $newfile );
                }
            }
        }
        push @all, $file if -f $file
    }
    return @all;
}

sub starting_points {
    return 'blib' if -e 'blib';
    return 'lib';
}

sub is_perl {
    my $file = shift;

    return 1 if $file =~ /\.PL$/;
    return 1 if $file =~ /\.p(l|m|od)$/;
    return 1 if $file =~ /\.t$/;

    open my $fh, $file or return;
    my $first = <$fh>;
    close $fh;

    return 1 if defined $first && ($first =~ /^#!.*perl/);

    return;
}


1;

__END__