Commit | Line | Data |
41e3a7ea |
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 |