File Coverage

blib/lib/Test/Portability/Files.pm

Criterion	Covered	Total	%
statement	80	99	80.8
branch	45	68	66.1
condition	10	18	55.5
subroutine	13	13	100.0
pod	3	3	100.0
total	151	201	75.1

package Test::Portability::Files;
$Test::Portability::Files::VERSION = '0.10';
# ABSTRACT: Check file names portability
use strict;
use warnings;
use ExtUtils::Manifest qw(maniread);
use File::Basename;
use File::Find;
use File::Spec;
use Test::Builder;
require Exporter;

our @ISA       = qw(Exporter);
our @EXPORT    = qw(&options &run_tests);
our @EXPORT_OK = @EXPORT;

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

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

    {
        ## no critic
        no strict 'refs';
        *{ $caller . '::options' }   = \&options;
        *{ $caller . '::run_tests' } = \&run_tests;
        ## use critic
    }

    $Test->exported_to($caller);
    $Test->plan( tests => 1 ) unless $Test->has_plan;
}

my %options = ( use_file_find => 0, );

my %tests = (
    ansi_chars    => 1,
    one_dot       => 1,
    dir_noext     => 1,
    special_chars => 1,
    space         => 1,
    mac_length    => 0,
    amiga_length  => 0,
    vms_length    => 1,
    dos_length    => 0,
    case          => 1,
    'symlink'     => 1,
    windows_reserved => 1,
);

my %errors_text =
    (    # wrap the text at this column --------------------------------> |
    ansi_chars =>
        "These files does not respect the portable filename characters\n"
        . "as defined by ANSI C and perlport:\n",

    one_dot => "These files contain more than one dot in their name:\n",

    dir_noext => "These directories have an extension in their name:\n",

    special_chars =>
        "These files contain special characters that may break on\n"
        . "several systems, please correct:\n",

    space => "These files contain space in their name, which is not well\n"
        . "handled on several systems:\n",

    mac_length =>
        "These files have a name more than 31 characters long, which\n"
        . "will be truncated on Mac OS Classic and old AmigaOS:\n",

    amiga_length =>
        "These files have a name more than 107 characters long, which\n"
        . "will be truncated on recent AmigaOS:\n",

    vms_length =>
        "These files have a name or extension too long for VMS (both\n"
        . "are limited to 39 characters):\n",

    dos_length =>
        "These files have a name too long for MS-DOS and compatible\n"
        . "systems:\n",

    case => "The name of these files differ only by the case, which can\n"
        . "cause real problems on case-insensitive filesystems:",

    windows_reserved =>
        "These files have names that correspond to reserved character devices\n"
         . "on Windows, and can cause unexpected problems:",

    'symlink' => "The following files are symbolic links, which are not\n"
        . "supported on several operating systems:",
    );

my %bad_names = ();
my %lc_names  = ();


sub options {
    my %opts = @_;
    for my $test ( keys %tests ) {
        $tests{$test} = $opts{"test_$test"} if exists $opts{"test_$test"};
    }
    for my $opt ( keys %options ) {
        $options{$opt} = $opts{$opt} if exists $opts{$opt};
    }
    @tests{ keys %tests } = ( $opts{all_tests} ) x ( keys %tests )
        if exists $opts{all_tests};
}


