From: gfx Date: Fri, 18 Dec 2009 04:00:26 +0000 (+0900) Subject: Add filesystem portability test (indicated by RT #52828) X-Git-Tag: 0.45~18 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=41e3a7eaba19f2e2c70513774266fbc9e51ee07f Add filesystem portability test (indicated by RT #52828) --- diff --git a/xt/04_fs_portability.t b/xt/04_fs_portability.t new file mode 100644 index 0000000..aa4227d --- /dev/null +++ b/xt/04_fs_portability.t @@ -0,0 +1,250 @@ +#!/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