Update ignore files
[gitmo/Mouse.git] / xt / 004-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