Fix RT #54203 (reported by chocolateboy) that setters might return undef.

[gitmo/Mouse.git] / xt / 04_fs_portability.t

#!/usr/bin/perl

use strict;
use warnings;

Test::Portability::Files->import();

options(
    test_ansi_chars   => 0,
    test_dos_length   => 0,
    test_mac_length   => 0,
    test_amiga_length => 0,

);
run_tests();

# The following code is copied from Test::Portability::Files
# with the patch by RT #21631
# See http://rt.cpan.org/Public/Bug/Display.html?id=21631
BEGIN{
package Test::Portability::Files;
use strict;
use ExtUtils::Manifest qw(maniread);
use File::Basename;
#use File::Find;
use File::Spec;
use Test::Builder;

{ no strict;
  $VERSION = '0.05_01';
  @EXPORT = qw(&options &run_tests);
  @EXPORT_OK = @EXPORT;
}

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

sub import {
    my $self = shift;
    my $caller = caller;
    
    { no strict 'refs';
      *{$caller.'::options'}   = \&options;
      *{$caller.'::run_tests'} = \&run_tests;
    }
    
    $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    => 1, 
    amiga_length  => 1, 
    vms_length    => 1, 
    dos_length    => 0, 
    case          => 1, 
   'symlink'      => 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:", 

   '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} = (1)x(keys %tests) if $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 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-[!"#\$%&'\(\)\*\+/:;<>\?@\[\\\]^`\{\|\}~]- # " for poor editors
          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
    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");
    }
}

} # end of BEGIN