X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=xt%2F04_fs_portability.t;fp=xt%2F04_fs_portability.t;h=0000000000000000000000000000000000000000;hb=1a3ecabc7c07dec487e93b92c434577052790ca2;hp=aa4227df8758749dd95fecf6b76c331f9696121a;hpb=21f7fab953e0db7855980b545f8de0ce1c342525;p=gitmo%2FMouse.git diff --git a/xt/04_fs_portability.t b/xt/04_fs_portability.t deleted file mode 100644 index aa4227d..0000000 --- a/xt/04_fs_portability.t +++ /dev/null @@ -1,250 +0,0 @@ -#!/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