1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
|
#!./perl -Tw
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
}
use Test::More 'no_plan';
BEGIN { use_ok 'File::Basename' }
# import correctly?
can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) );
### Testing Unix
{
ok length fileparse_set_fstype('unix'), 'set fstype to unix';
my($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
qr'\.book\d+');
is($base, 'draft');
is($path, '/virgil/aeneid/');
is($type, '.book7');
is(basename('/arma/virumque.cano'), 'virumque.cano');
is(dirname ('/arma/virumque.cano'), '/arma');
is(dirname('arma/'), '.');
is(dirname('/'), '/');
}
### Testing VMS
{
is(fileparse_set_fstype('VMS'), 'unix', 'set fstype to VMS');
my($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7',
qr{\.book\d+});
is($base, 'draft');
is($path, 'virgil:[aeneid]');
is($type, '.book7');
is(basename('arma:[virumque]cano.trojae'), 'cano.trojae');
is(dirname('arma:[virumque]cano.trojae'), 'arma:[virumque]');
is(dirname('arma:<virumque>cano.trojae'), 'arma:<virumque>');
is(dirname('arma:virumque.cano'), 'arma:');
{
local $ENV{DEFAULT} = '' unless exists $ENV{DEFAULT};
is(dirname('virumque.cano'), $ENV{DEFAULT});
is(dirname('arma/'), '.');
}
}
### Testing MSDOS
{
is(fileparse_set_fstype('MSDOS'), 'VMS', 'set fstype to MSDOS');
my($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7',
'\.book\d+');
is($base, 'draft');
is($path, 'C:\\virgil\\aeneid\\');
is($type, '.book7');
is(basename('A:virumque\\cano.trojae'), 'cano.trojae');
is(dirname('A:\\virumque\\cano.trojae'), 'A:\\virumque');
is(dirname('A:\\'), 'A:\\');
is(dirname('arma\\'), '.');
# Yes "/" is a legal path separator under MSDOS
is(basename("lib/File/Basename.pm"), "Basename.pm");
}
### Testing MacOS
{
is(fileparse_set_fstype('MacOS'), 'MSDOS', 'set fstype to MacOS');
my($base,$path,$type) = fileparse('virgil:aeneid:draft.book7',
'\.book\d+');
is($base, 'draft');
is($path, 'virgil:aeneid:');
is($type, '.book7');
is(basename(':arma:virumque:cano.trojae'), 'cano.trojae');
is(dirname(':arma:virumque:cano.trojae'), ':arma:virumque:');
is(dirname(':arma:virumque:'), ':arma:');
is(dirname(':arma:virumque'), ':arma:');
is(dirname(':arma:'), ':');
is(dirname(':arma'), ':');
is(dirname('arma:'), 'arma:');
is(dirname('arma'), ':');
is(dirname(':'), ':');
# Check quoting of metacharacters in suffix arg by basename()
is(basename(':arma:virumque:cano.trojae','.trojae'), 'cano');
is(basename(':arma:virumque:cano_trojae','.trojae'), 'cano_trojae');
}
### extra tests for a few specific bugs
{
fileparse_set_fstype 'MSDOS';
# perl5.003_18 gives C:/perl/.\
is((fileparse 'C:/perl/lib')[1], 'C:/perl/');
# perl5.003_18 gives C:\perl\
is(dirname('C:\\perl\\lib\\'), 'C:\\perl');
fileparse_set_fstype 'UNIX';
# perl5.003_18 gives '.'
is(dirname('/perl/'), '/');
# perl5.003_18 gives '/perl/lib'
is(dirname('/perl/lib//'), '/perl');
}
### Test tainting
{
# The empty tainted value, for tainting strings
my $TAINT = substr($^X, 0, 0);
# How to identify taint when you see it
sub any_tainted (@) {
return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 };
}
sub tainted ($) {
any_tainted @_;
}
sub all_tainted (@) {
for (@_) { return 0 unless tainted $_ }
1;
}
ok tainted(dirname($TAINT.'/perl/lib//'));
ok all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+'));
}
|
