xt/04_fs_portability.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 Test::Portability::Files->import();
   7
   8 options(
   9     test_ansi_chars   => 0,
  10     test_dos_length   => 0,
  11     test_mac_length   => 0,
  12     test_amiga_length => 0,
  13
  14 );
  15 run_tests();
  16
  17 # The following code is copied from Test::Portability::Files
  18 # with the patch by RT #21631
  19 # See http://rt.cpan.org/Public/Bug/Display.html?id=21631
  20 BEGIN{
  21 package Test::Portability::Files;
  22 use strict;
  23 use ExtUtils::Manifest qw(maniread);
  24 use File::Basename;
  25 #use File::Find;
  26 use File::Spec;
  27 use Test::Builder;
  28
  29 { no strict;
  30   $VERSION = '0.05_01';
  31   @EXPORT = qw(&options &run_tests);
  32   @EXPORT_OK = @EXPORT;
  33 }
  34
  35 my $Test = Test::Builder->new;
  36
  37 sub import {
  38     my $self = shift;
  39     my $caller = caller;
  40
  41     { no strict 'refs';
  42       *{$caller.'::options'}   = \&options;
  43       *{$caller.'::run_tests'} = \&run_tests;
  44     }
  45
  46     $Test->exported_to($caller);
  47     $Test->plan(tests => 1) unless $Test->has_plan;
  48 }
  49
  50 my %options = (
  51     use_file_find => 0,
  52 );
  53
  54 my %tests = (
  55     ansi_chars    => 1,
  56     one_dot       => 1,
  57     dir_noext     => 1,
  58     special_chars => 1,
  59     space         => 1,
  60     mac_length    => 1,
  61     amiga_length  => 1,
  62     vms_length    => 1,
  63     dos_length    => 0,
  64     case          => 1,
  65    'symlink'      => 1,
  66 );
  67
  68 my %errors_text = (  # wrap the text at this column --------------------------------> |
  69     ansi_chars    => "These files does not respect the portable filename characters\n"
  70                     ."as defined by ANSI C and perlport:\n",
  71
  72     one_dot       => "These files contain more than one dot in their name:\n",
  73
  74     dir_noext     => "These directories have an extension in their name:\n",
  75
  76     special_chars => "These files contain special characters that may break on\n".
  77                      "several systems, please correct:\n",
  78
  79     space         => "These files contain space in their name, which is not well\n"
  80                     ."handled on several systems:\n",
  81
  82     mac_length    => "These files have a name more than 31 characters long, which\n"
  83                     ."will be truncated on Mac OS Classic and old AmigaOS:\n",
  84
  85     amiga_length  => "These files have a name more than 107 characters long, which\n"
  86                     ."will be truncated on recent AmigaOS:\n",
  87
  88     vms_length    => "These files have a name or extension too long for VMS (both\n"
  89                     ."are limited to 39 characters):\n",
  90
  91     dos_length    => "These files have a name too long for MS-DOS and compatible\n"
  92                     ."systems:\n",
  93
  94     case          => "The name of these files differ only by the case, which can\n"
  95                     ."cause real problems on case-insensitive filesystems:",
  96
  97    'symlink'      => "The following files are symbolic links, which are not\n"
  98                     ."supported on several operating systems:",
  99 );
 100
 101 my %bad_names = ();
 102 my %lc_names = ();
 103
 104 sub options {
 105     my %opts = @_;
 106     for my $test (keys %tests) {
 107         $tests{$test} = $opts{"test_$test"} if exists $opts{"test_$test"}
 108     }
 109     for my $opt (keys %options) {
 110         $options{$opt} = $opts{$opt} if exists $opts{$opt}
 111     }
 112     @tests{keys %tests} = (1)x(keys %tests) if $opts{all_tests};
 113 }
 114
 115 sub test_name_portability {
 116     my($file,$file_name,$file_path,$file_ext);
 117
 118     # extract path, base name and extension
 119     if($options{use_file_find}) {  # using Find::File
 120         # skip generated files
 121         return if $_ eq File::Spec->curdir or $_ eq 'pm_to_blib';
 122         my $firstdir = (File::Spec->splitdir(File::Spec->canonpath($File::Find::name)))[0];
 123         return if $firstdir eq 'blib' or $firstdir eq '_build';
 124
 125         $file = $File::Find::name;
 126         ($file_name,$file_path,$file_ext) = fileparse($file, '\\.[^.]+?');
 127
 128     } else {  # only check against MANIFEST
 129         $file = shift;
 130         ($file_name,$file_path,$file_ext) = fileparse($file, '\\.[^.]+?');
 131
 132         #for my $dir (File::Spec->splitdir(File::Spec->canonpath($file_path))) {
 133         #    test_name_portability($dir)
 134         #}
 135
 136         $_ = $file_name.$file_ext;
 137     }
 138     #print STDERR "file $file\t=> path='$file_path', name='$file_name', ext='$file_ext'\n";
 139
 140     # After this point, the following variables are expected to hold these semantics
 141     #   $file must contain the path to the file (t/00load.t)
 142     #   $_ must contain the full name of the file (00load.t)
 143     #   $file_name must contain the base name of the file (00load)
 144     #   $file_path must contain the path to the directory containing the file (t/)
 145     #   $file_ext must contain the extension (if any) of the file (.t)
 146
 147     # check if the name only uses portable filename characters, as defined by ANSI C
 148     if($tests{ansi_chars}) {
 149         /^[A-Za-z0-9][A-Za-z0-9._-]*$/ or $bad_names{$file} .= 'ansi_chars,'
 150     }
 151
 152     # check if the name contains more than one dot
 153     if($tests{one_dot}) {
 154         tr/.// > 1 and $bad_names{$file} .= 'one_dot,'
 155     }
 156
 157     # check if the name contains special chars
 158     if($tests{special_chars}) {
 159         m-[!"#\$%&'\(\)\*\+/:;<>\?@\[\\\]^`\{\|\}~]- # " for poor editors
 160           and $bad_names{$file} .= 'special_chars,'
 161     }
 162
 163     # check if the name contains a space char
 164     if($tests{space}) {
 165         m/ / and $bad_names{$file} .= 'space,'
 166     }
 167
 168     # check the length of the name, compared to Mac OS Classic max length
 169     if($tests{mac_length}) {
 170         length > 31 and $bad_names{$file} .= 'mac_length,'
 171     }
 172
 173     # check the length of the name, compared to AmigaOS max length
 174     if($tests{amiga_length}) {
 175         length > 107 and $bad_names{$file} .= 'amiga_length,'
 176     }
 177
 178     # check the length of the name, compared to VMS max length
 179     if($tests{vms_length}) {
 180         ( length($file_name) <= 39 and length($file_ext) <= 40 )
 181           or $bad_names{$file} .= 'vms_length,'
 182     }
 183
 184     # check the length of the name, compared to DOS max length
 185     if($tests{dos_length}) {
 186         ( length($file_name) <= 8 and length($file_ext) <= 4 )
 187           or $bad_names{$file} .= 'dos_length,'
 188     }
 189
 190     # check if the name is unique on case-insensitive filesystems
 191     if($tests{case}) {
 192         if(not $lc_names{$file} and $lc_names{lc $file}) {
 193             $bad_names{$file} .= 'case,';
 194             $bad_names{$lc_names{lc $file}} .= 'case,';
 195         } else {
 196             $lc_names{lc $file} = $file
 197         }
 198     }
 199
 200     # check if the file is a symbolic link
 201     if($tests{'symlink'}) {
 202         -l $file and $bad_names{$file} .= 'symlink,'
 203     }
 204
 205     # if it's a directory, check that it has no extension
 206     if($tests{'dir_noext'}) {
 207         -d $file and tr/.// > 0 and $bad_names{$file} .= 'dir_noext,'
 208     }
 209 }
 210
 211 sub run_tests {
 212     fileparse_set_fstype('Unix');
 213
 214     if($options{use_file_find}) {
 215         # check all files found using File::Find
 216         find(\&test_name_portability, File::Spec->curdir);
 217
 218     } else {
 219         # check only against files listed in MANIFEST
 220         my $manifest = maniread();
 221         map { test_name_portability($_) } keys %$manifest;
 222     }
 223
 224     # check the results
 225     if(keys %bad_names) {
 226         $Test->ok(0, "File names portability");
 227
 228         my %errors_list = ();
 229         for my $file (keys %bad_names)  {
 230             for my $error (split ',', $bad_names{$file}) {
 231                 $errors_list{$error} = [] if not ref $errors_list{$error};
 232                 push @{$errors_list{$error}}, $file;
 233             }
 234         }
 235
 236         for my $error (sort keys %errors_list) {
 237             $Test->diag($errors_text{$error});
 238
 239             for my $file (sort @{$errors_list{$error}}) {
 240                 $Test->diag("   $file")
 241             }
 242
 243             $Test->diag(' ')
 244         }
 245     } else {
 246         $Test->ok(1, "File names portability");
 247     }
 248 }
 249
 250 } # end of BEGIN