File Coverage

blib/lib/Test/Mojibake.pm

Criterion	Covered	Total	%
statement	171	176	97.1
branch	93	98	94.9
condition	21	21	100.0
subroutine	14	14	100.0
pod	3	3	100.0
total	302	312	96.7

package Test::Mojibake;
# ABSTRACT: check your source for encoding misbehavior.


use strict;
use warnings qw(all);

our $VERSION = '1.1'; # VERSION

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

my %ignore_dirs = (
    '.bzr'  => 'Bazaar',
    '.git'  => 'Git',
    '.hg'   => 'Mercurial',
    '.pc'   => 'quilt',
    '.svn'  => 'Subversion',
    CVS     => 'CVS',
    RCS     => 'RCS',
    SCCS    => 'SCCS',
    _darcs  => 'darcs',
    _sgbak  => 'Vault/Fortress',
);

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

# Use a faster/safer XS alternative, if present

## no critic (ProhibitStringyEval, RequireCheckingReturnValueOfEval)
eval 'require Unicode::CheckUTF8';

## no critic (ProhibitPackageVars)
our $use_xs = $@ ? 0 : 1;

sub import {
    my ($self, @args) = @_;
    my $caller = caller;

    for my $func (qw(file_encoding_ok all_files all_files_encoding_ok)) {
        ## no critic (ProhibitNoStrict)
        no strict 'refs';
        *{$caller."::".$func} = \&$func;
    }

    $Test->exported_to($caller);
    $Test->plan(@args);

    return;
}


## no critic (ProhibitCascadingIfElse, ProhibitExcessComplexity)
sub file_encoding_ok {
    my ($file, $name) = @_;
    $name = defined($name) ? $name : "Mojibake test for $file";

    ## no critic (ProhibitFiletest_f)
    unless (-f $file) {
        $Test->ok(0, $name);
        $Test->diag("$file does not exist");
        return;
    }

    my $fh;
    unless (open($fh, '<:raw', $file)) {
        close $fh;
        $Test->ok(0, $name);
        $Test->diag("Can't open $file: $!");
        return;
    }

    my $use_utf8    = 0;
    my $pod         = 0;
    my $pod_utf8    = 0;
    my $n           = 1;
    my %pod         = ();
    while (my $line = <$fh>) {
        if (($n == 1) && $line =~ /^\x{EF}\x{BB}\x{BF}/x) {
            $Test->ok(0, $name);
            $Test->diag("UTF-8 BOM (Byte Order Mark) found in $file");
            return;
        } elsif ($line =~ /^=+cut\s*$/x) {
            $pod = 0;
        } elsif ($line =~ /^=+encoding\s+([\w\-]+)/x) {
            my $pod_encoding = lc $1;
            $pod_encoding =~ y/-//d;

            # perlpod states:
            # =encoding affects the whole document, and must occur only once.
            ++$pod{$pod_encoding};
            if (1 < scalar keys %pod) {
                $Test->ok(0, $name);
                $Test->diag("POD =encoding redeclared in $file, line $n");
                return;
            }

            $pod_utf8 = ($pod_encoding eq 'utf8') ? 1 : 0;
            $pod = 1;
        } elsif ($line =~ /^=+\w+/x) {
            $pod = 1;
        } elsif ($pod == 0) {
            # source
            $line =~ s/^\s*\#.*$//sx;  # disclaimers placed in headers frequently contain UTF-8 *before* its usage is declared.
            foreach (split m{;}x, $line) {
                # trim
                s/^\s+|\s+$//gsx;

                my @type = qw(0 0 0);
                ++$type[_detect_utf8(\$_)];
                my ($latin1, $utf8) = @type[0, 2];

                if (/^use\s+utf8(?:::all)?$/x) {
                    $use_utf8 = 1;
                } elsif (/^use\s+common::sense$/x) {
                    $use_utf8 = 1;
                } elsif (/^no\s+utf8$/x) {
                    $use_utf8 = 0;
                }

                if (($use_utf8 == 0) && $utf8) {
                    $Test->ok(0, $name);
                    $Test->diag("UTF-8 unexpected in $file, line $n (source)");
                    return;
                } elsif (($use_utf8 == 1) && $latin1) {
                    $Test->ok(0, $name);
                    $Test->diag("Non-UTF-8 unexpected in $file, line $n (source)");
                    return;
                }
            }
        } else {
            # POD
            my @type = qw(0 0 0);
            ++$type[_detect_utf8(\$line)];
            my ($latin1, $utf8) = @type[0, 2];

            if (($pod_utf8 == 0) && $utf8) {
                $Test->ok(0, $name);
                $Test->diag("UTF-8 unexpected in $file, line $n (POD)");
                return;
            } elsif (($pod_utf8 == 1) && $latin1) {
                $Test->ok(0, $name);
                $Test->diag("Non-UTF-8 unexpected in $file, line $n (POD)");
                return;
            }
        }
    } continue {
        ++$n;
    }
    close $fh;

    $Test->ok(1, $name);
    return 1;
}