sub test_name_portability {
    my ( $file, $file_name, $file_path, $file_ext );

    # extract path, base name and extension
    if ( $options{use_file_find} ) {    # using Find::File
                                        # skip generated files
        return if $_ eq File::Spec->curdir or $_ eq 'pm_to_blib';
        my $firstdir = (
            File::Spec->splitdir( File::Spec->canonpath($File::Find::name) ) )
            [0];
        return if $firstdir eq 'blib' or $firstdir eq '_build';

        $file = $File::Find::name;
        ( $file_name, $file_path, $file_ext ) =
            fileparse( $file, '\\.[^.]+?' );

    }
    else {                              # only check against MANIFEST
        $file = shift;
        ( $file_name, $file_path, $file_ext ) =
            fileparse( $file, '\\.[^.]+?' );

      #for my $dir (File::Spec->splitdir(File::Spec->canonpath($file_path))) {
      #    test_name_portability($dir)
      #}

        $_ = $file_name . $file_ext;
    }

#print STDERR "file $file\t=> path='$file_path', name='$file_name', ext='$file_ext'\n";

# After this point, the following variables are expected to hold these semantics
#   $file must contain the path to the file (t/00load.t)
#   $_ must contain the full name of the file (00load.t)
#   $file_name must contain the base name of the file (00load)
#   $file_path must contain the path to the directory containing the file (t/)
#   $file_ext must contain the extension (if any) of the file (.t)

# check if the name only uses portable filename characters, as defined by ANSI C
    if ( $tests{ansi_chars} ) {
        /^[A-Za-z0-9._][A-Za-z0-9._-]*$/ or $bad_names{$file} .= 'ansi_chars,';
    }

    # check if the name is a Windows Reserved Filename
    if ( $tests{'windows_reserved'} ) {
        $file_name =~ /^(CON|PRN|AUX|NUL|COM[1-9]|LPT[1-9])(\..*)*$/i
            and $bad_names{$file} .= 'windows_reserved,';
    }

    # check if the name contains more than one dot
    if ( $tests{one_dot} ) {
        tr/.// > 1 and $bad_names{$file} .= 'one_dot,';
    }

    # check if the name contains special chars
    if ( $tests{special_chars} ) {
        m-[!"#\$%&'\(\)\*\+/:;<>\?@\[\\\]^`\{\|\}~]-
            and $bad_names{$file} .= 'special_chars,';
    }

    # check if the name contains a space char
    if ( $tests{space} ) {
        m/ / and $bad_names{$file} .= 'space,';
    }

    # check the length of the name, compared to Mac OS Classic max length
    if ( $tests{mac_length} ) {
        length > 31 and $bad_names{$file} .= 'mac_length,';
    }

    # check the length of the name, compared to AmigaOS max length
    if ( $tests{amiga_length} ) {
        length > 107 and $bad_names{$file} .= 'amiga_length,';
    }

    # check the length of the name, compared to VMS max length
    if ( $tests{vms_length} ) {
        ( length($file_name) <= 39 and length($file_ext) <= 40 )
            or $bad_names{$file} .= 'vms_length,';
    }

    # check the length of the name, compared to DOS max length
    if ( $tests{dos_length} ) {
        ( length($file_name) <= 8 and length($file_ext) <= 4 )
            or $bad_names{$file} .= 'dos_length,';
    }

    # check if the name is unique on case-insensitive filesystems
    if ( $tests{case} ) {
        if ( not $lc_names{$file} and $lc_names{ lc $file } ) {
            $bad_names{$file} .= 'case,';
            $bad_names{ $lc_names{ lc $file } } .= 'case,';
        }
        else {
            $lc_names{ lc $file } = $file;
        }
    }

    # check if the file is a symbolic link
    if ( $tests{'symlink'} ) {
        -l $file and $bad_names{$file} .= 'symlink,';
    }

    # if it's a directory, check that it has no extension
    if ( $tests{'dir_noext'} ) {
        -d $file and tr/.// > 0 and $bad_names{$file} .= 'dir_noext,';
    }
}


sub run_tests {
    fileparse_set_fstype('Unix');

    if ( $options{use_file_find} ) {

        # check all files found using File::Find
        find( \&test_name_portability, File::Spec->curdir );

    }
    else {
        # check only against files listed in MANIFEST
        my $manifest = maniread();
        map { test_name_portability($_) } keys %$manifest;
    }

    # check the results
    my $bad_names = _bad_names();
    if ( keys %$bad_names ) {
        $Test->ok( 0, "File names portability" );

        my %errors_list = ();
        for my $file ( keys %$bad_names ) {
            for my $error ( split ',', $bad_names->{$file} ) {
                $errors_list{$error} = [] if not ref $errors_list{$error};
                push @{ $errors_list{$error} }, $file;
            }
        }

        for my $error ( sort keys %errors_list ) {
            $Test->diag( $errors_text{$error} );

            for my $file ( sort @{ $errors_list{$error} } ) {
                $Test->diag("   $file");
            }

            $Test->diag(' ');
        }
    }
    else {
        $Test->ok( 1, "File names portability" );
    }
}


sub _bad_names {
    return \%bad_names;
}


1;

__END__