Merge default-code.t to default.t
[gitmo/Mouse.git] / xt / 04_fs_portability.t
CommitLineData
41e3a7ea 1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6Test::Portability::Files->import();
7
8options(
9 test_ansi_chars => 0,
10 test_dos_length => 0,
11 test_mac_length => 0,
12 test_amiga_length => 0,
13
14);
15run_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
20BEGIN{
21package Test::Portability::Files;
22use strict;
23use ExtUtils::Manifest qw(maniread);
24use File::Basename;
25#use File::Find;
26use File::Spec;
27use Test::Builder;
28
29{ no strict;
30 $VERSION = '0.05_01';
31 @EXPORT = qw(&options &run_tests);
32 @EXPORT_OK = @EXPORT;
33}
34
35my $Test = Test::Builder->new;
36
37sub 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
50my %options = (
51 use_file_find => 0,
52);
53
54my %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
68my %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
101my %bad_names = ();
102my %lc_names = ();
103
104sub 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
115sub 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
211sub 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