sub all_files_encoding_ok {
    my (@args) = @_;
    @args = _starting_points() unless @args;

    ## no critic (ProhibitFiletest_f)
    my @files = map { -d $_ ? all_files($_) : (-f $_ ? $_ : ()) } @args;

    unless (@files) {
        $Test->plan(skip_all => 'could not find any files to test');
        return;
    }

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

    my $ok = 1;
    foreach my $file (@files) {
        file_encoding_ok($file) or undef $ok;
    }
    return $ok;
}


sub all_files {
    my (@queue) = @_;
    @queue = _starting_points() unless @queue;
    my @mod = ();

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

            @newfiles = no_upwards(@newfiles);
            @newfiles = grep { not exists $ignore_dirs{$_} } @newfiles;

            foreach my $newfile (@newfiles) {
                my $filename = catfile($file, $newfile);
                unless (-d $filename) {
                    push @queue, $filename;
                } else {
                    push @queue, catdir($file, $newfile);
                }
            }
        }

        ## no critic (ProhibitFiletest_f)
        if (-f $file) {
            push @mod, $file if _is_perl($file);
        }
    }
    return @mod;
}

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

sub _is_perl {
    my $file = shift;

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

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

    return 1 if defined $first && ($first =~ /(?:^\#!.*perl)|--\*-Perl-\*--/x);

    return;
}


sub _detect_utf8 {

    use bytes;
    use integer;

    my $str     = shift;

    if ($use_xs) {
        if (Unicode::CheckUTF8::is_utf8(${$str})) {
            return (${$str} =~ m{[\x{80}-\x{ff}]}x) ? 2 : 1
        } else {
            return 0;
        }
    }

    my $d       = 0;
    my $c       = 0;
    my $bv      = 0;
    my $bits    = 0;
    my $len     = length ${$str};

    for (my $i = 0; $i < $len; $i++) {
        $c = ord(substr(${$str}, $i, 1));
        if ($c >= 128) {
            $d++;

            if ($c >= 254) {
                return 0;
            } elsif ($c >= 252) {
                $bits = 6;
            } elsif ($c >= 248) {
                $bits = 5;
            } elsif ($c >= 240) {
                $bits = 4;
            } elsif ($c >= 224) {
                $bits = 3;
            } elsif ($c >= 192) {
                $bits = 2;
            } else {
                return 0;
            }

            if (($i + $bits) > $len) {
                return 0;
            }

            my @buf = ((0) x 4, $c & ((1 << (6 - $bits)) - 1));
            while ($bits > 1) {
                $i++;
                $bv = ord(substr(${$str}, $i, 1));
                if (($bv < 128) || ($bv > 191)) {
                    return 0;
                }
                $buf[7 - $bits] = $bv & 0x3f;
                $bits--;
            }
            return 0 if "\0\0\0\0\0\x2f" eq pack 'c6', @buf;
        } elsif ($c == 0) {
            return 0;
        }
    }

    return $d ? 2 : 1;
}


1;

__END__