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