#!/usr/bin/perl
use strict;
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
## no critic(ProhibitExcessComplexity)
BEGIN {
use strict;
use ExtUtils::Manifest qw(maniread);
#use File::Find;
{
no strict 'vars';
$VERSION = '0.05';
@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();
foreach (keys %$manifest) { test_name_portability($_) }
}
# 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