Commit | Line | Data |
e7204fba |
1 | #!./perl -Tw |
78201403 |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '../lib'; |
78201403 |
6 | } |
7 | |
08ea998e |
8 | use Test::More tests => 64; |
78201403 |
9 | |
e7204fba |
10 | BEGIN { use_ok 'File::Basename' } |
78201403 |
11 | |
12 | # import correctly? |
e7204fba |
13 | can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) ); |
14 | |
15 | ### Testing Unix |
16 | { |
17 | ok length fileparse_set_fstype('unix'), 'set fstype to unix'; |
3291253b |
18 | is( fileparse_set_fstype(), 'Unix', 'get fstype' ); |
e7204fba |
19 | |
20 | my($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', |
21 | qr'\.book\d+'); |
22 | is($base, 'draft'); |
23 | is($path, '/virgil/aeneid/'); |
24 | is($type, '.book7'); |
25 | |
26 | is(basename('/arma/virumque.cano'), 'virumque.cano'); |
27 | is(dirname ('/arma/virumque.cano'), '/arma'); |
28 | is(dirname('arma/'), '.'); |
e7204fba |
29 | } |
78201403 |
30 | |
78201403 |
31 | |
e7204fba |
32 | ### Testing VMS |
33 | { |
3291253b |
34 | is(fileparse_set_fstype('VMS'), 'Unix', 'set fstype to VMS'); |
78201403 |
35 | |
e7204fba |
36 | my($base,$path,$type) = fileparse('virgil:[aeneid]draft.book7', |
37 | qr{\.book\d+}); |
38 | is($base, 'draft'); |
39 | is($path, 'virgil:[aeneid]'); |
40 | is($type, '.book7'); |
78201403 |
41 | |
e7204fba |
42 | is(basename('arma:[virumque]cano.trojae'), 'cano.trojae'); |
43 | is(dirname('arma:[virumque]cano.trojae'), 'arma:[virumque]'); |
44 | is(dirname('arma:<virumque>cano.trojae'), 'arma:<virumque>'); |
45 | is(dirname('arma:virumque.cano'), 'arma:'); |
78201403 |
46 | |
e7204fba |
47 | { |
48 | local $ENV{DEFAULT} = '' unless exists $ENV{DEFAULT}; |
49 | is(dirname('virumque.cano'), $ENV{DEFAULT}); |
50 | is(dirname('arma/'), '.'); |
51 | } |
78201403 |
52 | } |
78201403 |
53 | |
78201403 |
54 | |
3291253b |
55 | ### Testing DOS |
e7204fba |
56 | { |
3291253b |
57 | is(fileparse_set_fstype('DOS'), 'VMS', 'set fstype to DOS'); |
78201403 |
58 | |
e7204fba |
59 | my($base,$path,$type) = fileparse('C:\\virgil\\aeneid\\draft.book7', |
60 | '\.book\d+'); |
61 | is($base, 'draft'); |
62 | is($path, 'C:\\virgil\\aeneid\\'); |
63 | is($type, '.book7'); |
78201403 |
64 | |
e7204fba |
65 | is(basename('A:virumque\\cano.trojae'), 'cano.trojae'); |
66 | is(dirname('A:\\virumque\\cano.trojae'), 'A:\\virumque'); |
67 | is(dirname('A:\\'), 'A:\\'); |
68 | is(dirname('arma\\'), '.'); |
78201403 |
69 | |
3291253b |
70 | # Yes "/" is a legal path separator under DOS |
e7204fba |
71 | is(basename("lib/File/Basename.pm"), "Basename.pm"); |
3291253b |
72 | |
73 | # $^O for DOS is "dos" not "MSDOS" but "MSDOS" is left in for |
74 | # backward bug compat. |
75 | is(fileparse_set_fstype('MSDOS'), 'DOS'); |
76 | is( dirname("\\foo\\bar\\baz"), "\\foo\\bar" ); |
78201403 |
77 | } |
e7204fba |
78 | |
79 | |
80 | ### Testing MacOS |
81 | { |
82 | is(fileparse_set_fstype('MacOS'), 'MSDOS', 'set fstype to MacOS'); |
83 | |
84 | my($base,$path,$type) = fileparse('virgil:aeneid:draft.book7', |
85 | '\.book\d+'); |
86 | is($base, 'draft'); |
87 | is($path, 'virgil:aeneid:'); |
88 | is($type, '.book7'); |
89 | |
90 | is(basename(':arma:virumque:cano.trojae'), 'cano.trojae'); |
91 | is(dirname(':arma:virumque:cano.trojae'), ':arma:virumque:'); |
92 | is(dirname(':arma:virumque:'), ':arma:'); |
93 | is(dirname(':arma:virumque'), ':arma:'); |
94 | is(dirname(':arma:'), ':'); |
95 | is(dirname(':arma'), ':'); |
96 | is(dirname('arma:'), 'arma:'); |
97 | is(dirname('arma'), ':'); |
98 | is(dirname(':'), ':'); |
99 | |
100 | |
101 | # Check quoting of metacharacters in suffix arg by basename() |
102 | is(basename(':arma:virumque:cano.trojae','.trojae'), 'cano'); |
103 | is(basename(':arma:virumque:cano_trojae','.trojae'), 'cano_trojae'); |
b3eb6a9b |
104 | } |
e7204fba |
105 | |
106 | |
107 | ### extra tests for a few specific bugs |
108 | { |
3291253b |
109 | fileparse_set_fstype 'DOS'; |
e7204fba |
110 | # perl5.003_18 gives C:/perl/.\ |
111 | is((fileparse 'C:/perl/lib')[1], 'C:/perl/'); |
112 | # perl5.003_18 gives C:\perl\ |
113 | is(dirname('C:\\perl\\lib\\'), 'C:\\perl'); |
114 | |
115 | fileparse_set_fstype 'UNIX'; |
116 | # perl5.003_18 gives '.' |
117 | is(dirname('/perl/'), '/'); |
118 | # perl5.003_18 gives '/perl/lib' |
119 | is(dirname('/perl/lib//'), '/perl'); |
b3eb6a9b |
120 | } |
121 | |
e586b3eb |
122 | ### rt.perl.org 22236 |
123 | { |
124 | is(basename('a/'), 'a'); |
125 | is(basename('/usr/lib//'), 'lib'); |
126 | |
127 | fileparse_set_fstype 'MSWin32'; |
128 | is(basename('a\\'), 'a'); |
129 | is(basename('\\usr\\lib\\\\'), 'lib'); |
130 | } |
131 | |
e7204fba |
132 | |
08bc7695 |
133 | ### rt.cpan.org 36477 |
134 | { |
135 | fileparse_set_fstype('Unix'); |
136 | is(dirname('/'), '/'); |
137 | is(basename('/'), '/'); |
138 | |
139 | fileparse_set_fstype('DOS'); |
140 | is(dirname('\\'), '\\'); |
141 | is(basename('\\'), '\\'); |
142 | } |
143 | |
144 | |
08ea998e |
145 | ### basename(1) sez: "The suffix is not stripped if it is identical to the |
146 | ### remaining characters in string" |
147 | { |
148 | fileparse_set_fstype('Unix'); |
149 | is(basename('.foo'), '.foo'); |
150 | is(basename('.foo', '.foo'), '.foo'); |
151 | is(basename('.foo.bar', '.foo'), '.foo.bar'); |
152 | is(basename('.foo.bar', '.bar'), '.foo'); |
153 | } |
154 | |
155 | |
e7204fba |
156 | ### Test tainting |
157 | { |
158 | # The empty tainted value, for tainting strings |
159 | my $TAINT = substr($^X, 0, 0); |
160 | |
161 | # How to identify taint when you see it |
162 | sub any_tainted (@) { |
163 | return ! eval { eval("#" . substr(join("", @_), 0, 0)); 1 }; |
164 | } |
165 | |
166 | sub tainted ($) { |
167 | any_tainted @_; |
168 | } |
169 | |
170 | sub all_tainted (@) { |
171 | for (@_) { return 0 unless tainted $_ } |
172 | 1; |
173 | } |
174 | |
08bc7695 |
175 | fileparse_set_fstype 'Unix'; |
e7204fba |
176 | ok tainted(dirname($TAINT.'/perl/lib//')); |
177 | ok all_tainted(fileparse($TAINT.'/dir/draft.book7','\.book\d+')); |
178 | } |